      program specshow
      USE DFLIB
      use dfport
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(KPNT=100001,KCN=2001,MAXIDE=100000)
      PARAMETER (kw=99)
      parameter (md=9999)
      parameter (MREF=120000)
      COMMON/FNAMES/FNMODEL,FNLINES,FNOBSPEC
      character*60 fnmodel,FNLINES,FNOBSPEC
      COMMON/LNRANGE/WLA1,WLA2,CBV
      COMMON/LCALDATA/XI,STWV,ENWV,NPOINT,NCON,NVAR,NCODE(99),DEPSL(99)
      COMMON/SYNPROF/WLTH(KPNT),AINT(KPNT),RESIDF(KPNT),ABSF(KPNT)
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL
      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP

      common/abundstd/numabs,abstd(99)
      character*2 elem,che
      logical loexist,loopen,loexthe,loexlin,loexobs,loexist1
      type (windowconfig) myscreen
      integer*4 backcolor,forecolor,textcolor,spobcolor,spthcolor,
     &spidcolor,sprecolor,spadcolor
      character*16 fontstd,fontide
      character*40 xlabel,ylabel
      common/grwinset/myscreen,fontstd,fontide,
     &backcolor,forecolor,textcolor,spobcolor,spthcolor,spidcolor,
     &sprecolor,spadcolor(3)
      common/overplotc/spthcadd(4),maskcolor,rngecolor,gauscolor,
     & bisecolor
      integer*4 spthcadd,maskcolor,rngecolor,gauscolor,bisecolor
      common/frameset/ngtx,ngty,xlmargin,xrmargin,ytmargin,ydmargin,
     &ltickp,xlabel,ylabel
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/ident/nide,lnident(MAXIDE)
      character*66 lnident
      common/labtit/labthe,labobs,lablin
      character*60 labthe,labobs,lablin
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/tysave/nspec,ythsv(kpnt,5),xthsv(kpnt,5),npsv(5)
      common/spec/nd,xs(md),ys(md)
c      data dladef/0.02d0/,dlcdef/2.00d0/,xistd/2./
      data wla1,wla2,cbv/-1.,-1.,0./
      data stwv,enwv,npoint,ncon/-1.,-1.,-1,-1/
      data resolu/0./,epsld/0.5/,ifqcal/0/,ifewid/0/
      type (qwinfo) winfo
      logical*4 result
      character*1 ch
      character*80 line,linedir
      character*120 lab1,lab2
      common/dirpath/nsdir,nedir,linedir
      character*60 flistnm,fnlinessv,fnobspecsv
      character*60 flistnm1,flistnm2
      character*8 labelkey
      character ateff*5,aglog*4,aglog1*3,axlog*5,axlog1*4,amole*1
      character*80 moddir,datdir
      character*72 cpanelgo
      common/cppass/nscp,necp,cpanelgo
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      common/crit_eta/etacrt
c
      character*60 fnrefspec,labref
      logical LOREFR
      common/refspec/nr,wrf1,wrf2,dwrf,xr(MREF),yr(MREF)
      common/reflab/LOREFR,fnrefspec,labref
      data LOREFR/.false./
c
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/batch/fndb_def,
     & fndb,spandb,idb,ndb,last,isv(999),wlamdb(999),labdb(999)
      character fndb_def*60,fndb*60,labdb*80
c
      common/ewdbout/dwcrt,loewout,fnewout
      character*60 fnewout
      logical loewout
      common/tilt/tilta
      common/dummyorder/npx,nmar
      common/bisector/ifbisec
      dimension numser(999)
      character*60 fnmultobs,tfnolist,fnolist(999)
      common/nspass/nspecify,ifmultobs,imfcur,nmfile,numser,
     & fnmultobs,fnolist

      common/dopcorrect/dopcor,dopref,dcfac,drfac
      common/fnorgpass/fnobspec_org
      character*60 fnobspec_org,fnobspec_dum
c
      integer*2 narg1,narg2
      character*80 buf,charw(200)
      character*60 sarg1,sarg2
      character*80 sptooldir
      logical mstatus
      common/ewprm/dwsp_n,dwsp,ngeta
      common/grparams/ek,adamp,area
      common/fluxmode/ifabs
      common/synfincheck/ifsame,ifsynfin
c
      character*60 fnlameps
      common/epspass/ep,nlimda,wlalimda(2000),epslimda(2000)

      COMMON /ITER/ ITER,IFPRNT(15),IFPNCH(15),NUMITS
      common/convf2t/ifconvf
      common/unfocus/ifunplot
      common/ifrefvlink/ifrefvlink
      common/ymgpass/ryymg
c
c_bbb
      common/auto/ifauto,iapdum,ifn
      open (unit=6,status='scratch')
      ifauto=0
      iapdum=0
c_fff

      iter=1
      ifprnt(1)=0
      ifpnch(1)=0
      numits=1

      ifunplot=1
      ryymg=0.5
      ifrefvlink=0
c     setting the size of the frame window maximum
      winfo.type=qwin$max
      status=setwsizeqq(qwin$framewindow,winfo)

c     menu editing
c
      mstatus=deletemenuqq(6,1)
      mstatus=deletemenuqq(6,1)
      mstatus=aboutboxqq
     % ('SPSHOW by Yoichi Takeda (NAOJ)')

      narg1=1
      sarg1=''
      call getarg(narg1,buf)
      read(buf,'(a)',err=19,end=19) sarg1
   19 continue
      call lablen(sarg1,60,ns_1,ne_1)    

      narg2=2
      sarg2=''
      call getarg(narg2,buf)
      read(buf,'(a)',err=29,end=29) sarg2
   29 continue
      call lablen(sarg2,60,ns_2,ne_2)

      ifconvf=0
      flistnm=''
      listf=1

      if(ns_1.lt.ne_1) then
        if(index(sarg1,'-fits2text').gt.0.or.
     &   index(sarg1,'/fits2text').gt.0) then
          ifconvf=1
        else
          flistnm=sarg1
        end if 
      end if

      if(ns_2.lt.ne_2) then
        if(index(sarg2,'-fits2text').gt.0.or.
     &   index(sarg2,'/fits2text').gt.0) then
          if(ifconvf.eq.1) then
            write(*,*) 'fits2text option has been specified twice!'
            write(*,*) 'stopped!'
            stop
          else
            ifconvf=1
            go to 39
          end if
        else
          if(len_trim(flistnm).gt.0) then
            write(*,*) 
     &        'Each Argument (filename/option) must NOT contain blank!'
            write(*,*) 'stopped!'
            stop
          else
            flistnm=sarg2
            go to 39
          end if
        end if
      end if
   39 continue 

c     check filename
      call dopcheck(flistnm,flistnm1,dcdummy)
      call checkfit(flistnm1,ifbl,norder)
      if(iabs(ifbl).gt.1) then
        flistnm2=flistnm1(1:iabs(ifbl)-1)
      else
        flistnm2=flistnm1
      end if
      inquire(file=flistnm2,exist=loexist)
      if(len_trim(flistnm2).gt.0.and..not.loexist) then
        write(*,*) 'Not found/undestood the specified argument -->'//
     &   trim(flistnm)
       write(*,*) 'Check if the specified file '//
     & 'really exists (or if the option is really allowed) ...'
        write(*,*) 'Stopped!'
        stop
      end if

      dopcor=0.
      dcfac=1.00000000000000
      dopref=0.

      ifmultobs=0
      nspecify=0
      do im=1,999
        numser(im)=0
      end do
c      ifbisec=0
      ifbisec=1
      nr=0
      ifn=0
      idb=0
      tilta=0.

c     initializing broadening parameters
      vw=0.
      rp=0.

      ifabs=0
      ifsynfin=0

      call lablen(flistnm,60,nsfl,nefl)
      if(nsfl.gt.nefl) go to 610

c
c     checks whether the argument 1 is cpanel file or obspec file
c                                      (ifcpa=1)      (ifcpa=0)
c
      inquire(file=flistnm,exist=loexist)
c     check the possibility of fobspec with {} or [] (naturally ifcpa=0)
      if(.not.loexist) then
        ifcpa=0
        go to 509
      end if
c     now examine the contents of the file
      open (unit=57,file=flistnm)
      do k=1,5
      read(57,'(a)',err=507,end=507) line
      end do
      if(line(1:8).eq.'#CPANEL@') then
        ifcpa=1
        go to 508
      end if
  507 continue
      ifcpa=0
  508 close (57)
  509 continue
c

       if(ifcpa.eq.0) then
      	ifn=1
        fnobspec_dum=flistnm
c\\\\
        call lablen(fnobspec_dum,60,nsm,nem)
c
        ifyen=index(fnobspec_dum,'\',.true.)
        if(ifyen.gt.0) nsm=ifyen+1
c
        if(fnobspec_dum(nsm:nsm).eq.'@') then
          write(*,
     &    '(''Entering into the multobs mode.(IFMULTOBS->1)'')')
          ifmultobs=1
          fnmultobs=fnobspec_dum
          open (unit=59,file=fnmultobs(nsm:nem))
          imcnt=0
          do imf=1,9999
          read(59,'(a)',err=5999,end=5999) tfnolist
          call lablen(tfnolist,60,nsy,ney)
          do iy=nsy,ney
            if(tfnolist(iy:iy).eq.' ') go to 5905
          end do
 5905     iyb=iy
          read(tfnolist(nsy:iyb-1),*) imfile
          if(imfile.lt.1.or.imfile.gt.999) then
            write(*,*) 'Invalid spectrum number in the filelist--> ',
     &      imfile
            write(*,*) 'which should be within 1<= N <= 999: Stopped!'
            stop
          end if
          fnolist(imfile)=tfnolist(iyb+1:ney)
          imcnt=imcnt+1
          numser(imcnt)=imfile
          end do
 5999     continue
          nmfile=imcnt
          close (59)
          imfcur=1
          nspecify=numser(imfcur)
          fnobspec_org=fnolist(nspecify)
        else
          fnobspec_org=fnobspec_dum
        end if
c\\\\


        call dopcheck(fnobspec_org,fnobspec,dopcor)
          if(dopcor.ne.0.) then
            dcfac=1.+dopcor/2.997925e5
          else
            dcfac=1.
          end if
      	labobs=fnobspec
      	fnmodel=''
      	labthe=fnmodel
      	fnlines=''
      	lablin=fnlines
      	loexthe=.false.
      	loexlin=.false.
      	loexobs=.true.
      	nide=0
      end if

  610 continue
      inquire(file=flistnm,exist=loexist)

      if( (ifn.eq.0) .and. (.not.loexist) ) then
        write(*,*) 'No argument! Specify files in cpanel.txt ...'
        listf=0
      end if
c
c      call getenv("SPT_DIR",linedir)
      call retenv("SPT_DIR",linedir)
      call lablen(linedir,80,nsdir,nedir)
c
c      call getenv("MOD_DIR",moddir)
      call retenv("MOD_DIR",moddir)
      call lablen(moddir,80,msdir,medir)
c
      call getenv("SPTOOL",sptooldir)
      call lablen(sptooldir,80,nspts,nspte)
      inquire(file='.\window.ini',exist=loexist)
      if(loexist) then
      open (unit=1, file='.\window.ini')
      else
      open (unit=1, file=sptooldir(nspts:nspte)//'\'//'window.ini')
      end if
      rewind 1
      lw=0
      do i=1,999
      read(1,'(a)',end=399,err=399) charw(i)
      lw=lw+1
      end do
  399 continue
      close (1)

      read(charw(1),*) myscreen.numxpixels
      read(charw(2),*) myscreen.numypixels
      read(charw(3),*) myscreen.numtextcols
      read(charw(4),*) myscreen.numtextrows
      read(charw(5),*) myscreen.numcolors
      read(charw(6),*) myscreen.fontsize
      read(charw(7),*) myscreen.title
      read(charw(8),*) fontstd
      read(charw(9),*) fontide
      read(charw(10),'(z6)') backcolor
      read(charw(11),'(z6)') forecolor
      read(charw(12),'(z6)') textcolor
      read(charw(13),'(z6)') spobcolor
      read(charw(14),'(z6)') spthcolor
      read(charw(15),'(z6)') spthcadd(1)
      read(charw(16),'(z6)') spthcadd(2)
      read(charw(17),'(z6)') spthcadd(3)
      read(charw(18),'(z6)') spthcadd(4)
      read(charw(19),'(z6)') spidcolor
      read(charw(20),'(z6)') sprecolor
      read(charw(21),'(z6)') spadcolor(1)
      read(charw(22),'(z6)') spadcolor(2)
      read(charw(23),'(z6)') spadcolor(3)
      read(charw(24),'(z6)') maskcolor
      read(charw(25),'(z6)') rngecolor
      read(charw(26),'(z6)') gauscolor
      read(charw(27),'(z6)') bisecolor
      read(charw(28),*) ngtx,ngty
      read(charw(29),*) xlmargin,xrmargin,ytmargin,ydmargin
      read(charw(30),*) ltickp
      read(charw(31),*) xlabel
      read(charw(32),*) ylabel
      read(charw(33),*) ymaxstd
      read(charw(34),*) dladef
      read(charw(35),*) dlcdef
      read(charw(36),*) etacrt
      read(charw(37),*) ifmole_def
      read(charw(38),*) xistd
c
c      read(charw(39),*) epsld
      call lablen(charw(39),80,nse1,nse2)
      ch=charw(39)(nse1:nse1)
        if(ifnum(ch).eq.1) then
          read(charw(39),*) epsld
          nlimda=1
          wlalimda(1)=0.
          epslimda(1)=epsld
          ep=epsld
        else
          isp=index(charw(39)(nse1:nse2),' ')
          fnlameps=charw(39)(nse1:isp-1)
          inquire(file=fnlameps,exist=loexist)
          if(.not.loexist) then
            write(*,*) 'fnlameps not exist -->',fnlameps
            stop
          end if
          open (unit=67,file=fnlameps)
          nlt=0
          do le=1,9999
            read(67,'(a)',end=6799) line
            call lablen(line,80,nse1,nse2)
            ch=line(nse1:nse1)
            if(ifnum(ch).eq.1) then
              nlt=nlt+1
              read(line,*) wlalimda(nlt),epslimda(nlt)
              if(nlt.gt.2000) then
                 write(*,*) 'Too large wavenumber points !'
                 stop
              end if
            end if
          end do
 6799     close (67)
          nlimda=nlt
          ep=0.
        end if  
c
      read(charw(40),*) spandb
      read(charw(41),*) dwcrt
      read(charw(42),*) npx,nmar
      read(charw(43),*) dwsp_n,dwsp,ngeta
      read(charw(44),*) ek,adamp
      read(charw(45),*) fndb_def
      read(charw(46),*)
      read(charw(47),'(a)') cpanelgo
      read(charw(48),*)
      read(charw(49),*)
      do iz=1,99
      abstd(iz)=abund(iz)
      end do
      numabs=0
      read(charw(50),*) numabs
      if(numabs.gt.0) then
        do ie=1,numabs
         read(charw(50+ie),*) iz,abstd(iz)
        end do
      end if
      if(npx.gt.md) then
        write(*,*) 'npx > md ! ',npx,md
        stop
      end if
      call lablen(cpanelgo,72,nscp,necp)
      if(ifn.eq.1) go to 400
      if(listf.eq.0) then
        fnobspec=''
        fnobspec_org=''
c        fnmodel='t#####g%%%x$&&&m#'
        fnmodel=''
        fnlines=''
        ifmole=ifmole_def
        incpanel=0
      else
        open (unit=3, file=flistnm)
        rewind 3
        read(3,'(a60)') fnobspec_org
        call dopcheck(fnobspec_org,fnobspec,dopcor)
          if(dopcor.ne.0.) then
            dcfac=1.+dopcor/2.997925e5
          else
            dcfac=1.
          end if
        labobs=fnobspec
        read(3,'(a60)') fnmodel
        call lablen(fnmodel,60,ns,ne)
        labthe=fnmodel
        read(3,'(a60)') fnlines
        lablin=fnlines
        read(3,*) ifmole
c
c       remove the offset value (added by cpanel) if necessary
        if(ifmole.ge.2) ifmole=ifmole-2
c
        if(ifmole.ne.0.and.ifmole.ne.1) then
        write(*,'(''Either 0 or 1 is allowed for ifmole:'',i4)') ifmole
        stop
        end if
        incpanel=0
        read(3,'(a8)',err=430,end=430) labelkey
        if(labelkey.eq.'#CPANEL@') incpanel=1
  430   continue
        close (3)
      end if

c     copy flistnm as cpane.txt in case of being specified in argument
      if(incpanel.eq.1) then
        call lablen(flistnm,60,ns,ne)
        result= systemqq('copy /Y '//flistnm(ns:ne)//' cpanel.txt')
      end if
c     if linedat.tmp exists, it is renamed as linedat.old
      inquire(file='linedat.tmp',exist=loexist)
      if(loexist) then
        inquire(file='linedat.old',exist=loexist1)
        if(loexist1) result=systemqq('del linedat.old')
        result= systemqq('ren linedat.tmp linedat.old')
      end if
c
  400 continue
      modeg=1

      do while (1)
      if(ifn.eq.1) go to 401
4800  continue
      if(ifqcal.eq.1) then
      ifqcal=0
cdec      write(*,*) 'Now calculating, please be patient ...'
      go to 5000
      end if

      inquire(file='cpanel.txt',exist=loexist)
c     refresh/initialize xi and abundance data
      if((.not.loexist).or.(incpanel.eq.0)) then
        if(incpanel.eq.0) incpanel=1
        open (unit=4,file='cpanel.txt')
        rewind 4
        xi=xistd
        write(4,'(a60,a11)') fnobspec_org,'|(fnobspec)'
        write(4,'(a60,a10)')  fnmodel,'|(fnmodel)'
        write(4,'(a60,a10)')  fnlines,'|(fnlines)'
        write(4,'(i1,59x,''|(ifmole)'')') ifmole
        write(4,'(a)') '#CPANEL@'
        write(4,'(a)') '# << xi/abundance data used for synthesis>>'
        write(4,'(a)') '# (Recommending to change to overwrite mode)'
        write(4,'(a)') '# '
        write(4,'(a)') '# What you can edit is from columns 7 to 12'
        write(4,'(a)') '#                      ~~~~~~~~~~~~~~~~~~~~'
        write(4,'(a)') '# (logarithmic abundance change relative to'
        write(4,'(a)') '# the standard abundance of the model)'
        write(4,'(a)') '# '
        write(4,'(a)') '# Touching other parts is meaningless,'
        write(4,'(a)') '# since they are to be filled by the program'
        write(4,'(a)') '# '
        write(4,'(a)') '#     @@@@@@'
        write(4,'(a)') '# '
        write(4,'(6x,f6.2,f6.1,f8.0,i4,''  ! xi, vw, rp, ifabs'')')
     &  xi,vw,rp,ifabs
        nvar=99
        do iv=1,nvar
        che=elem(iv)
        ncode(iv)=iv
        depsl(iv)=0.
        write(4,'(a2,i4,f6.2)') che,ncode(iv),depsl(iv)
        end do
        close (4)
      end if
c...... read data from cpanel.txt ........
c        write(*,*) 'Shown are the contents (abund/xi) of cpanel.txt.   '
c        write(*,*) 'Please check, modify (if necessary), and save them.'
c        write(*,*) 'You can proceed further after its CLOSING.         '
c        write(*,*) '                                  ~~~~~~~          '
c
c       first make a backup of current 'cpanel.txt' as 'cpanel.tmp'
        inquire(file='cpanel.tmp',exist=loexist)
        if(loexist) result=systemqq('del cpanel.tmp')
        result=systemqq('copy cpanel.txt cpanel.tmp')
c
        if(cpanelgo(max(1,necp-9):necp).eq.'cpanel.exe') then
        result=
     %  systemqq('start /WAIT '//linedir(nsdir:nedir)//'\cpanel.exe')
        else
        result= systemqq('start /WAIT '//cpanelgo(nscp:necp))
        end if
c
c       Check if the contents of the current 'cpanel.txt' has 
c       any change from the previous 'cpanel.tmp'
        open (unit=63,file='cpanel.tmp')
        open (unit=64,file='cpanel.txt')
        ifsame=0
        do i=1,9999
          read(63,'(a)',end=6009) lab1
          read(64,'(a)',end=6009) lab2
          if(lab1.ne.lab2) go to 6001
        end do
 6009   ifsame=1
 6001   continue
        close (63)
        close (64)
c***
c     In case synthesis calculation has already been done and no change 
c     has been applied to cpanel.txt, we jump directly to 2081
c     without doing any new synthesis calculation which is skipped
c
        if(ifsynfin.eq.1.and.ifsame.eq.1) go to 2081
c***
c        write(*,*) 'Now calculating, please be patient...'
        open (unit=4,file='cpanel.txt')
        rewind 4
c
        fnobspecsv=fnobspec
        read(4,'(a60)') fnobspec_org
        call dopcheck(fnobspec_org,fnobspec,dopcor)
          if(dopcor.ne.0.) then
            dcfac=1.+dopcor/2.997925e5
c           reset dshft
            dshft=0.
          else
            dcfac=1.
          end if
  401   continue
        call lablen(fnobspec,60,ns,ne)
        if(fnobspec(ns:ns).eq.'!') fnobspec=''
        labobs=fnobspec
        call lablen(fnobspec,60,ns,ne)
        nd=0
        if (ns.ge.ne) then
          loexobs=.false.
        else
          call checkfit(fnobspec,ifbl,norder)
              if(ifbl.ne.0) then
                 inquire(file=fnobspec(1:iabs(ifbl)-1),exist=loexobs)
               else
                 inquire(file=fnobspec,exist=loexobs)
               end if
              if(loexobs)call specread(88,fnobspec,ifbl,norder,nd,xs,ys)
        end if

        tilta=0.

        if(numord.gt.1.and.lolimit) go to 222
c
        call checkfit(fnobspecsv,ifblsv,nordersv)
c
        if(ifbl*ifblsv.ne.0 .and.
     &   fnobspec(1:iabs(ifbl)-1).eq.fnobspecsv(1:iabs(ifbl)-1) .and.
     &   norder.ne.nordersv) then
           modeg=1
           nspec=1
         end if

  222    continue
c
        xsmax=-1.e30
        xsmin=+1.e30
        do i=1,nd
        if(xs(i)*dcfac.gt.xsmax) xsmax=xs(i)*dcfac
        if(xs(i)*dcfac.lt.xsmin) xsmin=xs(i)*dcfac
        end do

c       reset the user-assigned wavelength limit(s) if being outside of
c       the actually available spectral range (e.g., for the case of [0,9999])
        if(numord.gt.1.and.lolimit) then
      	  xqn=min(wlmul(1,1),wlmul(1,numord))
      	  xqx=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
          if(wmne.lt.xqn) wmne=xqn
          if(wmxe.gt.xqx) wmxe=xqx
        end if
c
      if(numord.gt.1.and.lolimit) then
      	xsmin=wmne
      	xsmax=wmxe
      end if
c

      if(ifn.eq.1) go to 5000
c
        read(4,'(a60)') fnmodel
        call lablen(fnmodel,60,ns,ne)
        if(fnmodel(ns:ns).eq.'!') fnmodel=''
        inquire(file=fnmodel,exist=loexthe)
        call lablen(fnmodel,60,ns,ne)
        if(( .not.loexthe ) .and.
     &  ne-ns+1.eq.17.and.fnmodel(ns:ns).eq.'t' .and.
     &  fnmodel(ns+6:ns+6).eq.'g'.and.
     &  fnmodel(ns+10:ns+10).eq.'x' .and.
     &  fnmodel(ns+15:ns+15).eq.'m' ) then
          read(fnmodel(2:6),'(a5)') ateff
          read(fnmodel(8:10),'(a3)') aglog1
          read(fnmodel(12:15),'(a4)') axlog1
          read(fnmodel(17:17),'(a1)') amole

c         check if correct numeric numbers are specified
          idumt=-999
          idumg=-999
          idumx=-999
          idumm=-999
          read(ateff,*,err=109) idumt
          if(idumt.lt.03500.or.idumt.gt.50000) go to 109
          read(aglog1,*,err=109) idumg
          if(idumg.lt.000.or.idumg.gt.500) go to 109
          read(axlog1,*,err=109) idumx
          if(idumx.lt.-550.or.idumx.gt.+100) go to 109
          read(amole,*,err=109) idumm
          if(idumm.ne.0.and.idumm.ne.1) go to 109
          go to 110
  109     loexthe=.false.
          write(*,*) 'idumt,idumg,idumx,idumm:',idumt,idumg,idumx,idumm
          write(*,*) 'Sorry, specified model parameters unsupported!'
          go to 4700
  110     continue
c
          aglog=aglog1(1:1)//'.'//aglog1(2:3)
          axlog=axlog1(1:2)//'.'//axlog1(3:4)
          line=linedir(nsdir:nedir)//
     %    '\msearch '//ateff//' '//aglog//' '//axlog
          call lablen(line,80,nsqq,neqq)
          write(*,'(a)') line(nsqq:neqq)
          result=systemqq(line(nsqq:neqq))
          line=linedir(nsdir:nedir)//'\mprep '//amole
          call lablen(line,80,nsqq,neqq)
          write(*,'(a)') line(nsqq:neqq)
          result=systemqq(line(nsqq:neqq))
          line=linedir(nsdir:nedir)//
     %    '\mdinterp '//ateff//' '//aglog//' '//axlog//' '//amole
          call lablen(line,80,nsqq,neqq)
          write(*,'(a)') line(nsqq:neqq)
          result=systemqq(line(nsqq:neqq))

                inquire(file=fnmodel,exist=loexthe)
                if(.not.loexthe) then
                write(*,*) 'failed to create '//fnmodel
                write(*,*) 'program stopped (loexthe) -->!$?'
                stop
                end if
        end if
 4700   continue
        labthe=fnmodel
c
        fnlinessv=fnlines
        read(4,'(a60)') fnlines
        call lablen(fnlines,60,ns,ne)
        if(fnlines(ns:ns).eq.'!') fnlines=''
        call lablen(fnlines,60,ns,ne)
        if((ns.gt.ne).and.loexthe.and.loexobs) then
             if(xsmax.gt.999999..or.xsmin.gt.xsmax)then
                    write(*,*) 'xsmin,xsmax:',xsmin,xsmax
                    write(*,*) 'auto gf-preparation not supported!'
                    write(*,*) 'Specify the file of line-data again!'
                    write(*,*) 'Going back to the starting point .....'
                    go to 4800
c                    stop
             end if
            ixsmin=int(xsmin)-1
            ixsmax=int(xsmax+0.5)+1
            if(ixsmax.le.9999) then
              write(fnlines,'(2i4.4,''.kgf'')') ixsmin,ixsmax
            else if(ixsmax.le.99999) then
              write(fnlines,'(2i5.5,''.kgf'')') ixsmin,ixsmax
            else if(ixsmax.le.999999) then
              write(fnlines,'(2i6.6,''.kgf'')') ixsmin,ixsmax
            end if
cc
c            write(*,'(''We are going to create the line file: '',a12)')
c     &      fnlines(1:12)
c            write(*,*)
c     &      'covering the wavelength range of the obs. spectrum'
c            write(*,*) 'In case you want to cancel, just press "!" key'
c            write(*,*) 'Press any other key to proceed...'
c            ch=getcharqq()
c            if(ch.eq.'!') then
c            write(*,*) 'line-file creation has been cancelled!'
c            write(*,*) 'Going back to the starting point .....'
c            go to 4800
c            end if
cc
        end if
        inquire(file=fnlines,exist=loexlin)
        call lablen(fnlines,60,ns,ne)
        lablin=fnlines
        if(fnlines.ne.fnlinessv) then
          nspec=1
          modeg=1
        end if
        ifkgf=0
        if( (mod(ne-ns+1-4,2).eq.0).and.(ne-ns+1-4.ge.6).and.
     &      (ne-ns+1-4.le.12).and.(fnlines(ne-3:ne).eq.'.kgf')
     &      .and.(.not.loexlin) ) then
            call setkgf(fnlines)
            inquire(file=fnlines,exist=loexlin)
            if(.not.loexlin) then
                write(*,*) 'failed to create '//fnlines
                write(*,*) 'stopped (loexlin) -->!$?'
                stop
            end if
        end if
c
        read(4,*) ifmole
c       program stops if this ifmole has an emergency value of 2 or 3 
c       (i.e., with +2 offset)
        if(ifmole.ge.2) stop
c
        read(4,'(a)') line
        do while(line(1:1).eq.'#')
        read(4,'(a)') line
        end do
        backspace 4
        read(4,'(6x,f6.2,f6.1,f8.0,i4)') xi,vw,rp,ifabs
        nvar=99
        do iv=1,nvar
          read(4,'(a2,i4,f6.2)') che,ncode(iv),depsl(iv)
        end do
        close (4)
 5000 continue

      if( ((loexthe).and.(.not.loexlin)) .or.
     &    ((.not.loexthe).and.(loexlin)) ) then
      write(*,'(''loexthe='',L2,3x,''loexlin='',L2,3x,''loexobs='',L2)')
     & loexthe,loexlin,loexobs
      write(*,*) 'Incompatible! You must check the file name!'
      write(*,*) 'Going back to the starting point .....'
      go to 4800
c      write(*,*) 'stopped!'
c      stop
      end if

      ifthex=0
      if(loexthe.and.loexlin) ifthex=1

      if( (ifthex.eq.0) .and. (.not.loexobs) ) then
      write(*,'(''loexthe='',L2,3x,''loexlin='',L2,3x,''loexobs='',L2)')
     & loexthe,loexlin,loexobs
      write(*,*) 'Can not be helped!  You must check the file name!'
      write(*,*) 'Going back to the starting point .....'
      go to 4800
c      write(*,*) 'stopped!'
c      stop
      end if

      if(ifthex.eq.0) then
ct
           modeg=1
ct
cdec        open (unit=6, file='USER')
        winfo.type=qwin$min
        idum=setwsizeqq(6,winfo)
        go to 2081
      end if

c**** mole ****b
      ifmol=0
      ifpres=0
      call retenv("DAT_DIR",datdir)
      call lablen(datdir,80,ndsdir,ndedir)
      if(ifmole.eq.1) then
      ifmol=1
      ifpres=1
      open (unit=2,file=datdir(ndsdir:ndedir)//'\'//'molec.dat')
      rewind 2
      call readmol
      write(6,*)
      write(6,'('' <<< molecules formation to be included >>>'')')
      write(6,'(''     ifmol = '',i2,4x,''ifpres = '',i2)') ifmol,ifpres
      write(6,*)
      close (2)
      end if
c**** mole ****e
      if(ifthex.eq.1) then
c        inquire(unit=5,opened=loopen)
c        if(loopen) close (5)
        open (unit=5,file=fnmodel,shared)
        rewind 5
c1        inquire(unit=9,opened=loopen)
c1        if(loopen) close (9)
c1        open (unit=9,file=fnlines)
c1        rewind 9
      end if
cdec      open (unit=6, file='USER')
c       minimize unit6 window
cdec         winfo.type=qwin$min
cdec         idum=setwsizeqq(6,winfo)
c
      call wsearch(twla1,twla2)
      wla1=twla1
      wla2=twla2
      stwv=int(wla1)
      enwv=int(wla2)+1
      npoint=int((enwv-stwv)/dladef+0.5)+1
      ncon=int((enwv-stwv)/dlcdef+0.5)+1
        if(npoint.gt.kpnt.or.ncon.gt.kcn) then
        write(*,*) 'Too large npoint=',npoint,' or ncon=',ncon
        stop
        end if
c      if(modeg.eq.1) then
cc       maximize unit6 window to show only for the first time
c        winfo.type=qwin$max
c        idum=setwsizeqq(6,winfo)
c      else
cc       minimize unit6 window
c         winfo.type=qwin$min
c        idum=setwsizeqq(6,winfo)
c      end if
c
      call synspec
c
 2081 continue
      idum=focusqq(0)
ctak
c       maximize unit0 window to show only for the first time
        winfo.type=qwin$max
        idum=setwsizeqq(0,winfo)
ctak
    1 call draw(modeg)
      irt=0
      do while (irt.eq.0)
        call chngparm(irt)
      end do
      if (irt.eq.1) then
        modeg=modeg+1
        go to 1
      end if
      if (irt.eq.2) then
        modeg=modeg+1
        cycle
      end if
      end do
      stop
      end

      subroutine draw(modeg)
      USE DFLIB
      PARAMETER(KPNT=100001)
      parameter (md=9999)
      implicit real*8 (a-h,o-z)
      integer*2 status
      type (qwinfo) winfo
      type (windowconfig) myscreen
      integer*4 backcolor,forecolor,textcolor,spobcolor,spthcolor,
     &spidcolor,sprecolor,spadcolor
      character*16 fontstd,fontide
      character*40 xlabel,ylabel
      common/grwinset/myscreen,fontstd,fontide,
     &backcolor,forecolor,textcolor,spobcolor,spthcolor,spidcolor,
     &sprecolor,spadcolor(3)
      common/frameset/ngtx,ngty,xlmargin,xrmargin,ytmargin,ydmargin,
     &ltickp,xlabel,ylabel
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/spec/nd,xs(md),ys(md)
      COMMON/FNAMES/FNMODEL,FNLINES,FNOBSPEC
      character*60 fnmodel,FNLINES,FNOBSPEC
      COMMON/LNRANGE/WLA1,WLA2,CBV
      COMMON/LCALDATA/XI,STWV,ENWV,NPOINT,NCON,NVAR,NCODE(99),DEPSL(99)
      COMMON/SYNPROF/WLTH(KPNT),AINT(KPNT),RESIDF(KPNT),ABSF(KPNT)
      common/svxymm0/xmin0,xmax0,ymin0,ymax0,dshft0,vw0,threseta0,rp0
      common/mask/fz,yshift,imk,wms(99),wme(99)
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
c
      common/dopcorrect/dopcor,dopref,dcfac,drfac
      common/fluxmode/ifabs

      if(modeg.gt.1) go to 100
ccctakedatemp
cc      if(nd.eq.0) nd=1
ccctakedatemp

c     check if observed spectrum is normalized
      sum=0.
      tx1=1.e30
      tx2=-1.e30
      ty1=1.e30
      ty2=-1.e30
c      do k=1,nd
      do k=1,max(nd,1)
      if(xs(k)*dcfac.lt.tx1) tx1=xs(k)*dcfac
      if(xs(k)*dcfac.gt.tx2) tx2=xs(k)*dcfac
      if(ys(k).lt.ty1) ty1=ys(k)
      if(ys(k).gt.ty2) ty2=ys(k)
      sum=sum+ys(k)
      end do
c      yaver=sum/nd
      yaver=sum/max(nd,1)
      ifnorm=1
      if(yaver.gt.ymaxstd) ifnorm=0
      if(ifthex.eq.0) then
        xmin=tx1
        xmax=tx2
        ymin=ty1*0.0
        ymax=ty2*ymaxstd
        if(numord.gt.1.and.lolimit) then
	        xmin=wmne
    	    xmax=wmxe
        end if
      else
        xmin=STWV
        xmax=ENWV
        ymin=0.
        ymax=ymaxstd
      end if
c
      dshft=0.
c      vw=0. (set in the main program)
      threseta=0.01
c      rp=0. (set in the main program)
      imk=0
      yshift=0.
      fz=1.
cs
cs     save these initial parameters at common/parsave/
      xmin0=xmin
      xmax0=xmax
      ymin0=ymin
      ymax0=ymax
      dshft0=dshft
      vw0=vw
      threseta0=threseta
      rp0=rp
cs
c     setting the size of the frame window maximum
ctak      winfo.type=qwin$max
ctak      status=setwsizeqq(qwin$framewindow,winfo)

      status=focusqq(0)
      CALL graphicsmode(0)
  100 CALL drawframe(0)
      return
      end

      SUBROUTINE graphicsmode(iu)
      USE DFLIB
      implicit real*8 (a-h,o-z)
      LOGICAL             statusmode
      type (windowconfig) myscreen
      integer*4 backcolor,forecolor,textcolor,spobcolor,spthcolor,
     &spidcolor,sprecolor,spadcolor
      character*16 fontstd,fontide
      character*40 xlabel,ylabel
      common/grwinset/myscreen,fontstd,fontide,
     &backcolor,forecolor,textcolor,spobcolor,spthcolor,spidcolor,
     &sprecolor,spadcolor(3)
      common/frameset/ngtx,ngty,xlmargin,xrmargin,ytmargin,ydmargin,
     &ltickp,xlabel,ylabel
      integer*2 status
      status=setactiveqq(iu)
      statusmode = SETWINDOWCONFIG(myscreen)
      IF(.NOT. statusmode) statusmode = SETWINDOWCONFIG(myscreen)
      statusmode = GETWINDOWCONFIG( myscreen )
      call wsizeset(iu)
      ires =  setbkcolorrgb(backcolor)
      ires =  settextcolorrgb(textcolor)
      return
      end

      SUBROUTINE wsizeset(iu)
      USE DFLIB
      implicit real*8 (a-h,o-z)
      integer*4 status
      logical*4 statusmode
      type (windowconfig) wc
      type (qwinfo) winfo
      status=setactiveqq(iu)
      statusmode=getwindowconfig(wc)
      winfo.type=qwin$set
      winfo.h=wc.numtextrows
      winfo.w=wc.numtextcols
      status=setwsizeqq(iu,winfo)
      return
      end

      SUBROUTINE drawframe(iu)
      USE DFLIB
      PARAMETER(KPNT=100001)
      parameter (md=9999)
      parameter (mdq=1000,ndq=3)
      parameter (MREF=120000)
      parameter (MAXIDE=100000)
      implicit real*8 (a-h,o-z)
c
      parameter (mmax=200,mstep=101)
      dimension dxsl(mmax),dxsr(mmax),ysl(mmax),ysr(mmax)
      dimension yint(mstep),dxl(mstep),dxr(mstep),dxc(mstep)
      common/bisector/ifbisec
c
      dimension xguess(ndq),x(ndq)
      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      COMMON/LCALDATA/XI,STWV,ENWV,NPOINT,NCON,NVAR,NCODE(99),DEPSL(99)
      COMMON/SYNPROF/WLTH(KPNT),AINT(KPNT),RESIDF(KPNT),ABSF(KPNT)
      type (windowconfig) myscreen
      integer*4 backcolor,forecolor,textcolor,spobcolor,spthcolor,
     &spidcolor,sprecolor,spadcolor
      character*16 fontstd,fontide
      character*40 xlabel,ylabel
      common/grwinset/myscreen,fontstd,fontide,
     &backcolor,forecolor,textcolor,spobcolor,spthcolor,spidcolor,
     &sprecolor,spadcolor(3)
      common/overplotc/spthcadd(4),maskcolor,rngecolor,gauscolor,
     & bisecolor
      integer*4 spthcadd,maskcolor,rngecolor,gauscolor,bisecolor
      common/frameset/ngtx,ngty,xlmargin,xrmargin,ytmargin,ydmargin,
     &ltickp,xlabel,ylabel
      common/ident/nide,lnident(MAXIDE)
      character*66 lnident
      common/passxyth/n1,n2,xth(kpnt),yth(kpnt)
      common/mask/fz,yshift,imk,wms(99),wme(99)
      dimension sc(4)
      data sc/1.,2.,2.5,5./
      integer*4 status
      type (fontinfo) font
      integer*2 indx,numfonts
      integer*2 xwidth,yheight,cols,rows
      logical*4 statusmode
      character*16 grnum,fmt
      type (wxycoord) xy
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/spec/nd,xs(md),ys(md)
      common/labtit/labthe,labobs,lablin
      character*60 labthe,labobs,lablin
c
      logical LOREFR
      character*60 fnrefspec,labref
      common/refspec/nr,wrf1,wrf2,dwrf,xr(MREF),yr(MREF)
      common/reflab/LOREFR,fnrefspec,labref
c
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      common/passxy/mxpos,mypos
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/tysave/nspec,ythsv(kpnt,5),xthsv(kpnt,5),npsv(5)
      common/ewcalc/ewxbeg,ewxend
      character*3 ele,eley(77)
      dimension wlay(77),etay(77),cody(77),epoy(77),gfly(77)
      character*6 glr,gls,glw,glry(77),glsy(77),glwy(77)
      dimension ilsel(21)
      character*60 linetmp
      character*1 ch,csignd,csigng
      integer*2 idt1,idt2,idt3,itm1,itm2,itm3,itm4
      dimension fwt(-1000:1000)
      dimension residft(kpnt),fwtt(-1000:1000)
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
c
      dimension xtmp(md),ytmp(md),restemp(md)
      character chord*3, chfrc*3, dout1*22,dout2*22,dout3*22,dout4*14

      common/batch/fndb_def,
     & fndb,spandb,idb,ndb,last,isv(999),wlamdb(999),labdb(999)
      character fndb_def*60,fndb*60,labdb*80
      character lab80*80, lab110*110
      character comment*68
c
      common/ewdbout/dwcrt,loewout,fnewout
      character*60 fnewout
      logical loewout
      character*20 lab20
      character*1 chadopt,chraw
      character*5 fmty
      character*3 labc3
      common/tilt/tilta
      dimension numser(999)
      character*60 fnmultobs,tfnolist,fnolist(999)
      common/nspass/nspecify,ifmultobs,imfcur,nmfile,numser,
     & fnmultobs,fnolist
      common/dopcorrect/dopcor,dopref,dcfac,drfac
      character*6 labvcor
      common/xyvpass/xv,yv
c_bbb
      common/auto/ifauto,iapdum,ifn
      logical loauto
c_fff
      common/grparams/ek,adamp,area
      common/idfile/fnlineid
      character*60 fnlineid
      common/fluxmode/ifabs
      common/synfincheck/ifsame,ifsynfin
      common/unfocus/ifunplot
      common/ifrefvlink/ifrefvlink
      common/iabsfchk/iabsfirst,ymaxkeep,yminkeep
c
c
      common/epspass/ep,nlimda,wlalimda(2000),epslimda(2000)
c
      character*7 labdopc
c
      numfonts=initializefonts()
      status=setactiveqq(iu)
      call clearscreen($gclearscreen)
      statusmode=getwindowconfig(myscreen)
      xwidth =myscreen.numxpixels
      yheight=myscreen.numypixels
      cols   =myscreen.numtextcols
      rows   =myscreen.numtextrows

c     special frame setting for the case of ifabs=1 (absolute flux mode)
c     only for the first time
        if(ifabs.eq.1.and.iabsfirst.eq.1) then
          fluxmax=-1.e30
          do k=1,npoint
            if(absf(k).gt.fluxmax) fluxmax=absf(k)
          end do
          ymax=fluxmax*1.1
          ymin=0.
          ymaxkeep=ymax
          yminkeep=ymin
          iabsfirst=0
        end if
c
      xx = (xmax - xmin) / ngtx
      k = Int(log10(xx)) - 2
      do while (1)
        do m = 1, 4
        cmxcur = sc(m) * 10.**k
        If (xx.le.cmxcur) Then
        kx = k
        cmx = cmxcur
        nnx=int(xmin/cmx)
        if(xmin.ge.0) nnx=nnx+1
        xstart = nnx * cmx
        mx=m
        goto 101
        end if
        end do
       k = k + 1
      end do
  101 continue
      yy = (ymax - ymin) / ngty
      k = Int(log10(yy)) - 2
      do while (1)
        do m = 1, 4
        cmycur = sc(m) * 10.**k
        If (yy.le.cmycur) then
        ky = k
        cmy = cmycur
        nny=int(ymin/cmy)
        if(ymin.ge.0) nny=nny+1
        ystart = nny * cmy
        my=m
        goto 102
        end if
        end do
       k = k + 1
      end do
  102 continue
      wx1=xmin-(xmax-xmin)*xlmargin
      wy1=ymax+(ymax-ymin)*ytmargin
      wx2=xmax+(xmax-xmin)*xrmargin
      wy2=ymin-(ymax-ymin)*ydmargin
      dx = abs(wx2-wx1)/xwidth
      dy = abs(wy2-wy1)/yheight
      status=setwindow(.true.,wx1,wy1,wx2,wy2)
      status= SETCOLORRGB( forecolor )
c     drawing the frame
      status=RECTANGLE_W( $GBORDER, xmin,ymin,xmax,ymax)
c     setting standard font
      indx=setfont(fontstd)
      indx=getfontinfo(font)
c     ticks in X-axis
c     select format
      call fmtset(kx,mx,fmt)
c
      do ri= xstart, xmax, cmx
      write(grnum,fmt) ri
      call lablen(grnum,16,ns,ne)
      xcur = ri - font.avgwidth*(ne-ns+1+0.1)*dx / 2.
      ycur = ymin - font.pixheight*0.2*dy
      call moveto_w(xcur,ycur,xy)
      call outgtext(grnum(ns:ne))
      call moveto_w(ri,ymin,xy)
      status=lineto_w(ri,ymin+ltickp*dy)
      call moveto_w(ri,ymax,xy)
      status=lineto_w(ri,ymax-ltickp*dy)
      end do
c
c     ticks in Y-axis
c     select format
      call fmtset(ky,my,fmt)
c     for the special case of absolute flux representation
      xoffset=0.
      if(ifabs.eq.1) then
      fmt='(1pe9.2)'
      xoffset=1.
      end if
c
      xcmin=xmax
      do rj = ystart, ymax, cmy
      write(grnum,fmt) rj
      call lablen(grnum,16,ns,ne)
      xcur = xmin - font.avgwidth*(ne-ns+1.1+xoffset)*dx
      if(xcur.lt.xcmin) xcmin=xcur
      ycur = rj + font.pixheight*dy/2.
      call moveto_w(xcur,ycur,xy)
      call outgtext(grnum(ns:ne))
      call moveto_w(xmin,rj,xy)
      status=lineto_w(xmin+ltickp*dx,rj)
      call moveto_w(xmax,rj,xy)
      status=lineto_w(xmax-ltickp*dx,rj)
      end do
c
c     writing title for the model atmosphere file
      status= SETCOLORRGB(spthcolor)
      call lablen(labthe,60,ns,ne)
c      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      xcur=xmin
      ycur = ymax + font.pixheight*dy*4.5
      call moveto_w(xcur,ycur,xy)
      call outgtext (labthe(ns:ne))
c
c     writing title for the line data file
      status= SETCOLORRGB(spthcolor)
      call lablen(lablin,60,ns,ne)
c      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      xcur=xmin
      ycur = ymax + font.pixheight*dy*3.0
      call moveto_w(xcur,ycur,xy)
      call outgtext (lablin(ns:ne))
c
c     writing title for the observed spectrum
      status= SETCOLORRGB(spobcolor)
      call lablen(labobs,60,ns,ne)
c      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      xcur=xmin
      ycur = ymax + font.pixheight*dy*1.5
      call moveto_w(xcur,ycur,xy)
      if(dopcor.ne.0.) then
        write(labvcor,'(f6.1)') dopcor
        call outgtext (labobs(ns:ne)//' (vcor='//labvcor//')')
      else if(abs(dcfac-1).gt.0.000000001) then
        dopcor_suc=(dcfac-1.)*2.997925e5
        write(labvcor,'(f6.1)') dopcor_suc
        call outgtext (labobs(ns:ne)//' (vcor='//labvcor//')')
      else
        call outgtext (labobs(ns:ne))
      end if
      status= SETCOLORRGB(forecolor)

c     writing obs. spec No. in case of multi-file case
      if(nspecify.gt.0) then
      status= SETCOLORRGB(spobcolor)
      write(labc3,'(i3.3)') nspecify
c      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      xcur= xmin - font.avgwidth*5*dx
      ycur = ymax + font.pixheight*dy*1.5
      call moveto_w(xcur,ycur,xy)
      call outgtext (labc3)
      status= SETCOLORRGB(forecolor)
      end if
c
c
c     writing title for the reference spectrum
      if(nr.gt.0) then
      status= SETCOLORRGB(sprecolor)
      call lablen(labref,60,ns,ne)
c      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      xcur=xmin
      ycur = ymin - font.pixheight*dy*2.0
      call moveto_w(xcur,ycur,xy)
      if(dopref.ne.0..and.ifrefvlink.eq.1) then
        status= SETCOLORRGB(forecolor)
        call outgtext
     &  ('LINKED SHIFT APPLIED IN REFSPEC: PRESS "`" (B.Q.) TO RECOVER')
      else if (dopref.ne.0..and.ifrefvlink.ne.1) then
        write(labvcor,'(f6.1)') dopref
        call outgtext (labref(ns:ne)//' (vcor='//labvcor//')')
      else
        call outgtext ('refspec: '//labref(ns:ne))
      end if
      status= SETCOLORRGB(forecolor)
      end if

      if(ifthex.eq.0.and.nide.gt.0) then
        status= SETCOLORRGB(sprecolor)
        call lablen(fnlineid,60,ns,ne)
c        xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
        xcur=xmin
        ycur = ymin - font.pixheight*dy*1.0
        call moveto_w(xcur,ycur,xy)
        call outgtext ('lineid: '//fnlineid(ns:ne))
        status= SETCOLORRGB(forecolor)
      end if
c
c     writing x-label
      call lablen(xlabel,40,ns,ne)
      xcur = 0.5 * (xmin + xmax) - 0.5 * font.avgwidth*(ne-ns+1)*dx
      ycur = ymin - font.pixheight*dy*1.2
      call moveto_w(xcur,ycur,xy)
      call outgtext (xlabel(ns:ne))
c     writing y-label
      call lablen(ylabel,40,ns,ne)
      xcur = xcmin-font.pixheight*dx*1.1
      ycur = 0.5*(ymin+ymax)-0.5*font.avgwidth*(ne-ns+1.1)*dy
      call moveto_w(xcur,ycur,xy)
      call setgtextrotation(900)
      call outgtext (ylabel(ns:ne))
      call setgtextrotation(0)

c     set the focused spectrum to (xs,ys) in case of MULTISPEC
      call bestsel(xmin,xmax)
      if(numord.gt.1) then
      nd=nump(nofoc)
      do n=1,nd
      xs(n)=wlmul(n,nofoc)
      ys(n)=spmul(n,nofoc)
      end do
c--
      if(tilta.ne.0.) then
        xcen=0.5*(xmin+xmax)
      	do n=1,nd
      		ys(n)=ys(n)/(1.+tilta*(xs(n)*dcfac-xcen))
      	end do
      end if
c--
      end if
c

c
c     printing currently visible order numbers (with colors)
        if(numord.le.1) go to 1022
          status= SETCOLORRGB(forecolor)
          xcur = xmin
          ycur = ymin - font.pixheight*dy*3.0
          call moveto_w(xcur,ycur,xy)
          call outgtext('order No:')
          xcur = xmin
          ycur = ymin - font.pixheight*dy*4.0
          call moveto_w(xcur,ycur,xy)
          call outgtext('fract (%):')
c          if(lolimit) then
            iv1=1
            iv2=novtot
c          else
c            do iv=1,novtot
c              if(nofoc.eq.novis(iv)) then
c                iv1=iv
c                iv2=iv
c                exit
c              end if
c            end do
c          end if
         ivcnt=0
        do iv=iv1,iv2
          jj=novis(iv)
          if(jj.eq.nofoc) then
            status = SETCOLORRGB(spobcolor)
          else
c            if(.not.lolimit) cycle
            jclr=mod(jj,3)
            if(jclr.eq.0) jclr=3
            status= SETCOLORRGB(spadcolor(jclr))
          end if
          write(chord,'(i3)') jj
          ivcnt=ivcnt+1
          xcur = xmin  + (3+ivcnt-1)*font.avgwidth*4*dx
          ycur = ymin - font.pixheight*dy*3.0
          call moveto_w(xcur,ycur,xy)
          call outgtext (chord)
          ifrc=int(xfrac(iv)*100.)
          write(chfrc,'(i3)') ifrc
          if(ifrc.lt.0)   chfrc='---'
          if(ifrc.gt.100) chfrc='+++'
          xcur = xmin  + (3+ivcnt-1)*font.avgwidth*4*dx
          ycur = ymin - font.pixheight*dy*4.0
          call moveto_w(xcur,ycur,xy)
          call outgtext (chfrc)
        end do
        status= SETCOLORRGB(forecolor)
 1022   continue
c
c          write(dout1,3001) dshft,dshft/(0.5*(xmin+xmax))*2.997925e5
          write(dout1,3001) -dshft,-dshft/(0.5*(xmin+xmax))*2.997925e5
 3001     format('ds:',f6.2,' dVrad:',f6.1)
          write(dout2,3002) fz,yshift
 3002     format('fz:',f6.3,'  ysft:',f6.3)
ctakedatemp
c          if(nd.gt.0) then
          if(nd.gt.1) then
ctakedatemp
          status= SETCOLORRGB(spobcolor)
          xcur = xmin+10*font.avgwidth*4*dx
          ycur = ymin - font.pixheight*dy*2.0
          call moveto_w(xcur,ycur,xy)
          call outgtext(dout1)
          ycur = ymin - font.pixheight*dy*3.0
          call moveto_w(xcur,ycur,xy)
          call outgtext(dout2)
          status= SETCOLORRGB(forecolor)
          end if
          if(ifthex.ne.0) then
            if(vw.ge.0.) go to 7998
            if(nlimda.ge.2) then
              idum=map1(wlalimda,epslimda,nlimda,0.5*(xmin+xmax),ep,1)
            else      
              ep=epsld
            end if
            write(dout3,8003) int(abs(vw)+0.5),ep,threseta
 8003       format(i3,'/',f5.3,' eta:',1pe8.2)
            go to 7999
 7998       continue 
            write(dout3,3003) vw,threseta
 3003       format('vw:',f6.1,' eta:',1pe8.2)
 7999       continue
           status= SETCOLORRGB(spthcolor)
            xcur = xmin+10*font.avgwidth*4*dx
            ycur = ymin - font.pixheight*dy*4.0
            call moveto_w(xcur,ycur,xy)
            call outgtext(dout3)
            status= SETCOLORRGB(forecolor)
          else
            if(nide.gt.0) then
              write(dout3,'(9x,'' eta:'',f7.4)') threseta
              status= SETCOLORRGB(sprecolor)
              xcur = xmin+10*font.avgwidth*4*dx
              ycur = ymin - font.pixheight*dy*4.0
              call moveto_w(xcur,ycur,xy)
              call outgtext(dout3)
              status= SETCOLORRGB(forecolor)
            end if
          end if

          if(tilta.ne.0) then
          write(dout4,3004) tilta
 3004     format('tilt:',f9.5)
          status= SETCOLORRGB(maskcolor)
          xcur = xmin+15*font.avgwidth*4*dx
          ycur = ymin - font.pixheight*dy*3.0
          call moveto_w(xcur,ycur,xy)
          call outgtext(dout4)
          status= SETCOLORRGB(forecolor)
          end if

          if(ifthex.ne.0) then
            if(rp.gt.0.) then
              write(dout4,'(''R(ip):'',i6)') int(rp+0.5)
            else
              write(dout4,'(''R(ip):infin.'')')
            end if
            status= SETCOLORRGB(spthcolor)
            xcur = xmin+17*font.avgwidth*4*dx
            ycur = ymin - font.pixheight*dy*4.0
            call moveto_w(xcur,ycur,xy)
            call outgtext(dout4(1:12))
            status= SETCOLORRGB(forecolor)
          end if

c     First of all, we plot the reference spectrum if necessary
      if(nr.gt.0) then
c       now about to plot the reference spectrum
        status= SETCOLORRGB(sprecolor)
        if(ifrefvlink.eq.1)  status= SETCOLORRGB(forecolor)
        call range(xr*drfac,nr,xmin,xmax,n1,n2)
        call moveto_w(xr(n1)*drfac,yr(n1),xy)
        do n=n1+1,n2
          status=lineto_w(xr(n)*drfac,yr(n))
        end do
      end if
      status= SETCOLORRGB(forecolor)
c

c        fz=1.
c        if(nd.gt.0.and.ifnorm.ne.1.and.ifthex.eq.1) then
c        call range(wlth*10.,npoint,xmin,xmax,n1,n2)
c        sumt=0.
c        do n=n1,n2
c        sumt=sumt+residf(n)
c        end do
c        avt=sumt/(n2-n1+1)
c        call range(xs*dcfac-dshft,nd,xmin,xmax,n1,n2)
c        sumf=0.
c        do n=n1,n2
c        sumf=sumf+ys(n)
c        end do
c        avf=sumf/(n2-n1+1)
c        fz=avt/avf
c        end if


c     if ifunplot=1 in the multispec case,
c     observed spectra of unfocused orders are also plotted
c     Otherwise (ifunplot=0) this is not done (plotting only focused order)
      if((numord.gt.1).and.(ifunplot.eq.1)) then
      do 123 iv=1,novtot
      jj=novis(iv)
      if(jj.eq.nofoc) go to 123
      jclr=mod(jj,3)
      if(jclr.eq.0) jclr=3
      status= SETCOLORRGB(spadcolor(jclr))
        do ix=1,nump(jj)
         xtmp(ix)=wlmul(ix,jj)*dcfac-dshft
        end do
        call range(xtmp,nump(jj),xmin,xmax,n1,n2)
        call
     %  moveto_w(wlmul(n1,jj)*dcfac-dshft,spmul(n1,jj)*fz+yshift,xy)
        do n=n1+1,n2
          status=lineto_w(wlmul(n,jj)*dcfac-dshft,spmul(n,jj)*fz+yshift)
        end do
  123 continue
      end if
      status= SETCOLORRGB(forecolor)

      if(nd.gt.0) then
c       now about to plot the observed spectrum
        status= SETCOLORRGB(spobcolor)
        call range(xs*dcfac-dshft,nd,xmin,xmax,n1,n2)
        call moveto_w(xs(n1)*dcfac-dshft,ys(n1)*fz+yshift,xy)
        do n=n1+1,n2
          status=lineto_w(xs(n)*dcfac-dshft,ys(n)*fz+yshift)
        end do
c       coloring of masked portion
        if(imk.gt.0) then
                status= SETCOLORRGB(spobcolor)
                call range(xs*dcfac-dshft,nd,xmin,xmax,n1,n2)
                call moveto_w(xs(n1)*dcfac-dshft,ys(n1)*fz+yshift,xy)
                do n=n1+1,n2
                  xq=xs(n)*dcfac-dshft
                  do jx=1,imk
                    if(xq.ge.wms(jx).and.xq.lt.wme(jx)) then
                    status= SETCOLORRGB(#00FF00)
                    go to 555
                    end if
                  end do
  555             continue
                  status=lineto_w(xs(n)*dcfac-dshft,ys(n)*fz+yshift)
                  status= SETCOLORRGB(spobcolor)
                end do
        end if
      end if
      status= SETCOLORRGB(forecolor)

c     display the line-strength/identification info if available
c     now begins the identification of conspicuous lines
      if(nide.gt.0) then
      call setgtextrotation(900)
      if(ifthex.ne.1) then
      status=setcolorrgb(sprecolor)
      else
      status=setcolorrgb(spidcolor)
      end if
c     setting ident-font
      indx=setfont(fontide)
      indx=getfontinfo(font)
      if(threseta.ge.0.01) then
      lclast=21
      else if(threseta.ge.0.001) then
      lclast=22
      else if(threseta.ge.0.0001) then
      lclast=23
      else
      lclast=24
      end if
      do id=1,nide
      read(lnident(id),'(3x,f9.3,f12.6,42x)') wladum,etldum
      if(wladum.lt.xmin.or.wladum.gt.xmax.or.etldum.lt.threseta) cycle
      xcur=wladum-font.pixheight*dx*0.5
      ycur=ymin+0.5*font.avgwidth*dy
      call moveto_w(xcur,ycur,xy)
      call outgtext(lnident(id)(1:lclast))
      end do
      call setgtextrotation(0)
      status= SETCOLORRGB(forecolor)
      indx=setfont(fontstd)
      end if

c     print info of the target line in case of batch mode
      if(idb.gt.0) then
      	wladum=wlamdb(idb)
c      	  drawing the vertical reference line at the line position
          call moveto_w(wladum,ymin,xy)
      	  status=SETCOLORRGB(spthcolor)
      	  status=lineto_w(wladum,ymax)
c
      	call setgtextrotation(900)
      	status=setcolorrgb(spidcolor)
c     	setting ident-font
      	indx=setfont(fontide)
      	indx=getfontinfo(font)
      	xcur=wladum-font.pixheight*dx*0.5
      	ycur=ymin+0.5*font.avgwidth*dy
      	call moveto_w(xcur,ycur,xy)
      	call outgtext(labdb(idb)(1:21))
      	call setgtextrotation(0)
      	status= SETCOLORRGB(forecolor)
      	indx=setfont(fontstd)
c     	writing  filename of the batch-line file
c     	and the No. of the current batch line
      	call lablen(fndb,60,ns,ne)
      	xcur=xmin
      	ycur = ymax + font.pixheight*dy*5.5
      	call moveto_w(xcur,ycur,xy)
        if(last.gt.0) then
        isvlast=isv(last)
        else
        isvlast=0
        end if

      	write(lab110,527)isvlast,idb,ndb,fndb(1:40)
  527   format('(lastsave No.:',i3,')  line No.',i3,' from ',i3,
     &  ' lines in ',(a40))
      	call lablen(lab110,110,ns,ne)
      	call outgtext (lab110(ns:ne))
c       writing data of the currect line
      	xcur=xmin
      	ycur = ymax + font.pixheight*dy*4.0
      	call moveto_w(xcur,ycur,xy)
      	call outgtext('line data: '//labdb(idb)(1:52)//
     &  '  ('//labdb(idb)(77:80)//')')
      end if

c
c     skip drawing theoretical spectra in case of |ifewid|=1
      if(abs(ifewid).eq.1) go to 599
c     return if theoretical spectrum does not exist
      if (ifthex.eq.0) return
c
      if(ifabs.eq.0) then
        do n=1,npoint
        	residft(n)=residf(n)
        end do
      else
        do n=1,npoint
        	residft(n)=absf(n)
        end do
      end if
c
c     blurring the theoretical spectrum according to the resolving power
c     (for the case of rp>0)
c     vwt is the half-width at 1/e-maximum (in km/s)
      if(rp.le.0.) go to 1928
      vwt=(2.997925e5/rp)/1.6651092
      del=wlth(2)-wlth(1)
      kvwht=int(0.5*(wlth(1)+wlth(npoint))*vwt/2.997925e5/del+0.5)

c       for vwt>0 (gaussian with base extending from -3*vwt to 3*vwt)
        kvwhext=3.*kvwht
        if(kvwhext.gt.1000) then
        	write(*,*) 'Too large kvwhext=',kvwhext
        	stop
        end if
        sumwt=0.
        do jj=0,kvwhext
        	xarg=(float(jj)/kvwht)**2
        	fwtt(jj)=exp(-xarg)
        	sumwt=sumwt+fwtt(jj)
        end do
        do jj=-1,-kvwhext,-1
        	fwtt(jj)=fwtt(-jj)
        	sumwt=sumwt+fwtt(jj)
        end do
        do jj=-kvwhext,+kvwhext
        	fwtt(jj)=fwtt(jj)/sumwt
        end do

        do n=1+kvwhext,npoint-kvwhext
        	sum=0.
        	do m=n-kvwhext,n+kvwhext
        		sum=sum+fwtt(m-n)*residft(m)
        	end do
        	restemp(n)=sum
        end do
        do n=1+kvwhext,npoint-kvwhext
        residft(n)=restemp(n)
        end do 
c
c       edge processing (set at constant<--average in this region)
        smsl=0.
        do n=1,kvwhext
        smsl=smsl+residft(n)
        end do
        residft_ml=smsl/float(kvwhext)
        do n=1,kvwhext
          residft(n)=residft_ml
        end do

        smsr=0.
        do n=npoint-kvwhext+1,npoint
        smsr=smsr+residft(n)
        end do
        residft_mr=smsr/float(kvwhext)
        do n=npoint-kvwhext+1,npoint
          residft(n)=residft_mr
        end do
c
 1928   continue

c     smoothing of the theoretical spectrum according to vw
c     |vw| is the half-width at 1/e-maximum (in km/s)  (for vw>0)
c     or rotational broadening width (for vw<0)
      del=wlth(2)-wlth(1)
      kvwh=int(0.5*(wlth(1)+wlth(npoint))*dabs(vw)/2.997925e5/del+0.5)
      if (vw.lt.0.) then
c       for vw<0 (rotational broadening with base from -vw to +vw)
          if(kvwh.gt.1000) then
          write(*,*) 'Too large kvwh=',kvwh
          stop
          end if
c          if(nlimda.ge.2) then
c            idum=map1(wlalimda,epslimda,nlimda,0.5*(xmin+xmax),ep,1)
c          else      
c            ep=epsld
c          end if
          pi=3.14159265358979324
          den=pi*(1.-ep/3.)
          c1=(2.*(1.-ep))/den
          c2=(pi*ep/2.)/den
          sumwt=0.
          do jj=0,kvwh
          xarg=1.-(float(jj)/kvwh)**2
          fwt(jj)=c1*sqrt(xarg)+c2*xarg
          sumwt=sumwt+fwt(jj)
          end do
          do jj=-1,-kvwh,-1
          fwt(jj)=fwt(-jj)
          sumwt=sumwt+fwt(jj)
          end do
          do jj=-kvwh,+kvwh
          fwt(jj)=fwt(jj)/sumwt
          end do
        l=0
        do n=1+kvwh,npoint-kvwh
          l=l+1
          sum=0.
          do m=n-kvwh,n+kvwh
          sum=sum+fwt(m-n)*residft(m)
          end do
        yth(l)=sum
        xth(l)=wlth(n)*10.
        ythsv(l,1)=yth(l)
        xthsv(l,1)=xth(l)
        end do
        np=l
        npsv(1)=np
      else if (vw.eq.0.) then
        np=npoint
        npsv(1)=np
        do l=1,np
        xth(l)=wlth(l)*10.
        yth(l)=residft(l)
        ythsv(l,1)=yth(l)
        xthsv(l,1)=xth(l)
        end do
      else if (vw.gt.0.) then
c       for vw>0 (gaussian with base extending from -3*vw to 3*vw)
          kvwhex=3.*kvwh
          if(kvwhex.gt.1000) then
          write(*,*) 'Too large kvwhex=',kvwhex
          stop
          end if
          sumwt=0.
          do jj=0,kvwhex
          xarg=(float(jj)/kvwh)**2
          fwt(jj)=exp(-xarg)
          sumwt=sumwt+fwt(jj)
          end do
          do jj=-1,-kvwhex,-1
          fwt(jj)=fwt(-jj)
          sumwt=sumwt+fwt(jj)
          end do
          do jj=-kvwhex,+kvwhex
          fwt(jj)=fwt(jj)/sumwt
          end do
        l=0
        do n=1+kvwhex,npoint-kvwhex
          l=l+1
          sum=0.
          do m=n-kvwhex,n+kvwhex
          sum=sum+fwt(m-n)*residft(m)
          end do
        yth(l)=sum
        xth(l)=wlth(n)*10.
        ythsv(l,1)=yth(l)
        xthsv(l,1)=xth(l)
        end do
        np=l
        npsv(1)=np
c
cc       for vw>0 (triangle with base extending from -2vw to 2vw)
c        l=0
c        do n=1+2*kvwh,npoint-2*kvwh
c        l=l+1
c        sum=0.
c        sumwt=0.
c          do m=n-2*kvwh,n
c          wt=1.+float(m-n)/(2.*kvwh)
c          sumwt=sumwt+wt
c          sum=sum+wt*residft(m)
c          end do
c          do m=n+1,n+2*kvwh
c          wt=1.-float(m-n)/(2.*kvwh)
c          sumwt=sumwt+wt
c          sum=sum+wt*residft(m)
c          end do
c        yth(l)=sum/sumwt
c        xth(l)=wlth(n)*10.
c        ythsv(l,1)=yth(l)
c        xthsv(l,1)=xth(l)
c        end do
c        np=l
c        npsv(1)=np
      end if

c     now about to plot the theoretical spectrum
      do 7011 j=nspec,1,-1
      if (j.eq.1) then
      status = SETCOLORRGB(spthcolor)
      else if(j.eq.2) then
      status = SETCOLORRGB(spthcadd(1))
      else if(j.eq.3) then
      status = SETCOLORRGB(spthcadd(2))
      else if(j.eq.4) then
      status = SETCOLORRGB(spthcadd(3))
      else if(j.eq.5) then
      status = SETCOLORRGB(spthcadd(4))
      else
      status = SETCOLORRGB(spthcolor)
      end if
      call range(xthsv(1,j),npsv(j),xmin,xmax,n1,n2)
      call moveto_w(xthsv(n1,j),ythsv(n1,j),xy)
      do n=n1+1,n2
      status=lineto_w(xthsv(n,j),ythsv(n,j))
      end do
c     coloring of masked portion
        if(imk.gt.0) then
                status= SETCOLORRGB(spthcolor)
                call range(xthsv(1,j),npsv(j),xmin,xmax,n1,n2)
                call moveto_w(xthsv(n1,j),ythsv(n1,j),xy)
                do n=n1+1,n2
                  xq=xthsv(n,j)
                  do jx=1,imk
                    if(xq.ge.wms(jx).and.xq.lt.wme(jx)) then
                    status= SETCOLORRGB(maskcolor)
                    go to 556
                    end if
                  end do
  556             continue
                  status=lineto_w(xthsv(n,j),ythsv(n,j))
                  status= SETCOLORRGB(spthcolor)
                end do
        end if
 7011 continue
  599 continue

c   EW evaluation mode

       if(abs(ifewid).ne.1) go to 567

c****
c      EW calculation with automatic finding of ne1 and ne2
       if(ifewid.eq.-1) then
       if((yv.lt.ymin).or.(yv.gt.ymax).or.
     &   (xv.lt.xmin).or.(xv.gt.xmax)) then
         ewmad=0.
         ewmag=0.
         ifewid=0
         ewxbeg=0.
         ewxend=0.
         ycont=0.
         go to 642
       end if
       call ewmulti(ne1,ne2)
       ewxbeg=xs(ne1)*dcfac-dshft
       ewxend=xs(ne2)*dcfac-dshft
       ifewid=0
       go to 590
       end if
c
c****

c      resetting ifewid
       ifewid=0

      call range(xs*dcfac-dshft,nd,ewxbeg,ewxend,ne1,ne2)
  590 continue
      ewid=0.
      xcenmin=xmax
      ycenmin=1.e30
      iin=0
      do n=ne1,ne2
        yy=ys(n)*fz+yshift
        iin=iin+1
        wlamo(iin)=xs(n)*dcfac-dshft
        speco(iin)=yy
c        rdep=1.- yy/ycont
        rdep=1.- (yy-yshift)/(ycont-yshift)
        if(n.eq.ne1) then
          ewid=ewid+0.5*(xs(ne1+1)*dcfac-xs(ne1)*dcfac)*rdep
        else if (n.eq.ne2) then
          ewid=ewid+0.5*(xs(ne2)*dcfac-xs(ne2-1)*dcfac)*rdep
        else
          ewid=ewid+0.5*(xs(n+1)*dcfac-xs(n-1)*dcfac)*rdep
        end if
        if(yy.lt.ycenmin) then
          xcenmin=xs(n)*dcfac-dshft
          ycenmin=yy
        end if
      end do
      nlamo=iin
      ewmad=ewid*1000.

      if(ewmad.le.0.) go to 642
c
      if(vw.gt.0.) then
        doplamd=xcenmin*max(3.,vw)/2.997925e5
      else
        doplamd=xcenmin*max(3.,abs(vw))*0.75/2.997925e5
      end if

c     ew-related drawing
c     direct integration
      status= SETCOLORRGB(rngecolor)
      call moveto_w(xs(ne1)*dcfac-dshft,ycont,xy)
      status=lineto_w(xs(ne2)*dcfac-dshft,ycont)
      call polset(12,3,dx,dy)
      do n=ne1,ne2
      call polplot(xs(n)*dcfac-dshft,ys(n)*fz+yshift)
      end do
c
      if(ifbisec.ge.2) then
c     bisector determination
      call bisect(wlamo,speco,nlamo,  xpeak,nstep,yint,dxl,dxr,dxc)
c     drawing the bisector curve
      status= SETCOLORRGB(bisecolor)
      call moveto_w(xpeak+dxc(1),yint(1),xy)
      do n=2,nstep
      status=lineto_w(xpeak+dxc(n),yint(n))
      end do
      end if
c
      xguess(1)=ycont-ycenmin
      xguess(2)=xcenmin
      xguess(3)=doplamd
c
c     prepare nlamo,wlamo,speco, set ycont, and guess xguess(1-3)
c
c      write(*,'(''xguess:'',3e13.5)') xguess
c      call solve(nlamo,xguess,x,icode,itype)
      call solve_nl(nlamo,xguess,x)
c      write(*,'(''xfinal:'',3e13.5)') x
      facdop=2.5
      if(adamp.gt.0..and.adamp.le.0.1) facdop=4.
      if(adamp.gt.0.1) facdop=7.
      dsw=0.01
      numtmp=int(x(3)*facdop/dsw)
      igk=0
      do k=-numtmp,numtmp
      igk=igk+1
      wlamo(igk)=x(2)+dsw*dfloat(k)
      if(ek.eq.0..and.adamp.eq.0.) then
        arg=((wlamo(igk)-x(2))/x(3))**2
        speco(igk)=ycont-x(1)*exp(-arg)
      else
        speco(igk)=ycont-x(1)*grx((wlamo(igk)-x(2))/x(3))
      end if
      end do
      ngk=igk
      status= SETCOLORRGB(gauscolor)
      call moveto_w(wlamo(1),speco(1),xy)
      do n=2,ngk
      status=lineto_w(wlamo(n),speco(n))
      end do

      if(ek.eq.0..and.adamp.eq.0.) then
        ewmag=(x(1)/(ycont-yshift))*x(3)*1000.*1.772454
      else
        call calarea
        ewmag=(x(1)/(ycont-yshift))*x(3)*1000.*area
      end if
  642 continue
c      if(ifbisec.ge.2) then
c        write(*,'(''!!! BISECTOR OUTPUT MODE !!!'')')
c      end if
      if(ek.ne.0..or.adamp.ne.0.) then
        write(*,'(''!!! NON-GAUSSIAN FITTING '',$)')
        write(*,'(''(k='',f5.2,''  adamp='',f6.3,'') !!!'')')
     &  ek,adamp
      end if
        write(*,'(''(select range begin='',f8.2,'')'')') ewxbeg
        write(*,'(''(select range end  ='',f8.2,'')'')') ewxend

                if(ycont.gt.10000.) then
                fmty=' f7.0'
                else if (ycont.gt.1000.) then
                fmty=' f7.1'
                else if (ycont.gt.100.) then
                fmty=' f7.2'
                else if (ycont.gt.10.) then
                fmty=' f7.3'
                else
                fmty=' f7.4'
                end if

        write(*,'(''(specified continuum ='','//fmty//''')'')') ycont
c        write(*,'(''(specified continuum ='',f7.3,'')'')') ycont
      isel=0
      etmax=-1.e30
      ismax=0
      do i=1,nide
        read(lnident(i),'(a3,f9.3,f12.6,f10.2,2f7.3,3a6)')
     &  ele,wla,eta,cod,epo,gfl,glr,gls,glw
        if(wla.lt.ewxbeg.or.wla.gt.ewxend) cycle
c        if(wla.lt.x(2)-x(3)*facdop.or.wla.gt.x(2)+x(3)*facdop) cycle
        if(eta.lt.threseta) cycle
c        if(eta.lt.min(threseta,0.01)) cycle
        isel=isel+1
        if(isel.gt.77) then
          write(*,*) 'Too larege isel!'
          stop
        end if
        if(eta.gt.etmax) then
          etmax=eta
          ismax=isel
        end if
        eley(isel)=ele
        wlay(isel)=wla
        etay(isel)=eta
        cody(isel)=cod
        epoy(isel)=epo
        gfly(isel)=gfl
        glry(isel)=glr
        glsy(isel)=gls
        glwy(isel)=glw
        write(*,'(i2,1x,a3,1x,f9.3,f6.3,1x,f9.4)') isel,ele,wla,epo,eta
      end do
c       printout of wcen and efhw suppressed when aborted
        if(ycont.gt.0.) then
        write(*,'(''(fitted prof. center at '',f8.2,'')'')') x(2)
        write(*,'(''(e-fold half-width(km/s)'',f8.1,'')'')') 
     &   2.997925e5*x(3)/x(2)
        end if
          write(*,'(''ewma(g)='',f7.1,'' [function fit.]'')') ewmag
          write(*,'(''ewma(d)='',f7.1,'' [direct integ.]'')') ewmad

c      if(ifthex.eq.0) go to 94
      if(idb.gt.0.and.ifthex.eq.0) go to 94
      if(idb.gt.0.and.ifthex.gt.0.and.ifauto.eq.2) then
        nlsel=1
        ilsel(1)=ismax
        is1=ismax
        go to 94
      end if
      if(ismax.eq.0) go to 94
  409     write(*,
     & '(''Enter line number (0 to cancel) ['',i2,''] --> '',$)'),ismax
          call readline(linetmp,ifok,nsvv,nevv)
c          if(ifok.eq.0) return
          if(ifok.eq.0) then
          write(*,'(''OK !'',i2,'' is selected...'')') ismax
          nlsel=1
          ilsel(1)=ismax
          is1=ismax
          go to 94
          end if
c         check if data is really a number
          do ivv=nsvv,nevv
            if(ifnum(linetmp(ivv:ivv)).eq.1) go to 416
          end do
          go to 409
  416     continue
          call divline(linetmp,ilsel,nlsel,21)
          if(nlsel.gt.10) then
            write(*,'(''Total number of lines should be <=10 !'')')
            go to 409
          end if
      is1=ilsel(1)
c
      if(is1.eq.0) return
c
      if(nlsel.eq.1) go to 94
      do is=2,nlsel
      ist=ilsel(is)
      if(cody(ist).ne.cody(is1)) then
        write(*,'('' at ist='',i2)') ist
        write(*,'(''cody(is1)='',f8.2)') cody(is1)
        write(*,'(''cody(ist)='',f8.2)') cody(ist)
        go to 409
      end if
      if(abs(epoy(ist)-epoy(is1)).gt.0.02) then
        write(*,'('' at ist='',i2)') ist
        write(*,'(''epoy(is1)='',f6.3)') epoy(is1)
        write(*,'(''epoy(ist)='',f6.3)') epoy(ist)
        go to 409
      end if
      end do

   94 continue
c     select which to adopt (g or d)
      ch=''
      comment=''
      ifrem=0
      do while ((ch.ne.'d').and.(ch.ne.'g').and.(ch.ne.'c')
     # .and.(ichar(ch).ne.10).and.(ichar(ch).ne.13))
c_bbb
      loauto=.false.
      if(ifauto.eq.2) then
      loauto=.true.
      ch='g'
      chraw=' '
      ifrem=-1
      ifauto=0
      iapdum=0
      if(ewmad.le.0.) then
      write(*,*) 'aborted!'
      return
      end if
      go to 1357
      end if
c_fff
         write(*,
     %   '(''"g" or "d"? [(enter) is "g", press "c" to cancel]): '',$)')
         ch=getcharqq()
         chraw=ch
         if(ch.eq.'G') then
           ch='g'
           ifrem=1
         end if
         if(ch.eq.'D') then
           ch='d'
           ifrem=1
         end if
         if(ch.eq.'C') then
           write(*,*)
           write(*,'(''comment (< 68 char) ?'')')
           read(*,'(a)') comment
         end if
      end do
      if((ichar(ch).eq.10).or.(ichar(ch).eq.13)) then
        ch='g'
        ifrem=-1
      end if

 1357 continue

      write(*,'(a)') chraw
      if(ch.eq.'c') return
      if(ch.eq.'d') then
      modedg=1
      csignd='*'
      csigng=' '
      end if
      if(ch.eq.'g'.or.ch.eq.'a') then
      modedg=2
      csignd=' '
      csigng='*'
      end if

      if(ifthex.eq.0) go to 588

c     write out WIDTH data
      open (unit=13,file='linedat.tmp',access='append')
      codzz=cody(is1)
      if(cody(is1).ge.100.) then
      codzz=dfloat(abs(invcode(cody(is1))))/100.
      if(cody(is1).eq.106.00) codzz=1.06
      if(cody(is1).eq.107.00) codzz=1.07
      if(cody(is1).eq.108.00) codzz=1.08
      end if
      call lablen(labobs,60,ns,ne)
      do icf=ne,ns,-1
      if(labobs(icf:icf).eq.'\') then
      ns=icf+1
      go to 532
      end if
      end do
  532 continue
      do icf=ne,ns,-1
      if(labobs(icf:icf).eq.'[') then
      ne=icf-1
      go to 1532
      end if
      end do
 1532 continue
      do icf=ne-3,ns,-1
      if(labobs(icf:icf+3).eq.'.fit'.or.
     & labobs(icf:icf+3).eq.'.FIT') then
      ne=icf-1
      go to 2532
      end if
      end do
 2532 continue
      ch=' '
      if(nlsel.ge.2) then
      write(ch,'(i1)') nlsel-1
      end if
      if(modedg.eq.1) then
      chadopt='d'
      if(ifrem.eq.1) chadopt='D'
      write(13,591) ch,cody(is1),wlay(is1),epoy(is1),gfly(is1),
     & glry(is1),glsy(is1),glwy(is1),
     & ewmad,chadopt,labobs(max(ns,ne-15):ne)
  591 format(a1,f5.2,f9.3,2f6.3,3a6,f7.1,' (',a1,')',a16)
      end if
      if(modedg.eq.2) then
      chadopt='g'
      if(ifrem.eq.1) chadopt='G'
      if(ifrem.eq.-1) chadopt='_'
      write(13,592) ch,cody(is1),wlay(is1),epoy(is1),gfly(is1),
     & glry(is1),glsy(is1),glwy(is1),
     & ewmag,chadopt,labobs(max(ns,ne-15):ne)
  592 format(a1,f5.2,f9.3,2f6.3,3a6,f7.1,' (',a1,')',a16)
      end if
      if(nlsel.ge.2) then
        wymax=-1.e30
        wymin=+1.e30
        do is=1,nlsel
          ist=ilsel(is)
          if(wlay(ist).gt.wymax) wymax=wlay(ist)
          if(wlay(ist).lt.wymin) wymin=wlay(ist)
          if(ist.eq.is1) cycle
          write(13,593) wlay(ist),gfly(ist)
  593     format(6x,f9.3,6x,f6.3)
        end do
        aspanl=wlay(is1)-wymin+1.0
        aspanr=wymax-wlay(is1)+1.0
        aspanl=int(aspanl*100.+0.5)/100.
        aspanr=int(aspanr*100.+0.5)/100.
        if(aspanl.ge.12..or.aspanr.ge.12.) then
          write(*,*) 'Too large aspan: (aspanl,aspanr) ',aspanl,aspanr
          stop
        end if
        astep=0.01
        write(13,594) aspanl,aspanr,astep
  594   format(15x,3f6.3)
      end if
      close(13)

  588 continue

c     prepare for EW data (WIDTH format) output
      if(modedg.eq.1) then
      ewadopt=ewmad
      chadopt='d'
      if(ifrem.eq.1) chadopt='D'
      end if
      if(modedg.eq.2) then
      ewadopt=ewmag
      chadopt='g'
      if(ifrem.eq.1) chadopt='G'
      if(ifrem.eq.-1.and.(.not.loauto)) chadopt='_'
      if(ifrem.eq.-1.and.(loauto)) chadopt='~'
      end if
      call srchbe(labobs,60,ibgn,iend)
c

c      save results to fnewout in case of loewout=.true.
      if(loewout) then
      open (unit=58,file=fnewout,access='append')
      dwcrt1=dwcrt
      if(dwcrt1.lt.0.) dwcrt1=abs(dwcrt)*(wlamdb(idb)/5000.)
      if(idb.gt.0.and.abs(x(2)-wlamdb(idb)).lt.dwcrt1) then
        write(lab20,'(a16,i3,a1)')
     &   labobs(ibgn:iend),nofoc,chadopt
        write(58,'(a45,f7.1,a20,a8)')
     &   labdb(idb)(1:45),ewadopt,lab20,labdb(idb)(73:80)
      else
        write(58,'(6x,f9.3,30x,f7.1,17x,''('',a1,'')'',8x)')
     &  x(2),ewadopt,chadopt
      end if
      close (58)
      last=last+1
      isv(last)=idb
      end if
c      save logs to "ewcal.log"
       open (unit=12,file='ewcal.log',access='append')
       call getdat(idt1,idt2,idt3)
       call gettim(itm1,itm2,itm3,itm4)
       write(12,*)
     &'................................................................'
       write(12,23) idt1,idt2,idt3,itm1,itm2,itm3
   23  format(i4,'-',i2,'-',i2,3x,i2,':',i2,':',i2)
       if(dopcor.ne.0.) then
         write(labdopc,'(SP,f7.2,SS)') dopcor
         write(12,'(''obspec:{'',a7,''}'',a60)') labdopc,labobs
       else if(abs(dcfac-1).gt.0.000000001) then
         dopcor_suc=(dcfac-1.)*2.997925e5
         write(labdopc,'(SP,f7.2,SS)') dopcor_suc
         write(12,'(''obspec:{'',a7,''}'',a60)') labdopc,labobs
       else
         labdopc=''
         write(12,'(''obspec:'',a60)') labobs
       end if
       write(12,576) ewxbeg,ewxend
  576  format('ewxbeg=',0pf8.2,'  ewxend=',0pf8.2)
       if(tilta.eq.0.) then
         write(12,'(" ycont=",' // fmty // ',"  fz="' //
     &   ',1pe12.5,"  yshift=", 0pf8.4," dcfac=",1pe10.3)')
     &   ycont,fz,yshift,dcfac
c  577    format(' ycont=',0pf8.4,'  fz=',1pe12.5,'  yshift=',0pf8.4)
       else
         write(12,'(" ycont=",' // fmty // ',"  fz="' //
     &   ',1pe12.5,"  yshift=", 0pf8.4," dcfac=",1pe10.3' //
     &   ',"  tilta=",0pf8.5,"  ref(A)=",0pf8.2)')
     &   ycont,fz,yshift,dcfac,tilta,0.5*(xmin+xmax)
c 1577    format(' ycont=',0pf8.4,'  fz=',1pe12.5,'  yshift=',0pf8.4,
c     & '  tilta=',0pf8.5,'  ref(A)=',0pf8.2)
       end if
c       write(12,'(''x(1),x(2),x(3):'',3f11.4)') x(1),x(2),x(3)
       write(12,'(''x(1),x(2),x(3):'',3f11.4,3x,''ek,adamp:'',2f8.4)')
     & x(1),x(2),x(3),ek,adamp
       write(12,'(''ewma(g)='',f7.1,1x,a1)') ewmag,csigng
       write(12,'(''ewma(d)='',f7.1,1x,a1)') ewmad,csignd
       write(12,'(''<<<< WIDTH FORMAT >>>>'')')

       if(ifthex.eq.0) go to 879

c      theoretical mode
       ch=' '
       if(nlsel.ge.2) then
       write(ch,'(i1)') nlsel-1
       end if
       if(modedg.eq.1) then
c       write(12,'(''direct-c value adopted:'',f7.1)') ewmad
       write(12,591) ch,cody(is1),wlay(is1),epoy(is1),gfly(is1),
     &  glry(is1),glsy(is1),glwy(is1),ewmad,chadopt,
     & labobs(max(ns,ne-15):ne)
       end if
       if(modedg.eq.2) then
c       write(12,'(''gaussian value adopted:'',f7.1)') ewmag
       write(12,592) ch,cody(is1),wlay(is1),epoy(is1),gfly(is1),
     &  glry(is1),glsy(is1),glwy(is1),ewmag,chadopt,
     & labobs(max(ns,ne-15):ne)
       end if
      if(nlsel.ge.2) then
        do is=1,nlsel
          ist=ilsel(is)
          if(ist.eq.is1) cycle
          write(12,593) wlay(ist),gfly(ist)
        end do
        write(12,594) aspanl,aspanr,astep
      end if
       write(12,'(''comment:'',a68)') comment

       write(12,'(''[[ nearby line information (ifthex=1)]] threseta='',
     &  1pe12.5)') threseta
       do is=1,isel
        ele=eley(is)
        wla=wlay(is)
        epo=epoy(is)
        eta=etay(is)
        write(12,'(i2,1x,a3,1x,f9.3,f6.3,1x,f9.4)') is,ele,wla,epo,eta
       end do
       write(12,'(''nlsel='',i2)') nlsel
       write(12,'(''ilsel='',17i4)') (ilsel(is),is=1,nlsel)
       write(12,'(''modedg='',i2)') modedg
       write(12,*)

       go to 878
c

  879   continue

c       batch mode
      dwcrt1=dwcrt
      if(dwcrt1.lt.0.) dwcrt1=abs(dwcrt)*(wlamdb(idb)/5000.)
        if(idb.gt.0.and.abs(x(2)-wlamdb(idb)).lt.dwcrt1) then
          write(lab20,'(a16,i3,a1)')
     &     labobs(ibgn:iend),nofoc,chadopt
          write(12,'(a45,f7.1,a20,a8)')
     &     labdb(idb)(1:45),ewadopt,lab20,labdb(idb)(73:80)
        else
          write(12,'(6x,f9.3,30x,f7.1,17x,''('',a1,'')'',8x)')
     &    x(2),ewadopt,chadopt
        end if
       write(12,'(''comment:'',a68)') comment

  878 continue

      if(ifbisec.eq.1.or.ifbisec.eq.3) then
c     observed spectral data for EW measurement
      ewxb_t=x(2)-2.*(x(2)-ewxbeg)
      ewxe_t=x(2)+2.*(ewxend-x(2))
      call range(xs*dcfac-dshft,nd,ewxb_t,ewxe_t,ne1_t,ne2_t)
      do n=ne1_t,ne2_t
      xtmp(n)=(xs(n)*dcfac-dshft)-x(2)
      ytmp(n)=ys(n)*fz+yshift
      if(n.lt.ne1.or.n.gt.ne2) ytmp(n)=-ytmp(n)
      end do
      write(12,'(''<<spectral data for EW measurement>>'')')
      write(12,'(''ne:'',i3,''  ne_t:'',i3)')
     & ne2-ne1+1,ne2_t-ne1_t+1
      write(12,'(''dw:'',10f7.4)') (xtmp(n),n=ne1_t,ne2_t)
      write(12,'(''rd:'',10f7.4)') (ytmp(n),n=ne1_t,ne2_t)
      end if
c
      if(ifbisec.ge.2) then
c     write out profile (bisector) information
      write(12,'(''<<line-profile asymmentry (bisector)>>'')')
      write(12,'(f10.4,i4)') xpeak,nstep
      write(12,'(''L: '',10f8.4)') (dxl(ip),ip=1,nstep)
      write(12,'(''R: '',10f8.4)') (dxr(ip),ip=1,nstep)
      write(12,'(''C: '',10f8.4)') (dxc(ip),ip=1,nstep)
      write(12,'(''FN:'',10f8.5)') (yint(ip)/ycont,ip=1,nstep)
      end if

      close (12)

      status= SETCOLORRGB(forecolor)
c      return <-- scratched because of the redundancy (see below) 2003/12/1
  567 continue
c--------------------------------------------
c       recover ymin and ymax for the case of ifabs=1
        if(ifabs.eq.1) then
          ymax=ymaxkeep
          ymin=yminkeep
        end if
      return
      end

      subroutine eraselast
      use dflib
      implicit real*8 (a-h,o-z)
      character*120 line
      character*1 ch
      character*15 charline
      logical loexist
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/ewdbout/dwcrt,loewout,fnewout
      character*60 fnewout
      logical loewout
      integer*4 result
c
c     append cancel-request info at the end of ewcal.log
      open (unit=12,file='ewcal.log',access='append')
      write(12,'(a)')'(^^^ Cancel request has been dispatched ^^^)'
      close (12)
c
c     modifies fnewout if exists
      if(loewout) then
      open (unit=58,file=fnewout)
      rewind 58
c     temporary file is allocated to unit 91
      open (unit=91,form='formatted',disp='delete')
      rewind 91
      k=0
      do i=1,9999
        read(58,'(a)',end=299) line
        write(91,'(a)') line
        k=k+1
      end do
  299 continue
      kt=k
      if(kt.le.1) then
c       as a result, we have to delete all contents of fnewout
        close (58)
        close (91)
        result=systemqq('del '//fnewout)
        open (unit=58,file=fnewout,form='formatted')
        close (58)
      else
        rewind 91
        rewind 58
        do i=1,kt-1
          read(91,'(a)') line
          call lablen(line,120,mbgn,mend)
          write(58,'(a)') line(1:mend)
        end do
        close (58)
        close (91)
      end if
      end if

c     modifies linedat.tmp in case of ifthex=1
      if(ifthex.eq.1) then
      open (unit=13,file='linedat.tmp')
      rewind 13
c     temporary file is allocated to unit 91
      open (unit=91,form='formatted',disp='delete')
      rewind 91
      k=0
      do i=1,9999
        read(13,'(a)',end=399) line
        write(91,'(a)') line
        k=k+1
      end do
  399 continue
      kt=k
      if(kt.le.1) then
c       as a result, we have to delete all contents of linedat.tmp
        close (13)
        close (91)
        result=systemqq('del linedat.tmp')
        open (unit=13,file='linedat.tmp',form='formatted')
        close (13)
      else
        rewind 91
        rewind 13
        do i=1,kt-1
          read(91,'(a)') line
          call lablen(line,120,mbgn,mend)
          write(13,'(a)') line(1:mend)
        end do
        close (13)
        close (91)
      end if
      end if

      return
      end


      subroutine ewmulti(ne1best,ne2best)
      USE DFLIB
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      parameter (mdq=1000,ndq=3)

      dimension xguess(ndq),x(ndq)
      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      common/mask/fz,yshift,imk,wms(99),wme(99)
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/spec/nd,xs(md),ys(md)
      common/passxy/mxpos,mypos
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/ewcalc/ewxbeg,ewxend
      character*3 ele,eley(77)
      dimension wlay(77),etay(77),cody(77),epoy(77),gfly(77)
      character*6 glr,gls,glw,glry(77),glsy(77),glwy(77)
      common/dopcorrect/dopcor,dopref,dcfac,drfac
      common/xyvpass/xv,yv
      common/ewprm/dwsp_n,dwsp,ngeta
      common/grparams/ek,adamp,area
      dimension sigfit(50,50),ewgau(50,50),ewdir(50,50)
      dimension efwid(50,50)
      dimension resi(77),tsus(77),expect(77)
c     ecrt is the critical value for Chauvenet's criterion
c     data ecrt/0.5/
      data ecrt/1.0/
c     multi-EW evaluation mode
      if(ifewid.ne.-1) then
        write(*,*) 'Why not ifewid = -1?'
        stop
      end if

c     finds the line-depth maximum
      wf=xv/5000.
      call range
     & (xs*dcfac-dshft,nd,xv-wf*dwsp_n,xv+wf*dwsp_n,nw1_n,nw2_n)
      call range(xs*dcfac-dshft,nd,xv-wf*dwsp,xv+wf*dwsp,nw1,nw2)
      nwc=0
      ywmin=1.e30
      do n=nw1_n,nw2_n
      yy=ys(n)*fz+yshift
      if(yy.lt.ywmin) then
      nwc=n
      ywmin=yy
      end if
      end do
      ycont=yv
c      call range(xs*dcfac-dshft,nd,ewxbeg,ewxend,ne1,ne2)
      kz1=nwc-nw1
      kz2=nw2-nwc
      if(kz1.gt.50.or.kz2.gt.50) then
      write(*,*) 'dwsp_n,dwsp=',dwsp,dwsp_n
      write(*,*) 'nwc,nw1,nw2=',nwc,nw1,nw2
      write(*,*) 'kz1,kz2=',kz1,kz2
      stop
      end if
      do 600 k1=1,kz1
      do 600 k2=1,kz2
      ne1=nwc-k1
      ne2=nwc+k2
      ewid=0.
      xcenmin=xmax
      ycenmin=1.e30
      iin=0
      do n=ne1,ne2
        yy=ys(n)*fz+yshift
        iin=iin+1
        wlamo(iin)=xs(n)*dcfac-dshft
        speco(iin)=yy
c        rdep=1.- yy/ycont
        rdep=1.- (yy-yshift)/(ycont-yshift)
        if(n.eq.ne1) then
          ewid=ewid+0.5*(xs(ne1+1)*dcfac-xs(ne1)*dcfac)*rdep
        else if (n.eq.ne2) then
          ewid=ewid+0.5*(xs(ne2)*dcfac-xs(ne2-1)*dcfac)*rdep
        else
          ewid=ewid+0.5*(xs(n+1)*dcfac-xs(n-1)*dcfac)*rdep
        end if
        if(yy.lt.ycenmin) then
          xcenmin=xs(n)*dcfac-dshft
          ycenmin=yy
        end if
      end do
      nlamo=iin
      ewmad=ewid*1000.
      ewdir(k1,k2)=ewmad
c
      if(vw.gt.0.) then
        doplamd=xcenmin*max(3.,vw)/2.997925e5
      else
        doplamd=xcenmin*max(3.,abs(vw))*0.75/2.997925e5
      end if

      xguess(1)=ycont-ycenmin
      xguess(2)=xcenmin
      xguess(3)=doplamd
c
c     prepare nlamo,wlamo,speco, set ycont, and guess xguess(1-3)
c
c      call solve(nlamo,xguess,x,icode,itype)
      call solve_nl(nlamo,xguess,x)

c     calculates sigma (goodness-of-fit) for the integrated range
      sumsq=0.
      do n=ne1,ne2
      yobs=ys(n)*fz+yshift
      if(ek.eq.0..and.adamp.eq.0.) then
        arg=((xs(n)*dcfac-dshft-x(2))/x(3))**2
        ygau=ycont-x(1)*exp(-arg)
      else
        ygau=ycont-x(1)*grx((xs(n)*dcfac-dshft-x(2))/x(3))
      end if
      sumsq=sumsq+(yobs-ygau)**2
      end do
      sigfit(k1,k2)=sqrt(sumsq/(ne2-ne1+1))

      if(ek.eq.0..and.adamp.eq.0.) then
        ewmag=(x(1)/(ycont-yshift))*x(3)*1000.*1.772454
      else
        call calarea
        ewmag=(x(1)/(ycont-yshift))*x(3)*1000.*area
      end if
      ewgau(k1,k2)=ewmag
      efwid(k1,k2)=x(3)
  600 continue
c     delxs is the wavelength unit (in A) corresponding to one step
      delxs=abs(xs(nwc+1)-xs(nwc))*dcfac
c     Now we find the best range
      k1sel=0
      k2sel=0
      pfsel=+1.e30
c     starting from 2 instead of 1
      do 700 k1=2,kz1
      do 700 k2=2,kz2
c     avoid negative ew
      if(ewgau(k1,k2).le.0..or.ewdir(k1,k2).le.0.) go to 700
      delspan1=delxs*float(k1)
      delspan2=delxs*float(k2)
c     we require that
c     max(span1,span2) should be larger than 1.0*efwid (e-folding half-width) 
c     and min(span1,span2) should be larger than 0.5*efwid
      if(max(delspan1,delspan2).lt.efwid(k1,k2)) go to 700
      if(min(delspan1,delspan2).lt.0.5*efwid(k1,k2)) go to 700
c
c      pf=sigfit(k1,k2)
      pf=sigfit(k1,k2)/float(k1+k2)
c
      if(pf.lt.pfsel) then
      k1sel=k1
      k2sel=k2
      pfsel=pf
      end if
  700 continue

      if(ngeta.gt.0) then
      k1sel=k1sel+ngeta
      k2sel=k2sel+ngeta
      end if
      ne1sel=nwc-k1sel
      ne2sel=nwc+k2sel
      ym0=ys(ne1sel-0)*fz+yshift
      ym1=ys(ne1sel-1)*fz+yshift
      ym2=ys(ne1sel-2)*fz+yshift
      ym3=ys(ne1sel-3)*fz+yshift
      ym4=ys(ne1sel-4)*fz+yshift
      yp0=ys(ne2sel+0)*fz+yshift
      yp1=ys(ne2sel+1)*fz+yshift
      yp2=ys(ne2sel+2)*fz+yshift
      yp3=ys(ne2sel+3)*fz+yshift
      yp4=ys(ne2sel+4)*fz+yshift
      kzum=4
      kzup=4
      if(ym4.lt.ym3.and.ym3.lt.ym2) kzum=kzum-1
      if(yp4.lt.yp3.and.yp3.lt.yp2) kzup=kzup-1
      if(ym3.lt.ym2.and.ym2.lt.ym1) kzum=kzum-1
      if(yp3.lt.yp2.and.yp2.lt.yp1) kzup=kzup-1
      if(ym2.lt.ym1.and.ym1.lt.ym0) kzum=kzum-1
      if(yp2.lt.yp1.and.yp1.lt.yp0) kzup=kzup-1
      ne1best=nwc-k1sel-kzum
      ne2best=nwc+k2sel+kzup
c

c
c     edge check (fitting viewpoint)
c
      ne1=ne1best
      ne2=ne2best
      xcenmin=xmax
      ycenmin=1.e30
      iin=0
      do n=ne1,ne2
        yy=ys(n)*fz+yshift
        iin=iin+1
        wlamo(iin)=xs(n)*dcfac-dshft
        speco(iin)=yy
        if(yy.lt.ycenmin) then
          xcenmin=xs(n)*dcfac-dshft
          ycenmin=yy
        end if
      end do
      nlamo=iin
c
      if(vw.gt.0.) then
        doplamd=xcenmin*max(3.,vw)/2.997925e5
      else
        doplamd=xcenmin*max(3.,abs(vw))*0.75/2.997925e5
      end if

      xguess(1)=ycont-ycenmin
      xguess(2)=xcenmin
      xguess(3)=doplamd
c
c     prepare nlamo,wlamo,speco, set ycont, and guess xguess(1-3)
c
c      call solve(nlamo,xguess,x,icode,itype)
      call solve_nl(nlamo,xguess,x)
c     checking the residual
      do n=ne1,ne2
      yobs=ys(n)*fz+yshift
      if(ek.eq.0..and.adamp.eq.0.) then
        arg=((xs(n)*dcfac-dshft-x(2))/x(3))**2
        ygau=ycont-x(1)*exp(-arg)
      else
        ygau=ycont-x(1)*grx((xs(n)*dcfac-dshft-x(2))/x(3))
      end if
      resi(n-ne1+1)=yobs-ygau
      end do
      sum=0.
      do k=1,ne2-ne1+1
        sum=sum+resi(k)
      end do
      avres=sum/(ne2-ne1+1)
      sumsq=0.
      do k=1,ne2-ne1+1
        sumsq=sumsq+(resi(k)-avres)**2
      end do
      sigres=sqrt(sumsq/(ne2-ne1+1-1))
      do k=1,ne2-ne1+1
        tsus(k)=abs(resi(k)-avres)/sigres
        expect(k)=pp(tsus(k))*(ne2-ne1+1)
      end do
c      write(*,'(i6)') ne2-ne1+1
c      write(*,'(20f7.3)') (tsus(k),k=1,ne2-ne1+1)
c      write(*,'(20f7.1)') (expect(k),k=1,ne2-ne1+1)
      nrj1max=0
      do n=ne1,ne1+2
      if(expect(n-ne1+1).lt.0.5) then
      if(n.gt.nrj1max) nrj1max=n
      end if
      end do
      nrj2min=99999
      do n=ne2,ne2-2,-1
      if(expect(n-ne1+1).lt.ecrt) then
      if(n.lt.nrj2min) nrj2min=n
      end if
      end do
      ne1best=ne1
      if(nrj1max.ge.ne1) ne1best=nrj1max+1
      ne2best=ne2
      if(nrj2min.le.ne2) ne2best=nrj2min-1
c      write(*,*) ne1best-ne1+1,' lower limit'
c      write(*,*) ne2best-ne1+1,' upper limit'
c
c     final edge check (gradient viewpoint)
c
      ne1fin=ne1best
      yl0=ys(ne1best+0)*fz+yshift
      yl1=ys(ne1best+1)*fz+yshift
      yl2=ys(ne1best+2)*fz+yshift
      yl3=ys(ne1best+3)*fz+yshift
      if(yl0.lt.yl1) ne1fin=ne1best+1
      if(yl0.lt.yl1.and.yl1.lt.yl2) ne1fin=ne1best+2
      if(yl1.lt.yl2.and.yl2.lt.yl3) ne1fin=ne1best+3
      ne2fin=ne2best
      yr0=ys(ne2best-0)*fz+yshift
      yr1=ys(ne2best-1)*fz+yshift
      yr2=ys(ne2best-2)*fz+yshift
      yr3=ys(ne2best-3)*fz+yshift
      if(yr0.lt.yr1) ne2fin=ne2best-1
      if(yr0.lt.yr1.and.yr1.lt.yr2) ne2fin=ne2best-2
      if(yr1.lt.yr2.and.yr2.lt.yr3) ne2fin=ne2best-3
      ne1best=ne1fin
      ne2best=ne2fin
c      write(*,*) ne2best-ne1best+1,' <-- total number (final)'
c
c
c
      return
      end


      subroutine srchbe(lab60,nc,ibgn,iend)
      implicit real*8 (a-h,o-z)
      character*60 lab60
      call lablen(lab60,nc,nsz,nez)
      idfi=index(lab60,'.fit')
      idbl=index(lab60,'[')
      iddt=index(lab60,'.dat')
      idtx=index(lab60,'.txt')
      if(idfi.gt.0) then
      iend=idfi-1
      else if(idbl.gt.0) then
      iend=idbl-1
      else if(iddt.gt.0) then
      iend=iddt-1
      else if(idtx.gt.0) then
      iend=idtx-1
      else
      iend=nez
      end if
      ibgn=iend-15
      if(ibgn.le.0) then
      ibgn=1
      iend=16
      end if
      return
      end

      subroutine polset(npoly,khwpix,dx,dy)
      implicit real*8 (a-h,o-z)
      common/polpas/npl,xpl(50),ypl(50)
      data pi/3.141592653589793/
      if(npoly.gt.50) then
        write(*,*) npoly, ' is too large for npl!'
        call exit(1)
      end if
      npl=npoly
      do i=1,npl
        theta=2.*pi*(i-1)/dfloat(npl)
        xpl(i)=sin(theta)*dx*khwpix
        ypl(i)=cos(theta)*dy*khwpix
      end do
      return
      end

      subroutine polplot(x,y)
      USE DFLIB
      implicit real*8 (a-h,o-z)
      type (wxycoord) xy
      integer*4 status
      common/polpas/npl,xpl(50),ypl(50)
      call moveto_w(x+xpl(1),y+ypl(1),xy)
      do i=2,npl
        status=lineto_w(x+xpl(i),y+ypl(i))
      end do
      status=lineto_w(x+xpl(1),y+ypl(1))
      return
      end

      subroutine lablen(label,nlen,ns,ne)
      implicit real*8 (a-h,o-z)
      character*(*) label
      do n=nlen,1,-1
      if((label(n:n).ne.' ').and.(label(n:n).ne.'')) go to 10
      end do
      n=1
  10  ne=n
      do n=1,nlen
      if((label(n:n).ne.' ').and.(label(n:n).ne.'')) go to 20
      end do
      n=nlen
  20  ns=n
      return
      end
      subroutine fmtset(k,m,fmt)
      implicit real*8 (a-h,o-z)
      character*16 fmt
      i=-k
      if (m.eq.3) i=i+1
      i=max0(0,i)
      if (i.le.0) then
      fmt='(f10.0)'
      else if (i.eq.1) then
      fmt='(f10.1)'
      else if (i.eq.2) then
      fmt='(f10.2)'
      else if (i.eq.3) then
      fmt='(f10.3)'
      else if (i.eq.4) then
      fmt='(f10.4)'
      else if (i.eq.5) then
      fmt='(f10.5)'
      end if
      return
      end

c      subroutine solve(nlamo,xguess,x,icode,itype)
c      use numerical_libraries
c      implicit real*8 (a-h,o-z)
c      parameter  (mdq=1000,ldfjac=mdq,ndq=3)
c      integer*4 iparam(7)
c      dimension fjac(ldfjac,ndq), fscale(mdq)
c      dimension rparam(7), x(ndq), xguess(ndq), xlb(ndq)
c      dimension xs(ndq), xub(ndq)
c      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
c      external fcn
c      m=nlamo
c      n=ndq
c
c      do i=1,m
c        fscale(i)=1.
c      end do
c
c      do j=1,n
c        xs(j)=1.
c        xlb(j)=0.
c        xub(j)=1.e30
c      end do
cC                                 All the variables are positive
c      itp = 1
cC                                 Default parameters are used
c      iparam(1) = 0
cC
c      call erset(3,0,0)
c      call erset(4,0,0)
c      call erset(5,0,0)
c      call dbclsf (fcn, m, n, xguess, itp, xlb, xub, xs,
c     &            fscale, iparam, rparam, x, fvec, fjac, ldfjac)
c      icode=iercd()
c      itype=n1rty(1)
c      return
c      end

      subroutine solve_nl(nlamo,xguess,x)
      implicit real*8 (a-h,o-z)
      parameter  (mdq=1000,ldfjac=mdq,ndq=3)
c     version using "netlib" nonlinear least squares optimization code

      integer m,n,maxfev,mode,nprint,info,nfev
      integer ipvt(ndq)
      real*8 ftol,xtol,gtol,epsfcn,factor
      real*8 x(ndq),diag(ndq),fjac(ldfjac,ndq),qtf(ndq),
     *       wa1(ndq),wa2(ndq),wa3(ndq),wa4(mdq)
      real*8 xguess(ndq)

      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      external fcn
      m=nlamo
      n=ndq
c.................
      ftol=1.e-11
      xtol=1.e-11
      gtol=1.e-11
      maxfev=10000
      epsfcn=1.e-11
      mode=1
      factor=100.
      nprint=1
c.................

      call lmdif(fcn,m,n,xguess,fvec,ftol,xtol,gtol,maxfev,epsfcn,
     *            diag,mode,factor,nprint,info,nfev,fjac,ldfjac,
     *            ipvt,qtf,wa1,wa2,wa3,wa4)

      x(1)=xguess(1)
      x(2)=xguess(2)
      x(3)=xguess(3)

      return
      end


      subroutine fcn (m, n, x, f, iflag)
      implicit real*8 (a-h,o-z)
      parameter (mdq=1000)
      integer m, n, iflag
      dimension x(n),f(m)
      common/grparams/ek,adamp,area
      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      do i=1,m
      if(ek.eq.0..and.adamp.eq.0.) then
        arg=((wlamo(i)-x(2))/x(3))**2
        f(i)=speco(i)-(ycont-x(1)*exp(-arg))
      else
        f(i)=speco(i)-(ycont-x(1)*grx((wlamo(i)-x(2))/x(3)))
      end if
      end do
      return
      end

      function gaussian(x)
      implicit real*8 (a-h,o-z)
      gaussian=exp(-x**2)
      return
      end

      subroutine calarea
      implicit real*8 (a-h,o-z)
      parameter (mp=200)
      common/grparams/ek,adamp,area
c     for evaluating the normalizing constant only for the 1st time
      data del/0.05/,eksv/-999.9/,adampsv/-999.9/
      data areasv/-999.9/
      if(ek.eq.eksv.and.adamp.eq.adampsv) then
      area=areasv
      return
      end if
      eksv=ek
      adampsv=adamp
      yy=0.
      do j=-mp,+mp
      xx=del*j
      yy=yy+del*grx(xx)
      end do
      areasv=yy
      area=yy
      return
      end

      function grx(x)
      implicit real*8 (a-h,o-z)
      parameter (mp=200)
      dimension dv(-mp:+mp),gr(-mp:+mp)
      common/grparams/ek,adamp,area
      if(ek.le.0.) then
      grx=voigt(abs(x),adamp)
      return
      end if
      call gaurot(dv,gr,sumgr,dvh)
      vsel=abs(x)*dvh/0.8325546
      if(vsel.gt.dv(mp)) then
      grx=0.
      return
      end if
      idum=map1(dv(0),gr(0),mp+1,vsel,grsel,1)
      grx=grsel/gr(0)
      return
      end

      subroutine gaurot(dv,gr,sumgr,dvh)
      implicit real*8 (a-h,o-z)
      parameter (mp=200)
      dimension gau(-mp:+mp),rot(-mp:+mp),dv(-mp:+mp),gr(-mp:+mp)
      data vd/5.0/,delv/0.25/,np/200/
      data eksv/-999.9/,adampsv/-999.9/
      common/grparams/ek,adamp,area
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      epsld=0.6
c
      if(ek.eq.eksv.and.adamp.eq.adampsv) return
      eksv=ek
      adampsv=adamp

      vr=vd*ek
      denom=3.14159265*vr*(1.-epsld/3.)
      c1=2.*(1-epsld)/denom
      c2=0.5*3.14159265*epsld/denom

      do n=-np,+np
        dv(n)=delv*n
        gau(n)=voigt(abs(dv(n)/vd),adamp)/(vd*1.7724539)
        arg=1.-(dv(n)/vr)**2
        if(arg.ge.0.) then
          rot(n)=c1*sqrt(arg)+c2*arg
        else
          rot(n)=0.
        end if
      end do

      sumr=0.
      sumg=0.
      sumgr=0.
      do n=-np,+np
        sumr=sumr+rot(n)*delv
        sumg=sumg+gau(n)*delv
        sum=0.
        do m=-np,+np
          nm=n-m
          if(nm.lt.-np) nm=-np
          if(nm.gt.+np) nm=+np
          sum=sum+rot(nm)*gau(m)*delv
        end do
        gr(n)=sum
        sumgr=sumgr+gr(n)*delv
      end do

      do n=-np,+np
        gau(n)=gau(n)/sumg
        rot(n)=rot(n)/sumr
        gr(n)=gr(n)/sumgr
      end do

      idum=map1(gr(-mp),dv(-mp),mp+1,0.5*gr(0),dvh,1)
      dvh=abs(dvh)

      return
      end

      subroutine setkgf(fnout)
      use dfport
      implicit real*8 (a-h,o-z)
      character*133 line
      character*10 label,labelp
      character fnout*60,linedir*80
      character*9 gfname(190)
      character*9 gflab1(50),gflab2(50),gflab3(50),gflab4(40)
c
      logical locx,logx,loex,lowx
      character*1 chrem
c
      dimension wlimit(0:190),wsave(99999)
      data gflab1/
     a'GF0010.10','GF0020.10','GF0030.10','GF0040.10','GF0050.10',
     1'GF0060.10','GF0070.10','GF0080.10','GF0090.10','GF0100.10',
     2'GF0110.10','GF0120.10','GF0130.10','GF0140.10','GF0150.10',
     3'GF0160.10','GF0170.10','GF0180.10','GF0190.10','GF0200.10',
     4'GF0210.10','GF0220.10','GF0230.10','GF0240.10','GF0250.10',
     5'GF0260.10','GF0270.10','GF0280.10','GF0290.10','GF0300.10',
     6'GF0310.10','GF0320.10','GF0330.10','GF0340.10','GF0350.10',
     7'GF0360.10','GF0370.10','GF0380.10','GF0390.10','GF0400.10',
     8'GF0410.10','GF0420.10','GF0430.10','GF0440.10','GF0450.10',
     9'GF0460.10','GF0470.10','GF0480.10','GF0490.10','GF0500.10'/
      data gflab2/
     a'GF0510.10','GF0520.10','GF0530.10','GF0540.10','GF0550.10',
     1'GF0560.10','GF0570.10','GF0580.10','GF0590.10','GF0600.10',
     2'GF0610.10','GF0620.10','GF0630.10','GF0640.10','GF0650.10',
     3'GF0660.10','GF0670.10','GF0680.10','GF0690.10','GF0700.10',
     4'GF0710.10','GF0720.10','GF0730.10','GF0740.10','GF0750.10',
     5'GF0760.10','GF0770.10','GF0780.10','GF0790.10','GF0800.10',
     6'GF0810.10','GF0820.10','GF0830.10','GF0840.10','GF0850.10',
     7'GF0860.10','GF0870.10','GF0880.10','GF0890.10','GF0900.10',
     8'GF0910.10','GF0920.10','GF0930.10','GF0940.10','GF0950.10',
     9'GF0960.10','GF0970.10','GF0980.10','GF0990.10','GF1000.10'/
      data gflab3/
     a'GF1100.10','GF1200.10','GF1300.10','GF1400.10','GF1500.10',
     1'GF1600.10','GF1700.10','GF1800.10','GF1900.10','GF2000.10',
     2'GF2100.10','GF2200.10','GF2300.10','GF2400.10','GF2500.10',
     3'GF2600.10','GF2700.10','GF2800.10','GF2900.10','GF3000.10',
     4'GF3100.10','GF3200.10','GF3300.10','GF3400.10','GF3500.10',
     5'GF3600.10','GF3700.10','GF3800.10','GF3900.10','GF4000.10',
     6'GF4100.10','GF4200.10','GF4300.10','GF4400.10','GF4500.10',
     7'GF4600.10','GF4700.10','GF4800.10','GF4900.10','GF5000.10',
     8'GF5100.10','GF5200.10','GF5300.10','GF5400.10','GF5500.10',
     9'GF5600.10','GF5700.10','GF5800.10','GF5900.10','GF6000.10'/
      data gflab4/
     a'GF6100.10','GF6200.10','GF6300.10','GF6400.10','GF6500.10',
     1'GF6600.10','GF6700.10','GF6800.10','GF6900.10','GF7000.10',
     2'GF7100.10','GF7200.10','GF7300.10','GF7400.10','GF7500.10',
     3'GF7600.10','GF7700.10','GF7800.10','GF7900.10','GF8000.10',
     4'GF8100.10','GF8200.10','GF8300.10','GF8400.10','GF8500.10',
     5'GF8600.10','GF8700.10','GF8800.10','GF8900.10','GF9000.10',
     6'GF9100.10','GF9200.10','GF9300.10','GF9400.10','GF9500.10',
     7'GF9600.10','GF9700.10','GF9800.10','GF9900.10','GFEND.10 '/
      equivalence (gfname(001),gflab1(1))
      equivalence (gfname(051),gflab2(1))
      equivalence (gfname(101),gflab3(1))
      equivalence (gfname(151),gflab4(1))
      call lablen(fnout,60,ns,nend)
      if(fnout(nend-3:nend).ne.'.kgf') go to 699
      ne=nend-4
      nc=ne-ns+1
      if(nc.gt.12.or.nc.lt.4.or.mod(nc,2).ne.0) go to 699
      nch=nc/2
      do i=ns,ne
      if(ifnum(fnout(i:i)).eq.0) go to 699
      end do
      go to 700
  699 write(*,'(a60)') fnout
      write(*,'(a)') fnout(ns:ns+nch-1)//' '//fnout(ns+nch:ne)
      write(*,*)'####.kgf, '//
     &'######.kgf, ########.kgf, ##########.kgf, ############.kgf'
      write(*,*) 
     & '(number of # should be even, and any of 4, 6, 8, 10, 12)'
      stop
  700 continue
      read(fnout(ns:ns+nch-1),*) iwla1
      read(fnout(ns+nch:ne),*) iwla2
      if(iwla1.ge.iwla2) then
        write(*,*) 'Check the specified range ---> ',iwla1,iwla2
        stop
      end if
      wla1=iwla1
      wla2=iwla2
c      call getenv("KGF_DIR",linedir)
      call retenv("KGF_DIR",linedir)
      call lablen(linedir,80,nsdir,nedir)
      wlimit(0)=0.
      do i=1,189
      read(gfname(i),'(2x,f5.0,2x)') wlimit(i)
      end do
      wlimit(190)=1.d99
      open (unit=40,file=fnout)
      wln1=wla1/10.
      wln2=wla2/10.
      do 11 k=1,190
      if(wln1.ge.wlimit(k-1).and.wln1.le.wlimit(k)) go to 12
   11 continue
      write(*,*) '!! wla1=',wla1
      stop
   12 ks=k
      do 21 k=190,1,-1
      if(wln2.ge.wlimit(k-1).and.wln2.le.wlimit(k)) go to 22
   21 continue
      write(*,*) '!! wla2=',wla2
      stop
   22 ke=k
      do 100 k=ks,ke
      open (unit=38,file=linedir(nsdir:nedir)//'\'//gfname(k),
     & form='formatted')
      iline=0
      do 9 i=1,1000000
      read(38,'(a)',err=90,end=90) line
      call lablen(line,133,nsln,neln)
      if(ifnum(line(nsln:nsln)).eq.0) go to 9
      read(line,2,end=90)wl,gflog,code,e,xj,label,ep,xjp,labelp,
     & gammar,gammas,gammaw
    2 format(f11.4,f7.3,f6.2,f12.3,f5.1,1x,a10,f12.3,f5.1,1X,a10,3f6.2)
      if(wl.lt.wln1.or.wl.gt.wln2) go to 9
      ek=e
      if(ep.lt.e) ek=ep
      expot=1.23981e-4*ek
      wla=wl*10.
c
      locx=abs(code-codepre).le.0.001
      lowx=abs(wl-wlpre)*10..le.0.001
      loex=abs(expot-expotpre).le.0.001
      logx=abs(gflog-gflogpre).le.0.001
      if(locx.and.lowx.and.loex.and.logx) then
        chrem='*'
        write(*,223) '!!!! caution !!!',iline,code,wl*10.,expot,gflog
  223   format(1h ,a16,i5,':',f9.2,f11.3,f8.3,f8.3)
      else
        chrem=' '
      end if
      codepre=code
      wlpre=wl
      expotpre=expot
      gflogpre=gflog
c
      write(40,222) code,wla,expot,gflog,gammar,gammas,gammaw,chrem
  222 format(f9.2,f11.3,f8.3,f8.3,3f7.2,1x,a1)
      iline=iline+1
      wsave(iline)=wla
    9 continue
   90 close(38)
      if(iline.le.0) go to 100
      write(*,'(''data output to file:'',a40)') fnout
      write(*,30) k,gfname(k),wsave(1),wsave(iline),iline
   30 format(1h ,'file no.',i3,1x,'fname:',a9,1x,
     % 'from ',f11.3,' to ',f11.3,' A',2x,'(',i6,' lines)')
  100 continue
  999 continue
      close(40)
 9999 return
      end

      subroutine dopcheck(fnamei,fnameo,dopc)
      implicit real*8 (a-h,o-z)
      character*60 fnamei,fnameo
c     check if dopcor option exists
      jbleft =scan(fnamei,'{')
      jbright=scan(fnamei,'}')
      call lablen(fnamei,60,jns,jne)
      if((jbleft*jbright.ne.0).and.(jbleft.eq.jns)) then
      read(fnamei(jbleft+1:jbright-1),*,err=99,end=99) dopc
      fnameo=fnamei(jbright+1:jne)
      else
      dopc=0.
      fnameo=fnamei
      end if
      go to 999
   99 write(*,*) 'I can not read the dopcor value!'
      write(*,'(a)') fnamei
      stop
  999 return
      end


      subroutine checkfit(fnobspec,ifbl,norder)
      implicit real*8 (a-h,o-z)
      character*60 fnobspec
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
c
      logical LOREFR
      character*60 fnrefspec,labref
      common/reflab/LOREFR,fnrefspec,labref
      logical back
c
c     norder is returned if explicitly specified here
c     norder=0  --->   neither {dopcor} nor [order] is specified 
c     ifbl is returned
c     |ifbl| indicates the column number of '[' character
c     ifbl>0 ---> [order,wavelength-points]
c     ifbl<0 ---> [wavelength-points,order]
c


c      ifptxt = index(fnobspec,'.txt',back=.true.)
c      ifpfit = index(fnobspec,'.fit',back=.true.)

c      write(*,'(a)') 'fnobspec:'//trim(fnobspec)
c      write(*,*) 'ifptxt, ifpfit: ',ifptxt, ifpfit

      ifbl=scan(fnobspec,'[')
      ifbr=scan(fnobspec,']')
      ifcomma=scan(fnobspec,',')
      ifstar=scan(fnobspec,'*')
c#
      IF(.NOT.LOREFR) THEN
      wmne=0.
      wmxe=1.e30
      lolimit=.false.
      if(ifbl*ifbr.ne.0.and.ifstar.eq.0) then
      lolimit=.true.
      jbl=ifbl
      jbr=ifbr
      read(fnobspec(jbl+1:jbr-1),*) wmne,wmxe
      end if
      END IF

      if(ifbl*ifbr*ifcomma*ifstar.eq.0) then
      norder=0
      return
      end if
c
      if(ifcomma.lt.ifstar) then
      read(fnobspec(ifbl+1:ifcomma-1),*) norder
      ifbl=+iabs(ifbl)
      else
      read(fnobspec(ifcomma+1:ifbr-1),*) norder
      ifbl=-iabs(ifbl)
      end if
      return
      end


      subroutine bestsel(wmin,wmax)
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      data wminsv,wmaxsv/1.d90,1.d90/
      if(wmin.eq.wminsv.and.wmax.eq.wmaxsv) return
      wminsv=wmin
      wmaxsv=wmax
      if(numord.le.1) then
      novtot=numord
      nobest=numord
      nofoc=numord
      return
      end if
      wcen=0.5*(wmin+wmax)
      novtot=0
      nobest=0
      sepmin=1.e30
      do 100 i=1,numord
      if(wmax.lt.wlmul(1,i).or.wmin.gt.wlmul(nump(i),i)) go to 100
      novtot=novtot+1
      novis(novtot)=i
      xfrac(novtot)=(wcen-wlmul(1,i))/(wlmul(nump(i),i)-wlmul(1,i))
      septmp=abs(xfrac(novtot)-0.5)
      	if(septmp.lt.sepmin) then
      	nobest=novis(novtot)
      	sepmin=septmp
      end if
  100 continue
c
      nofoc=nobest
      nofoc=max(1,nofoc)
      nofoc=min(numord,nofoc)
      return
      end

      subroutine specread(nn,fnamet,ifbl,norder,nptsel,wlasel,specsel)
      use dflib
      use dfport
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      dimension wlasel(md),specsel(md),wla(md),spec(md)
      dimension nbs(99),nbe(99),wlmul_tmp(md),spmul_tmp(md)
      character*60 fnamet,fname,fntxtemp
      integer npoint,npt,norder
      logical loexist
      character filename*80, fmt*80
      character linetemp*80, line*80,ch*1
      character*60 fnamei
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/dummyorder/npx,nmar
      character*255 linelong
      common/convf2t/ifconvf
c
      numord=1
      if(ifbl.eq.0) then
      fname=fnamet
      else
      fname=fnamet(1:iabs(ifbl)-1)
      end if

cccccccccccccccccc
c     Case of fits-->txt converting option
      if(ifconvf.ne.1) go to 1999
      if(index(fname,'.fit',back=.true.).le.0.and.
     & index(fname,'.FIT',back=.true.).le.0) go to 3005
      ifdot1=index(fname,'.fit',back=.true.)
      ifdot2=index(fname,'.FIT',back=.true.)
      ifdot=max(ifdot1,ifdot2)
      ifyen=index(fname,'\',back=.true.)
      if(ifyen.gt.0) then
        fntxtemp=fname(ifyen+1:ifdot-1)//'_temporary.txt'
      else
        fntxtemp=fname(1:ifdot-1)//'_temporary.txt'
      end if
      linelong='convf2t '//trim(fname)//' '//trim(fntxtemp)
      result= systemqq(linelong)
      call textread(nn,fntxtemp,norder)
      write(*,*) 'done!'
      inquire(file=fntxtemp,exist=loexist)
      if(loexist) then
        linelong='del '//trim(fntxtemp)
        result= systemqq(linelong)
      end if
      go to 3001
 1999 continue
cccccccccccccccccc
c     Case where FITS format obspec file (*,fit or *.fits) is directly read
      if(index(fname,'.fit',back=.true.).gt.0.or.
     & index(fname,'.FIT',back=.true.).gt.0) then
        inquire(file=fname,exist=loexist)
        if(.not.loexist) then
          write(*,*) 'Not exist --> '//fname
        end if
        call fitsread(nn,fname,norder)
        go to 3001
      end if
 3005 continue
c     Otherwise case where obspec file is in text format
      inquire(file=fname,exist=loexist)
      if(.not.loexist) then
        write(*,*) 'Not exist --> '//fname
      end if
      call textread(nn,fname)

 3001 continue
c
c     re-ordering if necessary (increasing wavelength)
      do j=1,numord
        if(wlmul(1,j).gt.wlmul(nump(j),j)) then
          do n=1,nump(j)
            wlmul_tmp(n)=wlmul(nump(j)-n+1,j)
            spmul_tmp(n)=spmul(nump(j)-n+1,j) 
          end do
          do n=1,nump(j)
            wlmul(n,j)=wlmul_tmp(n)
            spmul(n,j)=spmul_tmp(n) 
          end do
        end if
      end do
c
      if(numord.eq.1) norder=numord
c
c     check the value of norder
      if((.not.lolimit).and.(norder.lt.1.or.norder.gt.numord)) then
c       set fucus on window 0
        result=focusqq(0)
   42 write(*,'(''Multispe fits file with '',i2,'' orders'')') numord
      write(*,'(''You can specify the spectrum range to display:'')')
      write(*,980)(j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
  980 format(5(1x,'(',i2.2,':',2i5,')'))
      write(*,
     & '(''(Order No.) or (wlmin wlmax) [just enter for all] --> '',$)')
      read(*,'(a)') linetemp
      call lablen(linetemp,80,nns,nne)
        if(nns.gt.nne) then
         write(*,'(''OK, whole spectral range has been selected ...'')')
      	 wmne=min(wlmul(1,1),wlmul(1,numord))
      	 wmxe=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
      	 lolimit=.true.
      	 go to 652
        end if
      read(linetemp,*,err=42) norder
      if(norder.lt.100) then
      	if(norder.lt.1.or.norder.gt.numord) go to 42
      else
      	read(linetemp,*,err=42) wmne,wmxe
      	if( wmne.lt.min(wlmul(1,1),wlmul(1,numord))
     &  .or.wmxe.gt.max(wlmul(nump(1),1),wlmul(nump(numord),numord)) )
     & 	go to 42
      	lolimit=.true.
      	norder=0
      end if
  652 continue
      end if
      if((lolimit).and.(norder.lt.1.or.norder.gt.numord)) then
      call bestsel(wmne,wmxe)
      norder=nobest
      end if

c     set norder to nofoc
      nofoc=norder
c
      npoint=nump(norder)
      if(npoint.gt.md) then
      write(*,*) 'too large npoint=',npoint
      stop
      end if
      do k=1,npoint
      wla(k)=wlmul(k,norder)
      spec(k)=spmul(k,norder)
      end do
      npt=npoint

C     select out spectrum data
c
      nct=0
      do k=1,npt
        if(wla(k).lt.wmne) cycle
        if(wla(k).gt.wmxe) exit
        nct=nct+1
        if(nct.gt.md) then
c     too large obspec points focused order assumed
c!!!! (This part is used when order No. is explicitly specified) !!!
c!!!! (Namely, only this portion is loaded in memory) !!!!
c  
          nptsel=nump(nofoc)
          do kk=1,nptsel
              wlasel(kk)=wlmul(kk,nofoc)
              specsel(kk)=spmul(kk,nofoc)
          end do
          go to 790
        end if
        wlasel(nct)=wla(k)
        specsel(nct)=spec(k)
      end do
   79 continue
      nptsel=nct
      call bestsel(wmne,wmxe)
  790 continue
      return
      end

      subroutine fitsread(nn,fname,norder)
      use dflib
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
c#
      real*8,dimension(:),allocatable :: wla,spec,wla_tmp,spec_tmp
      real*4 buffer(md*100), val(720)
      character*60 fnamet,fname
c#
      dimension naxes(2)
      logical loexist
      character filename*80
      character comment*80,ctype1*8,waxmap01*80
      real*4 crval1,cdelt1,crpix1,cd1_1
      real*4 ltv1, ltm1_1

      integer jdcflag,nwcsdim
      character word8*8,fmt*80,waxmap*80,segment(999)*80,string*2048
      dimension ns(999),ne(999)
      character linetemp*80
      character*80 line(36),head(9999)
      dimension coef(99),x(99), npln(99),noff(99)
      dimension wlmul_tmp(md),spmul_tmp(md)
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/dummyorder/npx,nmar
c
      exp10(x)=exp(x*2.302585092994e0)
c
      inquire(file=fname,exist=loexist)
      if(.not.loexist) then
      write(*,*) 'specified spectrum file does not exist!'
      stop
      end if

c     open the FITS file
      open (unit=nn,file=fname,action='READ',
     & recordtype='STREAM',blocksize=2880,form='BINARY',
     & convert='BIG_ENDIAN')

c     listing-up header data

      ifhend=0
      ihl=0
      do ib=1,9999
        read(nn) line
        do k=1,36
          ihl=ihl+1
          head(ihl)=line(k)
c          write(*,'(a)') head(ihl)
          if(head(ihl)(1:3).eq.'END') ifhend=1 
        end do
        if(ifhend.eq.1) go to 99
      end do
      write(*,*) 'Too many header lines >9999'
      stop
   99 continue
      nhl=ihl

C     determine the size of the image and the format type
      isimple=0
      ibitpix=0
      inaxis=0
      inaxis1=0
      inaxix2=0
      ictype1=0
      do k=1,nhl
        if(index(head(k),'SIMPLE  ').gt.0) isimple=k
        if(index(head(k),'BITPIX  ').gt.0) ibitpix=k
        if(index(head(k),'NAXIS   ').gt.0) inaxis=k
        if(index(head(k),'NAXIS1  ').gt.0) inaxis1=k
        if(index(head(k),'NAXIS2  ').gt.0) inaxis2=k
        if(index(head(k),'CTYPE1  ').gt.0) ictype1=k
      end do

      do n=10,80
        if(head(isimple)(n:n).ne.' ') go to 12
      end do
      n=80
   12 iqq=n
      if(head(isimple)(iqq:iqq).ne.'T') then
        write(*,*) 
     &  'Only normal SIMPLE=T  FITS file is accepted...'
        write(*,'(a)') trim(head(isimple))
        stop
      end if

      read(head(ibitpix)(10:),*) nbitpix       
      if(abs(nbitpix).eq.32) then
        nword=20*36
      else
        write(*,*) 'This version supports only |BITPIX|=32'
        write(*,*) 'and does not support BITPIX --> ',nbitpix
        stop
      end if

      read(head(inaxis)(10:),*) ndim
      read(head(inaxis1)(10:),*) naxes(1)
      if(ndim.ge.2) then
        read(head(inaxis2)(10:),*) naxes(2)
      else
        naxes(2)=0
      end if
      read(head(ictype1)(10:),*) ctype1

c      write(*,*) 'ndim    =',ndim
c      write(*,*) 'naxes(1)=',naxes(1)
c      write(*,*) 'naxes(2)=',naxes(2)
c      write(*,'(''CTYPE1:'',a8)') ctype1

      if(naxes(1).gt.md*99) then
        write(*,*) 'naxes(1) > md*99 !'
        stop
      end if
      if(naxes(2).gt.99) then
        write(*,*) 'naxes(1) > 99 !'
        stop
      end if


c     check dispersion-related parameters

      iwcsdim=0
      iltm1_1=0
      iltv1=0
      iwaxmap01=0
      do k=1,nhl
        if(index(head(k),'WCSDIM  ').gt.0) iwcsdim=k
        if(index(head(k),'LTM1_1  ').gt.0) iltm1_1=k
        if(index(head(k),'LTV1    ').gt.0) iltv1=k
        if(index(head(k),'WAXMAP01').gt.0) iwaxmap01=k
      end do

      if(iwcsdim.gt.0) then
        read(head(iwcsdim)(10:),*) nwcsdim
      else
        nwcsdim=ndim
      end if

      if(iltv1.gt.0) then
        read(head(iltv1)(10:),*) ltv1
      else
        ltv1=0.
      end if

      if(iltm1_1.gt.0) then
        read(head(iltm1_1)(10:),*) ltm1_1
      else
        ltm1_1=1.
      end if

      if(iwaxmap01.gt.0) then
        read(head(iwaxmap01)(10:),*) waxmap01
      else
        waxmap01=''
      end if

c      write(*,'(''WCSDIM  :'',i4)') nwcsdim
c      write(*,'(''LTV1    :'',f8.5)') ltv1
c      write(*,'(''LTM1_1  :'',f8.5)') ltm1_1
c      write(*,'(''WAXMAP01:'',(a))') trim(waxmap01)


cc


      if(ctype1.eq.'MULTISPE') go to 1001

c     non-MULTISPEC case (e.g.,LINEAR dispersion)

      icrval1=0
      icrpix1=0
      icdelt1=0
      icd1_1=0
      idcflag=0
      do k=1,nhl
        if(index(head(k),'CRVAL1').gt.0) icrval1=k
        if(index(head(k),'CRPIX1').gt.0) icrpix1=k
        if(index(head(k),'CDELT1').gt.0) icdelt1=k
        if(index(head(k),'CD1_1').gt.0) icd1_1=k
        if(index(head(k),'DC-FLAG').gt.0) idcflag=k
      end do
      if(icrval1*icrpix1.eq.0) then
        write(*,*) 'Either CRVAL1 or CRPIX1 not found'
        write(*,*) 'despite the non-MULTISPEC (single spectrum) mode...'
        write(*,*) 'stopped!'
      stop
      end if

      if(icdelt1.eq.0.and.icd1_1.eq.0) then
        write(*,*) 'Both CDELT1 and CD1_1 not found'
        write(*,*) 'despite the non-MULTISPEC (single spectrum) mode...'
        write(*,*) 'stopped!'
      stop
      end if      

      read(head(icrval1)(10:80),*) crval1
      read(head(icrpix1)(10:80),*) crpix1
      if(icdelt1.ne.0) read(head(icdelt1)(10:80),*) cdelt1
      if(icd1_1.ne.0)  read(head(icd1_1)(10:80),*) cd1_1
      if(icd1_1.eq.0) cd1_1=cdelt1

      if(idcflag.gt.0) then
        read(head(idcflag)(10:),*) jdcflag
      else
        jdcflag=0
      end if

c      write(*,'(''CRVAL1:'',f8.2)') crval1
c      write(*,'(''CRPIX1:'',f8.2)') crpix1
c      write(*,'(''CDELT1:'',f8.5)') cdelt1
c      write(*,'(''CD1_1 :'',f8.5)') cd1_1
c      write(*,'(''DC-FLAG  :'',i5)') jdcflag

      npoint=naxes(1)
      allocate(wla(npoint))
      allocate(spec(npoint))
      
      do l=1,npoint
        wla(l)=crval1+cd1_1*(l-crpix1)
        if(jdcflag.eq.1) wla(l)=exp10(wla(l))
      end do
      npt=npoint
      go to 1003

 1001 continue
ccc   MULTISPE

      ifdash=0
      ifinv=0

      do 450 i=1,999
        if(i.le.9) then
        fmt='(''WAT2_00'',i1)'
        else if (i.le.99) then
        fmt='(''WAT2_0'',i2)'
        else if (i.le.999) then
        fmt='(''WAT2_'',i3)'
        end if
        write(word8,fmt) i
        do 451 k=1,nhl
        if(index(head(k),word8).gt.0) go to 456
  451   continue
        go to 459
  456   segment(i)=head(k)(12:79)
        call lablen(segment(i),80,ns(i),ne(i))
        if(segment(i)(1:1).eq.' ') ns(i)=ns(i)-1
        if(segment(i)(68:68).eq.' ') ne(i)=ne(i)+1
  450 continue
  459 numstr=i-1

      do 8000 j=1,99
      ipos=j
      ic=0
      do i=1,numstr
        do 43 n=ns(i),ne(i)
        if(segment(i)(n:n).ne.'"') go to 43
        ic=ic+1
        if(ic.eq.2*ipos-1) then
          ii1=i
          n1=n
        end if
        if(ic.eq.2*ipos) then
          ii2=i
          n2=n
        go to 44
        end if
   43   continue
      end do
   44 continue
      iii=ii2-ii1+1
      if(iii.gt.99) then
      write(*,*)'Too long WAT2 label at an order (> 99 lines!)-->', iii
      stop
      end if
      if(iii.eq.1) then
        string=segment(ii1)(n1:n2)
      else if (iii.eq.2) then
        string=segment(ii1)(n1:ne(ii1))//segment(ii2)(ns(ii2):n2)
      else if (iii.ge.3) then
        string=segment(ii1)(n1:ne(ii1))
        nnn=ne(ii1)-n1+1
        do iix=ii1+1,ii2-1
          string=string(1:nnn)//segment(iix)(ns(iix):ne(iix))
          nnn=nnn+ne(iix)-ns(iix)+1
        end do
        string=string(1:nnn)//segment(ii2)(ns(ii2):n2)
      end if
      call lablen(string,2048,nt1,nt2)
c      write(*,*) 'nt1,nt2 ',nt1,nt2
c      write(*,'(a)') '|'//string(nt1:nt2)//'|'
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     & npdum,voc,apb1,apb2
c
      iordp=iord
c#    special treatment for HDS header with dash
      if(j.eq.1.and.iord.eq.iduma) then
        iordabs1=iord
        ifdash=1
      end if
      if(ifdash.eq.1)iordp=iord-iordabs1+1
c#
c%    inverse order case (e.g., old Xinglong CES spectrum)
      if(j.eq.1.and.iord.ne.1.and.iord.eq.naxes(2)) then
        ifinv=1
        iordmax=iord
      end if
      if(ifinv.eq.1) iordp=iordmax-iord+1
c%
c----------------------------------------------------------------------
      if(idumb.eq.0.or.idumb.eq.1) then
        go to 801
      else if (idumb.eq.2) then
        go to 802
      else
        write(*,*) 'Why not idumb=0 or 1 or 2 ?! idumb--> ',idumb
        stop
      end if
  801 continue
c     idumb=0 (for the linear case) or idumb=1 (for the log-linear case)

c      write(*,'(''CRVAL1:'',f8.2)') crval1
c      write(*,'(''CDELT1:'',f8.5)') cdelt1
      w0=crval1
      dw=cdelt1
      nump(j)=naxes(1)
      if(idumb.eq.0) then
c     linear (idumb=0)
        do k=1,nump(j)
          wlmul(k,j)=(w0+(k-1)*dw)/(1.+voc)
        end do
      else
c     log-linear (idumb=1)
        do k=1,nump(j)
          wlmul(k,j)=exp10((w0+(k-1)*dw))/(1.+voc)
        end do
      end if
c      write(*,*) j,nump(j),wlmul(1,j),wlmul(nump(j),j)
      go to 7777
  802 continue
c     idumb=2 (for the non-linear dispersion case )
        read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     &  npdum,voc,apb1,apb2,wt,offset,iftype
      
      nump(j)=naxes(1)
c
      if(iftype.eq.1) then
        go to 701
      else if (iftype.eq.2) then
        go to 702
      else if (iftype.eq.3) then
        go to 703
      else if (iftype.eq.4) then
        go to 704
cc      else if (iftype.eq.5) then
cc        go to 705
cc      else if (iftype.eq.6) then
cc        go to 706
      else
        write(*,*) 
     &  'fitsread in this version does not support iftype -->',iftype
        stop
      end if

c==== chebyshev case
  701 continue
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     &  npdum,voc,apb1,apb2,wt,offset,iftype,nodr,pmin,pmax,
     & (coef(l),l=1,nodr)
      do 171 k=1,nump(j)
      p=(k-ltv1)/ltm1_1
      en=(p-(pmax+pmin)/2.)/((pmax-pmin)/2.)
      x(1)=1.
      x(2)=en
      do l=3,nodr
      x(l)=2.*en*x(l-1)-x(l-2)
      end do
      alamda=0.
      do l=1,nodr
        alamda=alamda+coef(l)*x(l)
      end do
       wlmul(k,j)=wt*(offset+alamda)/(1.+voc)
  171 continue
      go to 7777

c==== legendre case
  702 continue
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     &  npdum,voc,apb1,apb2,wt,offset,iftype,nodr,pmin,pmax,
     & (coef(l),l=1,nodr)
      do 172 k=1,nump(j)
      p=(k-ltv1)/ltm1_1
      en=(p-(pmax+pmin)/2.)/((pmax-pmin)/2.)
      x(1)=1.
      x(2)=en
      do l=3,nodr
      x(l)=((2*float(l)-3.)*en*x(l-1)-float(l-2)*x(l-2))/float(l-1)
      end do
      alamda=0.
      do l=1,nodr
        alamda=alamda+coef(l)*x(l)
      end do
       wlmul(k,j)=wt*(offset+alamda)/(1.+voc)
  172 continue
      go to 7777

c==== linear spline case
  703 continue
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     &  npdum,voc,apb1,apb2,wt,offset,iftype,npiece,pmin,pmax,
     & (coef(l),l=1,npiece+1)
      do 173 k=1,nump(j)
      p=(k-ltv1)/ltm1_1
      es=(p-pmin)/(pmax-pmin)*float(npiece)
      jj=int(es)
      aa=(jj+1)-es
      bb=es-jj
      x0=aa
      x1=bb
      alamda=coef(0+jj)*x0+coef(1+jj)*x1
      wlmul(k,j)=wt*(offset+alamda)/(1.+voc)
  173 continue
      go to 7777

c==== cubic spline case
  704 continue
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     &  npdum,voc,apb1,apb2,wt,offset,iftype,npiece,pmin,pmax,
     & (coef(l),l=1,npiece+3)
      do 174 k=1,nump(j)
      p=(k-ltv1)/ltm1_1
      es=(p-pmin)/(pmax-pmin)*float(npiece)
      jj=int(es)
      aa=(jj+1)-es
      bb=es-jj
      x0=aa**3
      x1=1.+3.*aa*(1.+aa*bb)
      x2=1.+3.*bb*(1.+aa*bb)
      x3=bb**3
      alamda=coef(0+jj)*x0+coef(1+jj)*x1+coef(2+jj)*x2+coef(3+jj)*x3
      wlmul(k,j)=wt*(offset+alamda)/(1.+voc)
  174 continue
      go to 7777

cc==== pixel aray case
c  705 continue
c      go to 7777
cc==== sampled array case
c  706 continue
c      go to 7777

c----------------------------------------------------------------------
 7777 continue
      if(iordp.ne.ipos) go to 8001
 8000 continue
 8001 numord=ipos-1

c     check for the 1D case with reduced dimentionality 
      if(nwcsdim.gt.ndim.and.ndim.eq.1) then
        if(iwaxmap01.eq.0) then
          write(*,*) 'why not exist WAXMAP01 despite wcsdim > ndim?!',
     &    nwcsdim,ndim
          stop
        end if 
        read(waxmap01,*) (npln(m),noff(m),m=1,nwcsdim)
        do m=1,nwcsdim
          if(npln(m).eq.0) go to 876
        end do
  876   jsel=noff(m)+1
        npoint=nump(jsel)
        allocate(wla(npoint))
        allocate(spec(npoint))
        do ip=1,npoint
          wla(ip)=wlmul(ip,jsel)
        end do
        npt=npoint
        go to 1003
      end if

c
c     for normal multispec case (anyway allocating wla & spec)
      npoint=naxes(1)
      allocate(wla(npoint))
      allocate(spec(npoint))
      npt=npoint
      go to 1003

 1003 continue

C     counting total number of data
      if(ndim.eq.1) then 
        npixels=naxes(1)
      else 
        npixels=naxes(1)*naxes(2)
      end if
c      write(*,*) 'npixels=',npixels

      nremain=npixels
      nsum=0
      do l=1,9999
        if(nremain.lt.nword) then
          nmax=mod(nremain,nword)
          read(nn,end=699) (val(n),n=1,nmax)
        else
          nmax=nword
          read(nn,end=699) (val(n),n=1,nmax)
        end if
        do n=1,nmax
          buffer(nsum+n)=val(n)
        end do
        nsum=nsum+nmax
        nremain=nremain-nmax
        if(nremain.le.0) go to 699
      end do
  699 continue


      if(ndim.eq.1) then
c     for one-D spec
        do k=1,npt
          spec(k)=buffer(k)
        end do
c       re-ordering if necessary (increasing order of wavelength)
        if(wla(1).gt.wla(npt)) then
          allocate(wla_tmp(npt))
          allocate(spec_tmp(npt))
          do k=1,npt
            wla_tmp(k) =wla(npt-k+1)
            spec_tmp(k)=spec(npt-k+1)
          end do
          do k=1,npt
            wla(k) =wla_tmp(k)
            spec(k)=spec_tmp(k)
          end do
          deallocate(wla_tmp)
          deallocate(spec_tmp)
        end if
      else
c     for two-D spec
        do j=1,numord
          nskip=(j-1)*npt
          do k=1,npt
            spmul(k,j)=buffer(nskip+k)
          end do
c       re-ordering if necessary (increasing order of wavelength)
          if(wlmul(1,j).gt.wlmul(nump(j),j)) then
            do n=1,nump(j)
              wlmul_tmp(n)=wlmul(nump(j)-n+1,j)
              spmul_tmp(n)=spmul(nump(j)-n+1,j) 
            end do
            do n=1,nump(j)
              wlmul(n,j)=wlmul_tmp(n)
              spmul(n,j)=spmul_tmp(n) 
            end do
          end if
        end do
      end if

      if(ndim.gt.1) go to 7

c_dummyorder for 1D case
c     setting nordummy and nump
c ......................................................................
c      npx is length of dummy order and nmar is offset correction 
c      Note that npx <= md  and  0 =< nmar <npx should be fulfilled
c      The default value set in window.ini may be npx=md(=9999) and nmar=0
c 
c      first order(j=1)   usual order(j)       last order (j=nordummy)
c beg    1               npx*(j-1)+1-nmar    npx*(nordummy-1)+1-nmar
c end   npx-nmar         npx*(j-1)+npx-nmar  npt
c......................................................................
      if(npt.le.npx) then
        nordummy=1
        nump(1)=npt
      else
        nordummy=npt/(npx-nmar)
        nordummy=nordummy+1
        do j=1,nordummy
          nump(j)=npx
          if(j.eq.nordummy) nump(j)=npt-(npx-nmar)*(nordummy-1)
        end do
      end if
      do j=1,nordummy
      do k=1,nump(j)
      nc=(npx-nmar)*(j-1)+k
      wlmul(k,j)=wla(nc)
      spmul(k,j)=spec(nc)
      end do
      end do
      numord=nordummy
c_dummyorder

    7 continue
C     close the file and free the unit number
      close (nn)
c     Now deallocating wla,spec
      deallocate(wla)
      deallocate(spec)
      return
      end

      subroutine textread(nn,fname,norder)
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      real*8,dimension(:),allocatable :: www,sss,www_tmp,sss_tmp
      character*60 fnamet,fname
      character line*80, ch*1, fmt*80
      dimension wlmul_tmp(md),spmul_tmp(md)
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/dummyorder/npx,nmar
c
      common/convf2t/ifconvf
      dimension nbs(99),nbe(99)

c     Case where obspec file is in text format
      inquire(file=fname,exist=loexist)
      if(.not.loexist) then
      write(*,*) 'specified spectrum file does not exist!'
      stop
      end if
      if(ifconv.eq.1.and.index(fname,'_temporary.txt').gt.0) then
        open (unit=nn,file=fname,disp='delete')
      else
        open (unit=nn,file=fname,action='read')
      end if
c     check if fmt exists at the first line
      rewind nn
      read(nn,'(a)') line
      call lablen(line,80,ns,ne)
      lofmt=.false.
      if(line(ns:ns+4).eq.'%fmt=') then
      lofmt=.true.
      read(line(ns+5:ne),*) fmt
      end if
c
      allocate(www(md*99))
      allocate(sss(md*99))
      rewind nn
      n=0
      do i=1,9999999
        read(nn,'(a)',end=33) line
        do k=1,80
        if(line(k:k).ne.' ') go to 48
        end do
        go to 49
   48   ks=k
        ch=line(ks:ks)
        if(ifnum(ch).eq.1) then
          n=n+1
          if(lofmt) then
            read(line,fmt) www(n),sss(n)
          else
            read(line,*) www(n),sss(n)
          end if
        end if
   49 continue
      end do
   33 continue
c     closing obspec file
      close (nn)

      if(n.eq.0) then
        write(6,*) 'Check the spectrum file!'
        stop
      end if
      nnn=n

cc    dividing into multi-order spectra
      do m=1,99
        nbs(m)=0
        nbe(m)=0
      end do
      mm=1
      nbs(mm)=1
      do n=2,nnn-1
        if(www(n).le.0.) then
          nbe(mm)=n-1
          mm=mm+1
          nbs(mm)=n+1
        end if
      end do
      nbe(mm)=nnn
      mreg=mm

      if(mreg.eq.1) go to 100

c     multi-order spectra (mreg > 1)
      numord=mreg
      do j=1,numord
        nump(j)=nbe(j)-nbs(j)+1
        do k=1,nump(j)
      	  wlmul(k,j)=www(nbs(j)+k-1)
          spmul(k,j)=sss(nbs(j)+k-1)
        end do
c       re-ordering if necessary (increasing order of wavelength)
          if(wlmul(1,j).gt.wlmul(nump(j),j)) then
            do k=1,nump(j)
              wlmul_tmp(k)=wlmul(nump(j)-k+1,j)
              spmul_tmp(k)=spmul(nump(j)-k+1,j) 
            end do
            do k=1,nump(j)
              wlmul(k,j)=wlmul_tmp(k)
              spmul(k,j)=spmul_tmp(k) 
            end do
          end if
      end do
      go to 999

  100 continue
c       re-ordering if necessary (increasing order of wavelength)
        if(www(1).gt.www(nnn)) then
          allocate(www_tmp(nnn))
          allocate(sss_tmp(nnn))
          do n=1,nnn
            www_tmp(n)=www(nnn-n+1)
            sss_tmp(n)=sss(nnn-n+1)
          end do
          do n=1,nnn
            www(n)=www_tmp(n)
            sss(n)=sss_tmp(n)
          end do
          deallocate(www_tmp)
          deallocate(sss_tmp)
        end if
c
c     splitting single spectrum
c     setting nordummy and nump
c ......................................................................
c      npx is length of dummy order and nmar is offset correction 
c      Note that npx <= md  and  0 =< nmar <npx should be fulfilled
c      The default value set in window.ini may be npx=md(=9999) and nmar=0
c 
c      first order(j=1)   usual order(j)       last order (j=nordummy)
c beg    1               npx*(j-1)+1-nmar    npx*(nordummy-1)+1-nmar
c end   npx-nmar         npx*(j-1)+npx-nmar  npt
c......................................................................

      npt=nnn
      if(npt.le.npx) then
        nordummy=1
        nump(1)=npt
      else
        nordummy=npt/(npx-nmar)
        nordummy=nordummy+1
        do j=1,nordummy
          nump(j)=npx
          if(j.eq.nordummy) nump(j)=npt-(npx-nmar)*(nordummy-1)
        end do
      end if
      do j=1,nordummy
      do k=1,nump(j)
      nc=(npx-nmar)*(j-1)+k
      wlmul(k,j)=www(nc)
      spmul(k,j)=sss(nc)
      end do
      end do
      numord=nordummy

  999 continue

      deallocate(www)
      deallocate(sss)

      return
      end


      subroutine sunspset
      use dfport
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      parameter (MREF=120000)
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/refspec/nr,wrf1,wrf2,dwrf,xr(MREF),yr(MREF)
      dimension wb(11)
      data wb/3000.,4000.,5000.,6000.,7000.,8000.,9000.,10000.,
     & 11000., 12000., 13000./
      character*80 labdir
      character*6 head(10)
      data head/'sun035','sun045','sun055','sun065','sun075',
     & 'sun085','sun095','sun105','sun115','sun125'/
c      data dw/0.02/
      data dw/0.05/
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      dimension ncount(MREF)

c     Initializing xr and yr
      do l=1,MREF
        xr(l)=0.
        yr(l)=0.
      end do

        wmin=min(wlmul(1,1),wlmul(1,numord))
        wmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
c
c      wmin=xmin
c      wmax=xmax
c
      wmin=max(3000.,wmin)
      wmax=min(13000.,wmax)

      wmin=int(wmin)
      wmax=int(wmax+0.5)

      nwp=int((wmax-wmin)/dw+1.5)
      if(nwp.gt.MREF) then
        nwp=MREF
        wmax=wmin+dw*(MREF-1)
      end if      
      do l=1,nwp
        xr(l)=wmin+dw*(l-1)
      end do

      do 1 i=1,10
      if(wmin.ge.wb(i).and.wmin.le.wb(i+1)) then
      imin=i
      go to 10
      end if
    1 continue
   10 continue
      do 2 i=1,10
      if(wmax.ge.wb(i).and.wmax.le.wb(i+1)) then
      imax=i
      go to 20
      end if
    2 continue
   20 continue
      call retenv("SFX_DIR",labdir)
      call lablen(labdir,80,nsdir,nedir)

      do l=1,MREF
        ncount(l)=0
      end do

      do 100 i=imin,imax
      open (unit=81,file=labdir(nsdir:nedir)//'\'//head(i)//'w10.dat',
     & form='formatted')
      rewind 81
      do 150 k=1,999999
      read(81,*,end=99) wdum,fdum
      if(wdum.lt.wmin) go to 150
      if(wdum.gt.wmax) go to 999
      lc=int((wdum-wmin)/dw+1.5)
      if(lc.ge.MREF) then
        close (81)
        go to 999
      end if
      yr(lc)=yr(lc)+fdum
      ncount(lc)=ncount(lc)+1
  150 continue
   99 continue
      close (81)
  100 continue
  999 continue
      do l=1,nwp
        if(ncount(l).gt.0) then
          yr(l)=yr(l)/float(ncount(l))
        else
          yr(l)=1.
        end if
      end do
      nr=nwp
      return
      end

      subroutine sunidset
      use dfport
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      parameter (MAXIDE=100000)
      common/ident/nide,lnident(MAXIDE)
      character*66 lnident
      character*1 cdum
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      dimension wb(11)
      data wb/3000.,4000.,5000.,6000.,7000.,8000.,9000.,10000.,
     & 11000.,12000.,13000./
      character*80 labdir,line80
      character*8 head(10)
      data head/'03000400','04000500','05000600','06000700',
     & '07000800','08000900','09001000','10001100','11001200',
     & '12001300'/
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      wmin=min(wlmul(1,1),wlmul(1,numord))
      wmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
c      wmin=xmin
c      wmax=xmax
      wmin=max(3000.,wmin)
      wmax=min(13000.,wmax)
      do 1 i=1,10
      if(wmin.ge.wb(i).and.wmin.le.wb(i+1)) then
      imin=i
      go to 10
      end if
    1 continue
   10 continue
      do 2 i=1,10
      if(wmax.ge.wb(i).and.wmax.le.wb(i+1)) then
      imax=i
      go to 20
      end if
    2 continue
   20 continue
      call retenv("SFX_DIR",labdir)
      call lablen(labdir,80,nsdir,nedir)
      ni=0
      do 100 i=imin,imax
      open (unit=81,file=labdir(nsdir:nedir)//'\id'//head(i)//'.dat',
     & form='formatted')
      rewind 81
      do 150 j=1,999999
      read(81,'(a)',end=99) line80
            do k=1,80
              if(line80(k:k).ne.' ') go to 2048
            end do
            cycle
 2048       ks=k
            cdum=line80(ks:ks)
      if(cdum.eq.'#') go to 150
      read(line80,'(3x,f9.3)') wdum
      if(wdum.lt.wmin) go to 150
      if(wdum.gt.wmax) go to 999
      ni=ni+1
      lnident(ni)=line80(1:66)
      if(ni.ge.MAXIDE) then
        close (81)
        go to 999
      end if
  150 continue
   99 continue
      close (81)
  100 continue
  999 continue
      nide=ni
      return
      end

      subroutine range(x,n,xmin,xmax,n1,n2)
      implicit real*8 (a-h,o-z)
      dimension x(n)
      if(n.lt.0) then
        n1=0
        n2=0
        return
      end if
      do m=1,n
      if(x(m).ge.xmin) go to 10
      end do
   10 n1=m
      do m=n,1,-1
      if(x(m).le.xmax) go to 20
      end do
   20 n2=m
c      if(n1.ge.n2) then
c      write(6,*) 'check the range!'
c      stop
c      end if
      return
      end
      subroutine wsearch(twla1,twla2)
      implicit real*8 (a-h,o-z)
      COMMON/FNAMES/FNMODEL,FNLINES,FNOBSPEC
      character*60 fnmodel,FNLINES,FNOBSPEC
      character*120 line120
      open (unit=9,file=fnlines)
      rewind 9
      twla1=+9.99d99
      twla2=-9.99d99
      do while (1)
      read(9,'(a)',end=999) line120
      call lablen(line120,120,nsln,neln)
      if(ifnum(line120(nsln:nsln)).eq.0) cycle
      read(line120,*) cdum,wla
      if(wla.gt.twla2) twla2=wla
      if(wla.lt.twla1) twla1=wla
      end do
  999 continue
      close (9)
      return
      end
      subroutine chngparm(irt)
      use dflib
      use dfport
      PARAMETER(KPNT=100001)
      parameter (md=9999)
      parameter (mdq=1000)
      parameter (MREF=120000)
      parameter (MAXIDE=100000)
      implicit real*8 (a-h,o-z)
      type (windowconfig) myscreen
      character*16 fontstd,fontide
      integer*4 backcolor,forecolor,textcolor,spobcolor,spthcolor,
     &spidcolor,sprecolor,spadcolor
      common/grwinset/myscreen,fontstd,fontide,
     &backcolor,forecolor,textcolor,spobcolor,spthcolor,spidcolor,
     &sprecolor,spadcolor(3)
      common/frameset/ngtx,ngty,xlmargin,xrmargin,ytmargin,ydmargin,
     &ltickp,xlabel,ylabel
      common/labtit/labthe,labobs,lablin
      character*60 labthe,labobs,lablin
      common/passxyth/n1,n2,xth(kpnt),yth(kpnt)
      common/spec/nd,xs(md),ys(md)
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/svxymm0/xmin0,xmax0,ymin0,ymax0,dshft0,vw0,threseta0,rp0
      common/mask/fz,yshift,imk,wms(99),wme(99)
      COMMON /XABUND/XABUND(99),WTMOLE
      COMMON/FNAMES/FNMODEL,FNLINES,FNOBSPEC
      character*60 fnmodel,FNLINES,FNOBSPEC
      character*60 fname,linetmp
      character*68 comment
      character*40 com40
      character*1 ch,cdum
      common/ident/nide,lnident(MAXIDE)
      character*66 lnident
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      integer*4 mouseevent,keystate,mx,my,result
      integer*4 lol,lor,los,loc
      logical loexist
      integer*2 ic
      dimension iz(10),lznum(-68:99),etama(-68:99)
c
      logical LOREFR
      character*60 fnrefspec,labref
      common/refspec/nr,wrf1,wrf2,dwrf,xr(MREF),yr(MREF)
      common/reflab/LOREFR,fnrefspec,labref
c
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)
      COMMON /JUNK/TITLE(74),FREQID(6),WLTE,XSCALE
      COMMON /TEFF/TEFF,GRAV,GLOG
      COMMON/LCALDATA/XI,STWV,ENWV,NPOINT,NCON,NVAR,NCODE(99),DEPSL(99)
      COMMON/SYNPROF/WLTH(KPNT),AINT(KPNT),RESIDF(KPNT),ABSF(KPNT)
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL
      character*2 elem
      character*40 idlabel,idlabel_def
      logical*4 lores,loopen,lowaitid,lowaitmk,lowaitxx
      data nspec/1/
      common/tysave/nspec,ythsv(kpnt,5),xthsv(kpnt,5),npsv(5)
      common/xabzero/xabund0(99)
      common/ewcalc/ewxbeg,ewxend
      dimension iza(8),wvtemp(kpnt),sptemp(kpnt,0:5),izsel(99)
      character*2 elm,che
      dimension cm(68)
      data cm/
     a 100.00,101.00,101.01,106.00,106.01,107.00,108.00,108.01,
     b 109.00,112.00,113.00,114.00,114.01,116.00,117.00,600.00,
     c 606.00,607.00,607.01,608.00,613.00,614.00,616.00,707.00,
     d 707.01,708.00,708.01,712.00,713.00,714.00,716.00,800.00,
     e 808.00,808.01,812.00,813.00,814.00,816.00,820.00,822.00,
     f 826.00,900.00,1216.00,1300.00,1316.00,1416.00,1600.00,1616.00,
     g 1620.00,1626.00,1700.00,2600.00,10100.00,10106.00,10107.00,
     h 10108.00,10116.00,10606.00,10607.00,10608.00,10708.00,
     i 10800.00,10808.00,60600.00,60700.00,60808.00,70700.00,
     j 80800.00/
      character*80 linedir,line80,datdir
      common/dirpath/nsdir,nedir,linedir
      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      character*72 cpanelgo
      common/cppass/nscp,necp,cpanelgo
      character*1 cg
      dimension vtsel(21)
      character fmtx*5,fmty*5,fmtot*30
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
c
      character fntemp*60, ch2*2
      common/batch/fndb_def,
     & fndb,spandb,idb,ndb,last,isv(999),wlamdb(999),labdb(999)
      character fndb_def*60,fndb*60,labdb*80
c
      common/ewdbout/dwcrt,loewout,fnewout
      character*60 fnewout
      logical loewout
      dimension xstemp(md)
c
      common/epspass/ep,nlimda,wlalimda(2000),epslimda(2000)
c
      common/tilt/tilta
      dimension ysorg(md)

      common/bisector/ifbisec
c
      dimension numser(999)
      character*60 fnmultobs,tfnolist,fnolist(999)
      common/nspass/nspecify,ifmultobs,imfcur,nmfile,numser,
     & fnmultobs,fnolist
      character*3 labchar3
      dimension xbas(md),ysmap(md),ythmap(md)
      dimension xttt(md),yttt(md),xuuu(md),yuuu(md)

      common/dopcorrect/dopcor,dopref,dcfac,drfac
      character*60 fnobspec_org
      common/fnorgpass/fnobspec_org
      common/xyvpass/xv,yv
      common/ewprm/dwsp_n,dwsp,ngeta
      common/iabsfchk/iabsfirst,ymaxkeep,yminkeep
c_bbb
      common/auto/ifauto,iapdum,ifn
      data initau/0/
c_fff
      common/ymgpass/ryymg
      common/unfocus/ifunplot
      common/ifrefvlink/ifrefvlink
      common/grparams/ek,adamp,area
      common/crit_eta/etacrt
      common/idfile/fnlineid
      character*60 fnlineid
      common/fluxmode/ifabs
      character*60 fnback1,fnback2
      character*5 labreg
      character*12 labchar12
      character*8 labdc
c
      character fchar(12)*1,fkey(12)*3
      data fchar/'','','','','','','','','','','',''/
      data fkey/'F1 ','F2 ','F3 ','F4 ','F5 ','F6 ',
     &          'F7 ','F8 ','F9 ','F10','F11','F12'/
      data iffk/0/
      if(iffk.eq.1) go to 2229
c
c     Now reading information for customizing F1-F12 function keys 
c     from the data file of %SPTOOL%\miscdata\funckey.dat
c
      call retenv("DAT_DIR",datdir)
      call lablen(datdir,80,nsdir,nedir)
      inquire(file=datdir(nsdir:nedir)//'\funckey.dat', exist=loexist)
      if(.not.loexist) go to 2229 
      open (unit=82,file=datdir(nsdir:nedir)//'\funckey.dat',
     & form='formatted')
      do 2206 n=1,999
        read(82,'(a)',end=2220) linetmp
        if(linetmp(1:1).eq.'!') go to 2206
        do 2205 l=1,12
          if(index(linetmp,fkey(l)).gt.0) then 
            read(linetmp,*) fchar(l)
            go to 2206
          end if
 2205   continue
 2206 continue
 2220 continue
      close (82)
      iffk=1
 2229 continue

      result = passdirkeysqq(.true.)
c
        inextsp=0
        irt=1
    1   continue

c_bbb
      if(ifauto.eq.1) then
        if(idb.le.0) then
          ifauto=0
          go to 1
        end if
      ifauto=2
      ic=92
      go to 1111
      end if
c_fff
        write(*,'('' ? '',$)')
        ch=getcharqq()
        if(ichar(ch).eq.224) then
          ch=getcharqq()
          if(ch.eq.'M') then 
            ch=')'
          else if(ch.eq.'K') then
            ch='('
          else if(ch.eq.'H') then
            ch='u'
          else if(ch.eq.'P') then
            ch='z'
          else if(ch.eq.'I') then
            ch='U'
          else if(ch.eq.'Q') then
            ch='Z'
          else
            go to 1
          end if
        end if

        if(ichar(ch).eq.0.and.iffk.eq.1) then
          ch=getcharqq()
          do l=1,10
            if(ichar(ch).eq.59+l-1) then
              ch=fchar(l)
              go to 223
            end if
          end do
          if(ichar(ch).eq.133) then
            ch=fchar(11)
            go to 223
          end if
          if(ichar(ch).eq.134) then
            ch=fchar(12)
            go to 223
          end if
        go to 1
        end if
  223   continue
        ic=ichar(ch)
c        select case(ichar(ch))
c        ic=incharqq()

c_bbb
c       if 'ESC' key is pressed when ndb>0, then ']' followed by mouse+auto mode
        if(ic.eq.27.and.idb.gt.0) then
c          if(ifn.ne.1) then
c          write(*,*)
c     &    '!!! Sorry, this function is only for the -m option mode!!!'
c          write(*,*) 'Press any key to continue...'
c          cdum=getcharqq()
c          return
c          end if
        ifauto=1
        ic=93
        end if
 1111   continue
c_fff

        select case(ic)
        case (ichar('x'))
          write(*,'(a)') ch
          write(*,'(''xmin,xmax (x-range set) --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) xmin,xmax
          if(xmin.gt.xmax) then
            txdum=xmin
            xmin=xmax
            xmax=txdum
          end if
          call bestsel(xmin,xmax)
        case (ichar('X'))
          write(*,'(a)') ch
          xmax=xs(nd)*dcfac-dshft
          xmin=xs(1)*dcfac-dshft
          call bestsel(xmin,xmax)
        case (ichar('-'))
          write(*,'(a)') ch
          write(*,*) 'Exiting batch mode... idb is set to 0'
          idb=0
        case (ichar('+'))
          write(*,'(a)') ch
c          if(ifn.ne.1) then
c          write(*,*)
c     &    '!!! Sorry, this function is only for the -m option mode!!!'
c          write(*,*) 'Press any key to continue...'
c          cdum=getcharqq()
c          return
c          end if
          write(*,'(''reserved_line_file[/output_EW_file] --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
c          if(ifok.eq.0) return
          if(ifok.eq.0) then
            fndb=fndb_def
            if(ifmultobs.eq.0) then
c             default in the single-spectrum mode
              call lablen(fnobspec,60,nsobs,neobs)
              ifyen=index(fnobspec,'\',.true.)
              if(ifyen.gt.0) then
                ns_b=ifyen+1
                ns_e=min(ns_b+7,neobs)
              else
                ns_b=nsobs
                ns_e=min(ns_b+7,neobs)
              end if
              fnewout=fnobspec(ns_b:ns_e)//'.wdt'
            else
c             default in the multi-spectrum mode
              call lablen(fnmultobs,60,nsmo,nemo)
              ifat=index(fnmultobs,'@')
              ns_b=ifat+1
              ns_e=min(ns_b+7,nemo)
              fnewout=fnmultobs(ns_b:ns_e)//'.wdt'
            end if
            loewout=.true.
            go to 8702
          end if
          isla=index(linetmp,'/')
          if(isla.gt.1) then
          loewout=.true.
          read(linetmp(1:isla-1),'(a)',err=9) fndb
          read(linetmp(isla+1:60),'(a)',err=9) fnewout
          else if(isla.eq.1) then
          loewout=.true.
          fndb=fndb_def
          read(linetmp(isla+1:60),'(a)',err=9) fnewout
          else
          read(linetmp(1:60),'(a)',err=9) fndb
          loewout=.false.
          end if
 8702     continue
          inquire(file=fndb,exist=loexist)
          if(.not.loexist) go to 9
c      find wrange1 and wrange2
          if(numord.gt.1) then
            wrange1=min(wlmul(1,1),wlmul(1,numord))
            wrange2=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
          else
            wrange1=xs(1)*dcfac
            wrange2=xs(nd)*dcfac
          end if
          if(lolimit) then
c             reset the w-range according to the limits specified by the user
c             (but these user-specified limits are ignored if they correspond
c             to outside of the available spectral range)
c            wrange1=wmne
c            wrange2=wmxe
              wrange1=max(wmne,wrange1)
              wrange2=min(wmxe,wrange2)
          end if
c      Now reading line data (only those within the spectral range)
          open (unit=59,file=fndb)
          icnt=0
          do i=1,9999
            read(59,'(a)',end=7099) line80
c
c           check if the first-appearing character is numeric
            do 1047 k=1,80
              if(line80(k:k).ne.' ') go to 1048
 1047       continue
            cycle
 1048       ks=k
            if(ifnum(line80(ks:ks)).eq.0) cycle
c
            read(line80,'(6x,f9.3)') wdummy
            if(wdummy.lt.wrange1.or.wdummy.gt.wrange2) cycle
            icnt=icnt+1
            wlamdb(icnt)=wdummy
            labdb(icnt)=line80
          end do
 7099     ndb=icnt
          close (59)
c          write(*,'(''Total number of data --> '',i3)') ndb
c          write(*,'(''Input the data No. to begin with --> '',$)')
c 7090     read(*,*) idbtmp
c          if(idbtmp.lt.1.or.idbtmp.gt.ndb) then
c            write(*,'(''Invalid data number! Try again!'')')
c            go to 7090
c          end if
c          idb=idbtmp
c          write(*,'(''Enter batch mode with the data No. '',i3)'),idb
          if(ndb.eq.0) then
            write(*,*) 'We can not find any corresponding lines!'
            idb=0
          else
            idb=1
            spandb1=spandb
            if(spandb.lt.0) spandb1=abs(spandb)*(wlamdb(idb)/5000.)
            xmin=wlamdb(idb)-0.5*spandb1
            xmax=wlamdb(idb)+0.5*spandb1
            call bestsel(xmin,xmax)
            last=0
          end if

        case (ichar(']'))
          write(*,'(a)') ch
          if(idb.eq.0) return
c_bbb
c         only for the first calling
          if(initau.eq.0.and.ifauto.eq.1) then
          idb=idb-1
          initau=initau+1
          end if
c
          if(iapdum.eq.1) then
          iapdum=0
          go to 4411
          end if
c_fff
          idb=idb+1
c          idb=min(idb,ndb)
          if(idb.gt.ndb) then
            if(ifmultobs.eq.1) then
             write(*,*) 'Measurement of current spectrum has ended...'
             idb=1
             ic=ichar('n')
             inextsp=9
             go to 1111
            end if
            write(*,*) 'Exiting batch mode... idb is set to 0'
            idb=0
            go to 4411
          end if
          spandb1=spandb
          if(spandb.lt.0) spandb1=abs(spandb)*(wlamdb(idb)/5000.)
          xmin=wlamdb(idb)-0.5*spandb1
          xmax=wlamdb(idb)+0.5*spandb1
          call bestsel(xmin,xmax)
c
c         specify x-range [-30km/s,+30km/s] (to determine y-range for display)
          xxxmin=wlamdb(idb)-wlamdb(idb)*(30./2.997925e5)
          xxxmax=wlamdb(idb)+wlamdb(idb)*(30./2.997925e5)
c
c         sum=0.
          ty1=1.e30
          ty2=-1.e30
          do iv=1,novtot
          	do n=1,nump(novis(iv))
          		xstemp(n)=wlmul(n,novis(iv))*dcfac-dshft
          	end do
c          	call range(xstemp,nump(novis(iv)),xmin,xmax,n1,n2)
          	call range(xstemp,nump(novis(iv)),xxxmin,xxxmax,n1,n2)
          	do k=n1,n2
          	  if(spmul(k,novis(iv)).lt.ty1) ty1=spmul(k,novis(iv))
          	  if(spmul(k,novis(iv)).gt.ty2) ty2=spmul(k,novis(iv))
c         	  sum=sum+spmul(k,novis(iv))
          	end do
          end do
c         yaver=sum/max(1,n2-n1+1)
c          ymin=max(0.,ty1/ymaxstd)
c          ymax=ty2*ymaxstd
          yymg=(ty2-ty1)*ryymg
          ymin=max(0.,ty1-yymg)
          ymax=min(ty2+yymg,ymaxstd)
          if(ymin.ge.ymax) then
          ymin=0.
          ymax=ymaxstd
          end if
c_bbb
 4411     continue
c_fff

        case (ichar('['))
          write(*,'(a)') ch
          if(idb.eq.0) return
          idb=idb-1
c          idb=max(idb,1)
          if(idb.le.0) idb=ndb
          spandb1=spandb
          if(spandb.lt.0) spandb1=abs(spandb)*(wlamdb(idb)/5000.)
          xmin=wlamdb(idb)-0.5*spandb1
          xmax=wlamdb(idb)+0.5*spandb1
          call bestsel(xmin,xmax)
c         sum=0.
          ty1=1.e30
          ty2=-1.e30
          do iv=1,novtot
          	do n=1,nump(novis(iv))
          		xstemp(n)=wlmul(n,novis(iv))*dcfac-dshft
          	end do
          	call range(xstemp,nump(novis(iv)),xmin,xmax,n1,n2)
          	do k=n1,n2
          	  if(spmul(k,novis(iv)).lt.ty1) ty1=spmul(k,novis(iv))
          	  if(spmul(k,novis(iv)).gt.ty2) ty2=spmul(k,novis(iv))
c         	  sum=sum+spmul(k,novis(iv))
          	end do
          end do
c         yaver=sum/max(1,n2-n1+1)
          ymin=max(0.,ty1/ymaxstd)
          ymax=ty2*ymaxstd
          if(ymin.ge.ymax) then
          ymin=0.
          ymax=ymaxstd
          end if

        case (ichar('|'))
          write(*,'(a)') ch
          if(ifbisec.eq.0) then
            ifbisec=1
            write(*,
     &      '(''Entered the EW_prof output mode.(IFBISEC=1)'')')
          else if (ifbisec.eq.1) then
            ifbisec=2
            write(*,
     &      '(''Entered the bisector output mode.(IFBISEC=2)'')')
          else if (ifbisec.eq.2) then
            ifbisec=3
            write(*,
     &      '(''Entered  the bisector + EW_prof mode.(IFBISEC=3)'')')
          else if (ifbisec.eq.3) then
            ifbisec=0
            write(*,
     &      '(''Exited from the bisec/EW prof mode. (IFBISEC=0)'')')
          end if
          write(*,*) 'Press any key to continue...'
          cdum=getcharqq()
        case (ichar('y'))
          write(*,'(a)') ch
          write(*,'(''ymin,ymax (y-range set)--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) ymin,ymax
          if(ymin.gt.ymax) then
            tydum=ymin
            ymin=ymax
            ymax=tydum
          end if

        case (ichar('Y'))
          write(*,'(a)') ch
c         sum=0.
          ty1=1.e30
          ty2=-1.e30
          call range(xs*dcfac-dshft,nd,xmin,xmax,n1,n2)
          do k=n1,n2
          	  if(ys(k).lt.ty1) ty1=ys(k)
          	  if(ys(k).gt.ty2) ty2=ys(k)
c         	  sum=sum+ys(k)
          end do
c         yaver=sum/max(1,n2-n1+1)
          ymin=ty1/ymaxstd
          ymax=ty2*ymaxstd
          if(ymin.ge.ymax) then
          ymin=0.
          ymax=ymaxstd
          end if

c       for the case of BS key (erasing the EW measuremernt just done)
        case (8)
c          write(*,'(a)') ch
          write(*,
     &    '(''Most recently recorded EW data will be deleted...'')')
          write(*,
     &    '(''Press any key to continue (enter "c" to cancel)'')')
          ch=getcharqq()
          if(ch.ne.'C'.and.ch.ne.'c') then
          call eraselast
          last=last-1
          initau=0
          end if
          write(*,'(''Delete cancelled !'')')

        case (ichar('P'))
          write(*,'(a)') ch
          write(*,'(''Current offset value for profile search:'',i3)')
     &    ngeta
          write(*,'(''New offset value ? --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) ngeta

        case (ichar('A'))
          write(*,'(a)') ch
          write(*,'(''Current adamp for profile fitting:'',f7.4)')
     &    adamp
          write(*,'(''New adamp value ? (just Enter to abort)--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) adampdum
          if(adampdum.lt.0..or.adampdum.gt.1.) then
          write(*,*) 'adamp should be within 0<adamp<1: try again!'
          return
          end if
          adamp=adampdum

        case (ichar('K'))
          write(*,'(a)') ch
          write(*,'(''Current k(=vr/vg) for profile fit:'',f5.2)')
     &    ek
          write(*,'(''New k value ? (just Enter to abort)--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) ekdum
          if(ekdum.lt.0..or.ekdum.gt.5.) then
          write(*,*) 'k should be in the range of 0<k<5: try again!'
          return
          end if
          ek=ekdum

        case (ichar('C'))
          write(*,'(a)') ch
          write(*,
     &    '(''Clearing the parameters (k and adamp) for fitting...'')')
          ek=0.
          adamp=0.
          write(*,
     &    '(''We now have k=0 and adamp=0 (pure Gaussian)...'')')
          write(*,*) 'Press any key to continue...'
          cdum=getcharqq()


        case (ichar('w'))
          write(*,'(a)') ch
          write(*,'(''current spandb='',f7.2)') spandb
          write(*,'(''new spandb (x-width of display range) --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) spandb
          xcen=0.5*(xmin+xmax)
          spandb1=spandb
          if(spandb.lt.0) spandb1=abs(spandb)*(xcen/5000.)
          xmin=xcen-0.5*spandb1
          xmax=xcen+0.5*spandb1
          call bestsel(xmin,xmax)

cM        case (ichar('M'))
cM          write(*,'(a)') ch
cM          write(*,'(''current ryymg='',f7.2)') ryymg
cM          write(*,'(''new ryymg (relative y-margin ratio) --> '',$)')
cM          call readline(linetmp,ifok,nsvv,nevv)
cM          if(ifok.eq.0) return
cM          read(linetmp,*,err=9,end=9) ryymg

          
        case (ichar(' '))
          write(*,'(a)') ch
          nofoc=nofoc+1
          do iv=1,novtot
            if(nofoc.eq.novis(iv)) go to 222
          end do
          nofoc=novis(1)
  222     continue

        case (ichar('.'))
          if(ifunplot.eq.1) then
            ifunplot=0
          else
            ifunplot=1
          end if

        case (ichar('`'))
          if(ifrefvlink.eq.0) then
            ifrefvlink=1
            doprefsv=dopref
            drfacsv=drfac
            dopref=dopcor
            drfac=dcfac
          else
            ifrefvlink=0
            dopref=doprefsv
            drfac=drfacsv
          end if

        case (ichar('z'))
          write(*,'(a)') ch
          xcen=0.5*(xmin+xmax)
          cwid=xmax-xmin
          xmin=xcen-cwid/4.
          xmax=xcen+cwid/4.
c          call bestsel(xmin,xmax)
        case (ichar('u'))
          write(*,'(a)') ch
          xcen=0.5*(xmin+xmax)
          cwid=xmax-xmin
          xmin=xcen-cwid
          xmax=xcen+cwid
c          call bestsel(xmin,xmax)
        case (ichar('Z'))
          write(*,'(a)') ch
          dy1=1.-ymin
          ymin=1.-dy1/2.
          dy2=ymax-1.
          ymax=1.+dy2/2.
        case (ichar('U'))
          write(*,'(a)') ch
          dy1=1.-ymin
          ymin=1.-dy1*2.
          dy2=ymax-1.
          ymax=1.+dy2*2.
        case (ichar('c'))
          write(*,'(a)') ch
          write(*,'(''x-centering position --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) tcen
          twh=(xmax-xmin)/2.
          xmin=tcen-twh
          xmax=tcen+twh
          call bestsel(xmin,xmax)
        case (ichar(')'))
          write(*,'(a)') ch
          twid=xmax-xmin
          xmax=xmax+twid*0.1
          xmin=xmin+twid*0.1
          call bestsel(xmin,xmax)
        case (ichar('('))
          write(*,'(a)') ch
          twid=xmax-xmin
          xmax=xmax-twid*0.1
          xmin=xmin-twid*0.1
          call bestsel(xmin,xmax)
        case (ichar('>'))
          write(*,'(a)') ch
          twid=xmax-xmin
          xmax=xmax+twid*1.0
          xmin=xmin+twid*1.0
          call bestsel(xmin,xmax)
        case (ichar('<'))
          write(*,'(a)') ch
          twid=xmax-xmin
          xmax=xmax-twid*1.0
          xmin=xmin-twid*1.0
          call bestsel(xmin,xmax)
        case (ichar('^'))
          write(*,'(a)') ch
          ymax=ymax+0.1
          ymin=ymin+0.1
        case (ichar('v'))
          write(*,'(a)') ch
          ymax=ymax-0.1
          ymin=ymin-0.1
        case (ichar('s'))
          write(*,'(a)') ch
          write(*,
     &    '(''incremental x-shift of observed spectrum --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) shiftzu
          dshft=dshft-shiftzu
        case (ichar('b'))
          write(*,'(a)') ch
c          write(*,'(''broad-HW km/s (>0 tri-HWHM, <0 rotat.) --> '',$)')
          write(*,
     %    '(''broad-HW km/s (>0 gaus-HWEM, <0 rotat) -->    '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) vw
        case (ichar('R'))
          if(ifthex.eq.0) then
c          write(*,
c     &    '('' Sorry, this does not work in non-theoret. mode'')')
c          write(*,'('' Press any key to proceed...'')')
c          cdum=getcharqq()
          return
          end if
          write(*,'(a)') ch
          write(*,
     %'(''Resolving power for blurring (0 for infinity)-->    '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) rpt
          if(rpt.lt.0.) go to 9
          if(rpt.gt.0..and.rpt.lt.1000.) go to 9
          rp=rpt
        case (ichar('e'))
          write(*,'(a)') ch
          write(*,'(''threshold of eta --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) threseta
c        case (ichar('p'))
c          write(*,'(a)') ch
cc          write(*,'(''current parameters:'')')
cc          write(*,'(''xmin (A):'',f8.2)') xmin
cc          write(*,'(''xmax (A):'',f8.2)') xmax
cc          write(*,'(''ymin    :'',f6.3)') ymin
cc          write(*,'(''ymax    :'',f6.3)') ymax
c          write(*,'(''RV shift:'',f6.2,'' A'')') dshft
c          write(*,'(''Rad.Vel.:'',f6.2,''km/s'')')
c     &    dshft/(0.5*(xmin+xmax))*2.997925e5
c          write(*,'(''broad by:'',f6.1,'' km/s'')') vw
c          write(*,'(''eta cut :'',f6.3)') threseta
c          write(*,'(''yshift  :'',f6.3)') yshift
c          write(*,'(''fz      :'',f6.4)') fz
c          irt=0
        case (ichar('G'))
          write(*,'(a)') ch
          if(ifn.eq.1) then
c          write(*,
c     &    '('' Sorry, this does not work in the m-option mode'')')
c          write(*,'('' Press any key to proceed...'')')
c          cdum=getcharqq()
          return
          end if
c
c          write(*,*) 'Going to recalculate spectra with new data input.'
c          write(*,*)'"cpanel.txt" file needs to be updated and save it.'
c
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cscratch first reset ide (in case of simulation mode) for the possibility of 
cscratch next shifting to browsing (i.e., only obsspec) mode
cscratch if(ifthex.eq.1) nide=0
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c
c       updating cpanel.txt...
        open (unit=4,file='cpanel.txt')
        write(4,'(a60,a11)') fnobspec_org,'|(fnobspec)'
        write(4,'(a60,a10)')  fnmodel,'|(fnmodel)'
        write(4,'(a60,a10)')  fnlines,'|(fnlines)'
        write(4,'(i1,59x,''|(ifmole)'')') ifmole
        write(4,'(a)') '#CPANEL@'
        write(4,'(a)') '# << xi/abundance data used for synthesis>>'
        write(4,'(a)') '# (Recommending to change to overwrite mode)'
        write(4,'(a)') '# '
        write(4,'(a)') '# What you can edit is from columns 7 to 12'
        write(4,'(a)') '#                      ~~~~~~~~~~~~~~~~~~~~'
        write(4,'(a)') '# (logarithmic abundance change relative to'
        write(4,'(a)') '# the standard abundance of the model)'
        write(4,'(a)') '# '
        write(4,'(a)') '# Touching other parts is meaningless,'
        write(4,'(a)') '# since they are to be filled by the program'
        write(4,'(a)') '# '
        write(4,'(a)') '#     @@@@@@'
        write(4,'(a)') '# '
        write(4,'(6x,f6.2,f6.1,f8.0,i4,''  ! xi, vw, rp, ifabs'')')
     &  xi,vw,rp,ifabs
c 
c       in case of shifting from ifthex=0 to ifthex=1
c       abundances have to be initialized here
        if(ifthex.eq.0) then
        nvar=99
        do iv=1,nvar
        che=elem(iv)
        ncode(iv)=iv
        depsl(iv)=0.
        write(4,'(a2,i4,f6.2)') che,ncode(iv),depsl(iv)
        end do
        go to 1422
        end if
c        
        do iv=1,nvar
        ela=log10(xabund0(iv)/xabund0(1))+12.
        if(iv.ge.3) then
          els=log10(xabund(iv)/xscale/xabund(1))+12.
        else
          els=log10(xabund(iv)/xabund(1))+12.
        end if
        elx=log10(xabund(iv)/xabund(1))+12.
        write(4,1869) elem(iv),ncode(iv),depsl(iv),ela,elx,xscale,els
 1869   format(a2,i4,f6.2,f8.2,3x,'( mdl:',f6.2,' [xscale=',
     &  f10.5,']  std:',f6.2,' )')
        end do
 1422   continue
        close (4)
c
          nspec=nspec+1
          nspec=min(nspec,5)
          do j=nspec,2,-1
            npsv(j)=npsv(j-1)
            do n=1,npsv(j)
              ythsv(n,j)=ythsv(n,j-1)
              xthsv(n,j)=xthsv(n,j-1)
            end do
          end do
          irt=2
          return

        case (ichar('g'))
          write(*,'(a)') ch
          if(ifn.eq.1.or.ifthex.eq.0) then
c          write(*,
c     &    '('' This does not work in non-the. mode without cpanel'')')
c          write(*,'('' Press any key to proceed...'')')
c          cdum=getcharqq()
          return
          end if
          write(*,*)
     &    '(three modes:  a: absolute, r: relative, i: incremental)'
          write(*,'(''atom-number, value, mode ---> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) izp,tdepsl
          if(izp.eq.1) then
            write(*,*) 'H(iz=1) should not be touched!'
            return
          end if
          cg=linetmp(nevv:nevv)
          if(izp.ge.1.and.(cg.ne.'a'.and.cg.ne.'r'.and.cg.ne.'i')) then
          write(*,'(''Invalid mode characters -->:'',(a))') cg
          return
          end if
          if(izp.le.0) then
            xi=tdepsl
          else
            elstd=log10(xabund(izp)/xabund(1))+12.
            depslc=depsl(izp)
            if(cg.eq.'a') depsl(izp)=tdepsl-elstd
            if(cg.eq.'r') depsl(izp)=tdepsl
            if(cg.eq.'i') depsl(izp)=depslc+tdepsl
          end if
          nspec=nspec+1
          nspec=min(nspec,5)
          do j=nspec,2,-1
c          do n=n1,n2
          npsv(j)=npsv(j-1)
          do n=1,npsv(j)
          xthsv(n,j)=xthsv(n,j-1)
          ythsv(n,j)=ythsv(n,j-1)
          end do
          end do
          ifqcal=1
          irt=2
          return

        case (ichar('q'))
          write(*,'(a)') ch
          write(*,*)  'We are going to quit and end the job ...'
          write(*,*) ' Hit any key to proceed (press "c" to cancel) ...'
          ch=getcharqq()
          if(ch.ne.'c'.and.ch.ne.'C') call exit(0)

        case (ichar('N'))

          write(*,'(a)') ch
          if(ifmultobs.eq.0) then
            ifmultobs=1
            nspecify=-1
            write(*,
     &      '(''Entered into the multobs mode.(IFMULTOBS->1)'')')
          else
            ifmultobs=0
            do imm=1,999
              numser(imm)=0
              fnolist(imm)=''
            end do
            nspecify=0
            write(*,
     &      '(''Exitted  from the multobs mode.(IFMULTOBS->0)'')')
          end if
          write(*,*) 'Press any key to continue...'
          cdum=getcharqq()
          if(ifmultobs.eq.0) go to 5990
c         now setting up for the multobs mode
          write(*,'(''file name of the LIST of obs. spec. --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,'(a)',err=9) fnmultobs
          call lablen(fnmultobs,60,nsm,nem)
          if (nsm.ge.nem) then
            go to 9
          end if
          inquire(file=fnmultobs(nsm:nem),exist=loexist)
          if(.not.loexist) go to 19
          open (unit=59,file=fnmultobs(nsm:nem))
          imcnt=0
          do imf=1,9999
          read(59,'(a)',err=5999,end=5999) tfnolist
          call lablen(tfnolist,60,nsy,ney)
          do iy=nsy,ney
            if(tfnolist(iy:iy).eq.' ') go to 5905
          end do
 5905     iyb=iy
          read(tfnolist(nsy:iyb-1),*) imfile
          if(imfile.lt.1.or.imfile.gt.999) then
            write(*,*) 'Invalid spectrum number in the filelist--> ',
     &      imfile
            write(*,*) 'which should be within 1<= N <= 999: Stopped!'
            stop
          end if
          fnolist(imfile)=tfnolist(iyb+1:ney)
          imcnt=imcnt+1
          numser(imcnt)=imfile
          end do
 5999     continue
          nmfile=imcnt
          close (59)
          imfcur=0
 5990     continue

        case (ichar('n'))
          write(*,'(a)') ch
        if(ifmultobs.eq.1) then
c         ifmultobs=1 mode
          ifmcurbk=ifmcur
          imfcur=imfcur+1
          if(imfcur.gt.nmfile) then
            write(*,*)
     &      '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            write(*,*)
     &      'Last spectrum in the file list has been completed ....'
            write(*,*)
     &      'If you want exit from the multispec mode, enter "0"...'
            write(*,*)
     &      '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
            imfcur=1
          end if
 5902     write(*,
     &     '(''obs. spec. No ? ['',i3.3,''] --> '',$)')
     &     numser(imfcur)
            call readline(linetmp,ifok,nsvv,nevv)
            if(ifok.eq.0) then
              nspecify=numser(imfcur)
            else
              read(linetmp,*,err=9,end=9) nspecify
              if(nspecify.le.0) then
                ifauto=0
                initau=0
                go to 1
              end if
              do imm=1,nmfile
                if(nspecify.eq.numser(imm)) go to 5907
              end do
              write(*,'(''Spec. No.'',i3,'' does not exist!'')')
     &        nspecify
              go to 9
 5907         continue
              imfcur=imm
            end if
            dopcor_keep=dopcor
            dopcorbk=dopcor
            dcfacbk=dcfac
            fnback1=fnobspec_org
            fnback2=fnobspec
            fnobspec_org=fnolist(nspecify)
            call dopcheck(fnobspec_org,fnobspec,dopcor)
          go to 1927
        end if
c       normal ifmultobs=0 mode
         write(*,'(''file name of new observed spectrum -->     '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          dopcorbk=dopcor
          dcfacbk=dcfac
          fnback1=fnobspec_org
          fnback2=fnobspec
          read(linetmp,'(a)',err=9) fnobspec_org
          call dopcheck(fnobspec_org,fnobspec,dopcor)
 1927   continue

          if(dopcor.ne.0.) then
            dcfac=1.+dopcor/2.997925e5
          else
            dcfac=1.
          end if

          call checkfit(fnobspec,ifbl,norder)
             if(ifbl.ne.0) then
               inquire(file=fnobspec(1:iabs(ifbl)-1),exist=loexist)
             else
               inquire(file=fnobspec,exist=loexist)
             end if
             if(.not.loexist) then
               ifmcur=ifmcurbk
               dopcor=dopcorbk
               dcfac=dcfacbk
               fnobspec_org=fnback1
               fnobspec    =fnback2
               go to 19
             end if
             call specread(88,fnobspec, ifbl, norder, nd, xs, ys)

          labobs=fnobspec
cs
          call lablen(fnobspec,60,ns,ne)
          if (ns.ge.ne) then
            nd=0
            go to 19
          end if

c         reset display region when obs. spectrum browsing mode
          if(ifthex.eq.0) then
                tx1=1.e30
                tx2=-1.e30
                ty1=1.e30
                ty2=-1.e30
                sum=0.
                do k=1,nd
                  if(xs(k)*dcfac.lt.tx1) tx1=xs(k)*dcfac
                  if(xs(k)*dcfac.gt.tx2) tx2=xs(k)*dcfac
                  if(ys(k).lt.ty1) ty1=ys(k)
                  if(ys(k).gt.ty2) ty2=ys(k)
                  sum=sum+ys(k)
                end do
                ysmean=sum/nd
                xmin=tx1
                xmax=tx2
                if(numord.gt.1.and.lolimit) then
c                xmin=wmne
c                xmax=wmxe
                 xmin=min(wlmul(1,1),wlmul(1,numord))
                 xmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
                 xmin=max(wmne,xmin)
                 xmax=min(wmxe,xmax)
                end if
                call bestsel(xmin,xmax)


                if (ysmean.lt.ymaxstd) then
                  ymin=0.
                  ymax=ymaxstd
                else
                  ymin=ty1*0.0
                  ymax=ty2*ymaxstd
                end if
          end if
          tilta=0.
c         reset default display region
          modeg=1
          idb=0
c         but keep the batch mode for the case of ifmultobs=1
c         and loading the next spectrum (inextsp=9)
          if(ifmultobs.eq.1.and.inextsp.eq.9) then
c           first finding wrange1 and wrange2 for the new obsspec file
            if(numord.gt.1) then
              wrange1=min(wlmul(1,1),wlmul(1,numord))
              wrange2=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
            else
              wrange1=xs(1)*dcfac
              wrange2=xs(nd)*dcfac
            end if
            if(lolimit) then
c             reset the w-range according to the limits specified by the user
c             (but these user-specified limits are ignored if they correspond
c             to outside of the available spectral range)
c              wrange1=wmne
c              wrange2=wmxe
              wrange1=max(wmne,wrange1)
              wrange2=min(wmxe,wrange2)
            end if
c           using previously used fndb and fnewout (unless specified)
c           Now reading line data (only those within the spectral range)
            open (unit=59,file=fndb)
            icnt=0
            do i=1,9999
              read(59,'(a)',end=7799) line80
c
c             check if the first-appearing character is numeric
              do k=1,80
                if(line80(k:k).ne.' ') go to 7748
              end do
              cycle
 7748         ks=k
              if(ifnum(line80(ks:ks)).eq.0) cycle
c
              read(line80,'(6x,f9.3)') wdummy
              if(wdummy.lt.wrange1.or.wdummy.gt.wrange2) cycle
              icnt=icnt+1
              wlamdb(icnt)=wdummy
              labdb(icnt)=line80
            end do
 7799       ndb=icnt
            close (59)
            idb=1
            spandb1=spandb
            if(spandb.lt.0) spandb1=abs(spandb)*(wlamdb(idb)/5000.)
            xmin=wlamdb(idb)-0.5*spandb1
            xmax=wlamdb(idb)+0.5*spandb1
            call bestsel(xmin,xmax)
            last=0
            if(fnrefspec(1:15).eq.'KPNO solar flux') then
c             again using solar spectrum for fnrefspec but with range reset
              call sunspset
c              fnrefspec='KPNO solar flux spectrum (default)'
c              labref=fnrefspec
c              drfac=1.
c            else
c              nr=0
c              fnrefspec=''
c              labref=fnrefspec
            end if
            if(fnlineid(1:31).eq.'simulated solar lines (default)') then
              call sunidset
            end if
            inextsp=0
            ifauto=0
            initau=0
            go to 1
          end if
c
        case (ichar('r'))
c       in case of no-obspec mode (pure simulation while no observed spectrum 
c       is specified), simulated spectrum will be written out to a file
        if(ifthex.ne.0) then
          write(*,'(a/)') ch
          write(*,*)'We now write out the unbroadened simulated spectra'
          write(*,'(''fname of the. sp. output ?'')')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
  615     read(linetmp,'(a)',err=9) fname
          call lablen(fname,60,ns,ne)
          if(ns.gt.ne) go to 615
          open (unit=8,file=fname)
          write(*,'(''comment (=<60 chars) ? (Just enter to skip)'')')
          read(*,'(a)',err=9) comment
          if(ifabs.eq.0) then
            write(8,'(a)') '# simulated original (unbroadened) spectrum'
     &      //' [flux normalized to local continuum]'
          else
            write(8,'(a)') '# simulated original (unbroadened) spectrum'
     &      //' [absolute H_lam flux (erg/s/A/cm^2]'
          end if
          write(8,'(a)') '# '//labthe
          write(8,'(a)') '# '//lablin
          write(8,'(a)') '# '//comment
          write(8,'(''#  wave(A) '','' the. spec.'')')
          if(ifabs.eq.0) then
            do k=1,npoint
              write(8,'(0pf10.3,0pf12.6)') wlth(k)*10,residf(k)
            end do
          else
            do k=1,npoint
              write(8,'(0pf10.3,1pe12.4)') wlth(k)*10,absf(k)
            end do
          end if
          close (8)
          go to 5090
        end if
c       otherwise, reference spectrum is read from an adequate file,
c       which is to be compared with the current observational spectrum 
c
        if(nr.eq.0) go to 5012

c       in case of refspec being already loaded
        write(*,*) 'refspec is already loaded...'
        write(*,*) 'To unload current refspec, press "d" ...'
        write(*,*) 'To return with nothing changed, press "c" ...'
        write(*,*) 'Any other key to continue & newly load refspec...'
        ch=getcharqq()
        if(ch.eq.'d') then
          nr=0
          return
        else if(ch.eq.'c') then
          return
        end if

 5012     continue
          write(*,'(a)') ch
          write(*,'(''file name of reference spectrum --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) then
          call sunspset
          fnrefspec='KPNO solar flux spectrum (default)'
          labref=fnrefspec
          drfac=1.
          go to 5090
          end if
          read(linetmp,'(a)',err=9) fnrefspec
          call dopcheck(fnrefspec,fnrefspec,dopref)
          if(dopref.ne.0.) then
            drfac=1.+dopref/2.997925e5
          else
            drfac=1.
          end if
          labref=fnrefspec
cs
          call lablen(fnrefspec,60,ns,ne)
          if (ns.ge.ne) then
            nr=0
c            go to 9
            go to 5090
          end if
          inquire(file=fnrefspec,exist=loexist)
          if(.not.loexist) go to 9
          open (unit=8,file=fnrefspec)
          wvlmt1=min(wlmul(1,1),wlmul(1,numord))
          wvlmt2=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
          n=0
          do i=1,99999
            read(8,'(a)',end=2033) line80
            do k=1,80
              if(line80(k:k).ne.' ') go to 2048
            end do
            cycle
 2048       ks=k
            cdum=line80(ks:ks)
c      read the data only if the first appearing character is numeric
            if(ifnum(cdum).eq.1) then
                read(line80,*) xrtemp,yrtemp
c                if(xrtemp.ge.xmin.and.xrtemp.le.xmax) then
                if(xrtemp.gt.wvlmt1.and.xrtemp.lt.wvlmt2) then
                 n=n+1
                  if(n.gt.MREF) then
                    write(*,*) 'nr, MREF: ',nr,MREF
                    stop
                  end if
                  xr(n)=xrtemp
                  yr(n)=yrtemp
                end if
            end if
          end do
 2033     continue
          nr=n
          close (8)
 5090     continue
c
        case (ichar('j'))
          write(*,'(a)') ch
          if(numord.le.1.or.ifthex.ne.0) then
            write(*,*) 'This is only for non-theo.(+multispe) mode!'
            write(*,'('' Sorry... Press any key to proceed...'')')
            cdum=getcharqq()
            return
          end if
          if(nofoc-1.lt.1) then
            write(*,*) 'No smaller order exists than the present one!'
            return
          end if
          nofoc=nofoc-1
          nd=nump(nofoc)
          do k=1,nd
            xs(k)=wlmul(k,nofoc)
            ys(k)=spmul(k,nofoc)
          end do
c         reset display region when obs. spectrum browsing mode
          if(ifthex.eq.0) then
                tx1=1.e30
                tx2=-1.e30
                ty1=1.e30
                ty2=-1.e30
                sum=0.
                do k=1,nd
                  if(xs(k)*dcfac.lt.tx1) tx1=xs(k)*dcfac
                  if(xs(k)*dcfac.gt.tx2) tx2=xs(k)*dcfac
                  if(ys(k).lt.ty1) ty1=ys(k)
                  if(ys(k).gt.ty2) ty2=ys(k)
                  sum=sum+ys(k)
                end do
                ysmean=sum/nd
                xmin=tx1
                xmax=tx2
c                if(numord.gt.1.and.lolimit) then
c                xmin=wmne
c                xmax=wmxe
c                end if
                call bestsel(xmin,xmax)
                if (ysmean.lt.ymaxstd) then
                  ymin=0.
                  ymax=ymaxstd
                else
                  ymin=ty1*0.0
                  ymax=ty2*ymaxstd
                end if
          end if
cc         rewrite the order No. of fnobspec and labobs
c          write(ch2,'(i2.2)') nofoc
c          ifbl=index(fnobspec,'[')
c          fntemp=fnobspec(1:iabs(ifbl)-1)//'[*,'//ch2//']'
c          fnobspec=fntemp
c          labobs=fnobspec
c          xmin0=xmin
c          xmax0=xmax
c          ymin0=ymin
c          ymax0=ymax
c
c
        case (ichar('k'))
          write(*,'(a)') ch
          if(numord.le.1.or.ifthex.ne.0) then
            write(*,*) 'This is only for non-theo.(+multispe) mode!'
            write(*,'('' Sorry... Press any key to proceed...'')')
            cdum=getcharqq()
          return
          end if
          if(nofoc+1.gt.numord) then
            write(*,*) 'No larger order exists than the present one!'
            return
          end if
          nofoc=nofoc+1
          nd=nump(nofoc)
          do k=1,nd
            xs(k)=wlmul(k,nofoc)
            ys(k)=spmul(k,nofoc)
          end do
c         reset display region when obs. spectrum browsing mode
          if(ifthex.eq.0) then
                tx1=1.e30
                tx2=-1.e30
                ty1=1.e30
                ty2=-1.e30
                sum=0.
                do k=1,nd
                  if(xs(k)*dcfac.lt.tx1) tx1=xs(k)*dcfac
                  if(xs(k)*dcfac.gt.tx2) tx2=xs(k)*dcfac
                  if(ys(k).lt.ty1) ty1=ys(k)
                  if(ys(k).gt.ty2) ty2=ys(k)
                  sum=sum+ys(k)
                end do
                ysmean=sum/nd
                xmin=tx1
                xmax=tx2
c                if(numord.gt.1.and.lolimit) then
c                xmin=wmne
c                xmax=wmxe
c                end if
                call bestsel(xmin,xmax)
                if (ysmean.lt.ymaxstd) then
                  ymin=0.
                  ymax=ymaxstd
                else
                  ymin=ty1*0.0
                  ymax=ty2*ymaxstd
                end if
          end if
cc         rewrite the order No. of fnobspec and labobs
c          write(ch2,'(i2.2)') nofoc
c          ifbl=index(fnobspec,'[')
c          fntemp=fnobspec(1:iabs(ifbl)-1)//'[*,'//ch2//']'
c          fnobspec=fntemp
c          labobs=fnobspec
c          xmin0=xmin
c          xmax0=xmax
c          ymin0=ymin
c          ymax0=ymax
c
c
c
c            This is EL (not the vertical bar!)
c                    |
c                    V
        case (ichar('l'))
          write(*,'(a)') ch
          if(numord.le.1.or.ifthex.ne.0) then
            write(*,*) 'spectral range(s) of the observed spectra:'
            write(*,980)
     &      (j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
            write(*,'('' Press any key to proceed...'')')
            cdum=getcharqq()
            return
          end if
          write(*,980)
     &    (j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
  980     format(5(1x,'(',i2.2,':',2i5,')'))
          write(*,'('' Specify the order to display --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) notmp
          if(notmp.lt.1.or.notmp.gt.numord) then
          write(*,'(''specify correct order no. !'')')
c          write(*,980)
c     &    (j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
          go to 9
          end if
          nofoc=notmp
          nd=nump(nofoc)
          do k=1,nd
            xs(k)=wlmul(k,nofoc)
            ys(k)=spmul(k,nofoc)
          end do
c         reset display region when obs. spectrum browsing mode
          if(ifthex.eq.0) then
                tx1=1.e30
                tx2=-1.e30
                ty1=1.e30
                ty2=-1.e30
                sum=0.
                do k=1,nd
                  if(xs(k)*dcfac.lt.tx1) tx1=xs(k)*dcfac
                  if(xs(k)*dcfac.gt.tx2) tx2=xs(k)*dcfac
                  if(ys(k).lt.ty1) ty1=ys(k)
                  if(ys(k).gt.ty2) ty2=ys(k)
                  sum=sum+ys(k)
                end do
                ysmean=sum/nd
                xmin=tx1
                xmax=tx2
c                if(numord.gt.1.and.lolimit) then
c                xmin=wmne
c                xmax=wmxe
c                end if
                call bestsel(xmin,xmax)
                if (ysmean.lt.ymaxstd) then
                  ymin=0.
                  ymax=ymaxstd
                else
                  ymin=ty1*0.0
                  ymax=ty2*ymaxstd
                end if
          end if
cc         rewrite the order No. of fnobspec and labobs
c          write(ch2,'(i2.2)') nofoc
c          ifbl=index(fnobspec,'[')
c          fntemp=fnobspec(1:iabs(ifbl)-1)//'[*,'//ch2//']'
c          fnobspec=fntemp
c          labobs=fnobspec
c          xmin0=xmin
c          xmax0=xmax
c          ymin0=ymin
c          ymax0=ymax
c
        case (ichar('t'))
          write(*,'(a)') ch
          write(*,'(''multip. factor to obs. spec.--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) fz

        case (ichar('T'))
          write(*,'(a)') ch
          fz=1.
c
        case (ichar('/'))
          write(*,'(a)') ch
          write(*,'(''tilt corr. grad. (per A) to obs. spec.--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
c         we first save ys in case of monospec
          if(numord.le.1.and.tilta.eq.0.) then
            do n=1,nd
            ysorg(n)=ys(n)
            end do
          end if
          read(linetmp,*,err=9,end=9) tilta
c         directly change ys in case of monospec
          if(numord.le.1) then
            xcen=0.5*(xmin+xmax)
        	do n=1,nd
      		 ys(n)=ysorg(n)/(1.+tilta*(xs(n)*dcfac-xcen))
        	end do
          end if
c
        case (ichar('V'))
          write(*,'(a)') ch
          if(ifmultobs.eq.1) then
            doppre=dopcor_keep
          else
            doppre=dopcor
          end if
          write(*,
     &    '(''New Doppler velocity shift?  ['',f6.1,'']'')') doppre
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) then
            tdopcor=doppre
          else
            read(linetmp,*,err=9,end=9) tdopcor
          end if
          dopcor=tdopcor
          dshft=0.
          dcfac=1.+dopcor/2.997925e5
c
        case (ichar('_'))
          write(*,'(a)') ch
          tilta=0.
c         ys directly recovered in case of monospec
          if(numord.le.1) then
            do n=1,nd
            	ys(n)=ysorg(n)
            end do
          end if
c
        case (ichar('0'))
          write(*,'(a)') ch
          xmin=xmin0
          xmax=xmax0
          call bestsel(xmin,xmax)
          if(ifthex.eq.0) then
            xmin=min(wlmul(1,1),wlmul(1,numord))
            xmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
          end if
          ymin=ymin0
          ymax=ymax0
          if(ifabs.eq.1) then
          ymin=yminkeep
          ymax=ymaxkeep
          end if
          dshft=dshft0
          vw=vw0
          threseta=threseta0
          rp=rp0
          imk=0
          yshift=0.
          fz=1.
          if(ifthex.eq.0) then
            nide=0
            nr=0
          end if
        case (ichar('I'))
          write(*,'(a/)') ch
          if(ifthex.eq.1) then
            write(*,*)'Going to write to a file line ID/strength info'
            write(*,548) threseta
  548       format('for lines stronger than current eta-threshold of',
     &      1pe11.4)
            write(*,
     &      '(''If OK, specify the filename (just Enter to cancel):'')')
            call readline(linetmp,ifok,nsvv,nevv)
            if(ifok.eq.0) return
  501       read(linetmp,'(a)',err=9) fname
            call lablen(fname,60,ns,ne)
            if(ns.gt.ne) go to 501
            open (unit=34,file=fname)
            write(*,'(''comment (=<60 chars) ? (Just enter to skip)'')')
            read(*,'(a)',err=9) comment
            write(34,'(a)') '# '//labthe
            write(34,'(a)') '# '//lablin
            write(34,'(a)') '# '//labobs
            write(34,'(''# ('',0p2f10.3,i7,1pe11.4,'')'')')
     &      stwv,enwv,nide,etacrt
            write(34,'(''#  '',0p2f10.3,0pf7.2,1pe11.4)')
     &      xmin,xmax,xi,threseta
            write(34,'(a)') '# '//comment
            do iid=1,nide
             read(lnident(iid),'(3x,f9.3,f12.6)') wladummy,etadum
             if(wladummy.lt.xmin.or.wladummy.gt.xmax.
     &       or.etadum.lt.threseta) cycle
             write(34,'(a)') lnident(iid)
            end do
          else
ccc            nide=0
            write(*,'(a)') ch
            write(*,*) 'Going to read line info from a file'
            write(*,'(''Specify the file name to read --> '',$)')
            call readline(linetmp,ifok,nsvv,nevv)
c            if(ifok.eq.0) return
            if(ifok.eq.0) then
              call sunidset
              fnlineid='simulated solar lines (default)'
              return
            end if
            read(linetmp,'(a)',err=9) fnlineid
            call lablen(fnlineid,60,ns,ne)
            if (ns.ge.ne) then
              nide=0
c              go to 9
              go to 2609
            end if
            inquire(file=fnlineid,exist=loexist)
            if(.not.loexist) go to 9
            open (unit=8,file=fnlineid)
            wvlmt1=min(wlmul(1,1),wlmul(1,numord))
            wvlmt2=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
            n=0
            do i=1,99999
              read(8,'(a)',end=2633) line80
              do k=1,80
                if(line80(k:k).ne.' ') go to 2648
              end do
              cycle
 2648         ks=k
              cdum=line80(ks:ks)
c             read only if the first appearing character is not '#'
              if(cdum.ne.'#') then
                  n=n+1
                  read(line80,'(3x,f9.3,f12.6)') wladummy,etadum
                  if(wladummy.ge.wvlmt1.and.wladummy.le.wvlmt2) then 
                    lnident(n)=line80(1:66)
                  end if
                  if(n.eq.MAXIDE) go to 2633
              end if
            end do
 2633       continue
            nide=n
            close (8)
          end if
 2609     continue

        case (ichar('o'))
          write(*,'(a/)') ch
          write(*,*)'Going to write the displayed spectra out to a file'
          write(*,'(''wavelength step (in A; e.g., 0.01) --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9,end=9) delwv
  510     write(*,'(''fname of the. sp. output ?'')')
          read(*,'(a)',err=9) fname
          if(ifthex.eq.0) write(*,*) 'No theoretical spectra exist!'
          call lablen(fname,60,ns,ne)
          if(ns.gt.ne) go to 510
          open (unit=34,file=fname)
          write(*,'(''comment (=<60 chars) ? (Just enter to skip)'')')
          read(*,'(a)',err=9) comment
          write(34,'(a)') '# '//labthe
          write(34,'(a)') '# '//lablin
          write(34,'(a)') '# '//labobs
          write(34,'(''# xmin,xmax,dshft,yshift,fz:'',2f10.2,3f10.5)')
     #    xmin, xmax, dshft, yshift, fz
          write(34,'(''# vw,rp,ifabs:'',f6.1,f10.0,i4)') vw,rp,ifabs
          write(34,'(a)') '# '//comment
          if(nd.gt.0) then
          write(34,508)
  508     format('# wave(A) ','  obs.spec.','  the.spec.','  overplot1',
     %    '  overplot2','  overplot3','  overplot4')
          else
          write(34,509)
  509     format('# wave(A) ','  the.spec.','  overplot1',
     %    '  overplot2','  overplot3','  overplot4')
          end if
          if(ifthex.ne.0) then
          xn1=xth(n1)
          xn2=xth(n2)
          else
          call range(xs*dcfac-dshft,nd,xmin,xmax,n1s,n2s)
          xn1=xs(n1s)*dcfac-dshft
          xn2=xs(n2s)*dcfac-dshft
          end if
          nptemp=int((xn2-xn1)/delwv)+1
          do jp=1,nptemp
          wvtemp(jp)=xn1+delwv*(jp-1)
          end do

          if(ifthex.eq.0) then
            nspec=0
            go to 511
          end if
          do j=1,nspec
          idum=map1
     &    (xthsv(1,j),ythsv(1,j),npsv(j),wvtemp,sptemp(1,j),nptemp)
          end do
  511     continue
          if(nd.le.0) then
            do jp=1,nptemp
              sptemp(jp,0)=0.
            end do
          else
           idum=map1(xs*dcfac-dshft,ys*fz+yshift,nd,wvtemp,
     &              sptemp(1,0),nptemp)
          end if
          jstart=0
          if(nd.le.0) jstart=1
          if(ifabs.eq.0) then
            fmtot='(0pf9.3,1x,0p6f11.4)'
          else
            fmtot='(0pf9.3,1x,1p6e11.4)'
          end if
c
c         case for only observed spectrum
          if(ifthex.eq.0.or.nspec.eq.0) fmtot='(0pf9.3,1x,1pe11.4)'
c
          do jp=1,nptemp
          write(34,fmtot)
     &    wvtemp(jp),(sptemp(jp,j),j=jstart,nspec)
          end do
          close (34)

          if(nd.gt.0) then
          write(*,*)
     #    'Option to output observed spectrum with its original spacing'
          write(*,'(''filename for this? (just enter to skip)--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,'(a)',err=9) fname
          call lablen(fname,60,ns,ne)
          if(ns.gt.ne) return
          open (unit=34, file=fname)
          write(labchar3,'(i3)') nofoc
          write(34,'(a)') '# ('//labchar3//') '//labobs
          write(34,'(''# xmin,xmax,dshft,yshift,fz:'',2f10.2,3f10.5)')
     #    xmin, xmax, dshft, yshift, fz
          do j=1,nd
          if(xs(j)*dcfac-dshft.lt.xmin.or.
     &    xs(j)*dcfac-dshft.gt.xmax) cycle
          write(34,'(0pf9.3,1x,1pe11.4)') 
     &    xs(j)*dcfac-dshft, ys(j)*fz+yshift
          end do
          close (34)
          end if

        case (ichar('O'))
          write(*,'(a/)') ch
          write(*,*)'Going to write the displayed obspec out to a file'
          write(*,'(''filename ? (just enter to skip)--> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,'(a)',err=9) fname
          call lablen(fname,60,ns,ne)
          if(ns.gt.ne) return
          open (unit=34, file=fname)
          write(labchar3,'(i3)') nofoc
          write(34,'(a)') '# ('//labchar3//') '//labobs
          write(34,'(''# xmin,xmax,dshft,yshift,fz:'',2f10.2,3f10.5)')
     #    xmin, xmax, dshft, yshift, fz
          do j=1,nd
          if(xs(j)*dcfac-dshft.lt.xmin.or.xs(j)*dcfac-dshft.gt.xmax)
     &    cycle
          write(34,'(0pf9.3,1x,1pe11.4)') 
     &    xs(j)*dcfac-dshft, ys(j)*fz+yshift
          end do
          close (34)

        case (ichar('\'), 9)
c       back-slash key or TAB key
        call drawframe(0)
c_bbb
        if(ifauto.eq.2) then
        write(*,*) 'M(auto)...'
        go to 5959
        end if
c_fff
c          write(*,*) 'mouse mode (right click to exit from this):'
          write(*,*)
     &     ' click with SHIFT --> w1/w2/Fc for E.W.'
          write(*,*)
     &     '(click with CTRL --> w1/w2 [new (xmin,xmax) ])'
          write(*,*)
     &     '(click with CTRL+SHIFT--> w1/w2 [ident-list range])'
          write(*,*)
     &     '(simple click --> [X-drag] or [Fc for E.W. measure] '

 5959     continue

      lowaitid=.false.
      lowaitmk=.false.
      lowaitxx=.false.
  111     mouseevent=MOUSE$LBUTTONDOWN .or. MOUSE$RBUTTONDOWN
c     &              .or. MOUSE$LBUTTONUP .or. MOUSE$RBUTTONUP
c     &              .or. MOUSE$LBUTTONDBLCLK .or. MOUSE$RBUTTONDBLCLK
c     &              .or. MOUSE$MOVE
          result=waitonmouseevent(mouseevent,keystate,mx,my)
c
c         Now begins to check the event for each of the cases

          lol=(MOUSE$KS_LBUTTON.and.keystate) /= MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) == MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) /= MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) /= MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc) then
          result=waitonmouseevent(MOUSE$RBUTTONUP,keystate,mx,my)
                write(*,*) 'Now we have returned to '//
     &          'the normal command mode'
c_bbb
                iapdum=1
                ifauto=0
c_fff
                go to 1
           end if
c     region shift or zooming in/out in y-direction by R-drag with SHIFT
          lol=(MOUSE$KS_LBUTTON.and.keystate) /= MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) == MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) == MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) /= MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wy2=ymin-(ymax-ymin)*ydmargin
                wy1=ymax+(ymax-ymin)*ytmargin
                presx=abs(wx2-wx1)/myscreen.numxpixels
                presy=abs(wy2-wy1)/myscreen.numypixels
                xv=wx1+mx*presx
                yv=wy1-my*presy
          result=waitonmouseevent(MOUSE$RBUTTONUP,keystate,mxn,myn)
          loc=(MOUSE$KS_SHIFT.and.keystate) == MOUSE$KS_SHIFT
          if(loc) then
            if(myn.gt.my) then
              dy1=1.-ymin
              ymin=1.-dy1/2.
              dy2=ymax-1.
              ymax=1.+dy2/2.
              call drawframe(0)
              go to 111
            else if(myn.lt.my) then
              dy1=1.-ymin
              ymin=1.-dy1*2.
              dy2=ymax-1.
              ymax=1.+dy2*2.
              call drawframe(0)
              go to 111
            else
              call drawframe(0)
              go to 111
            end if
           end if
          end if

c===================================================================
c     Caution: (simple L-click) --> case by case two different functions
          lol=(MOUSE$KS_LBUTTON.and.keystate) == MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) /= MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) /= MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) /= MOUSE$KS_CONTROL
c     case of idb>0 (prescribed-line measuring batch mode)
c     Quickly measuring EW only by clicking the continuum level
c      if((ifn.eq.1).and.(idb.gt.0).and.lol.and.lor.and.los.and.loc) then
      if((idb.gt.0).and.lol.and.lor.and.los.and.loc) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wy2=ymin-(ymax-ymin)*ydmargin
                wy1=ymax+(ymax-ymin)*ytmargin
                presx=abs(wx2-wx1)/myscreen.numxpixels
                presy=abs(wy2-wy1)/myscreen.numypixels
                xv=wx1+mx*presx
                yv=wy1-my*presy
                ifewid=-1
                return
          end if
c     case of idb=0 (normal measuring mode)
c     Showing X/Y-position followed by changing X-view region
c      if((ifn.ne.1).and.(idb.eq.0).and.lol.and.lor.and.los.and.loc) then
      if((idb.eq.0).and.lol.and.lor.and.los.and.loc) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wy2=ymin-(ymax-ymin)*ydmargin
                wy1=ymax+(ymax-ymin)*ytmargin
                presx=abs(wx2-wx1)/myscreen.numxpixels
                presy=abs(wy2-wy1)/myscreen.numypixels
                xv=wx1+mx*presx
                yv=wy1-my*presy
                if(presx.gt.0.01) then
                  fmtx=' f8.2'
                else if (presx.gt.0.001) then
                  fmtx=' f9.3'
                else if (presx.gt.0.0001) then
                  fmtx='f10.4'
                else
                  fmtx='f11.5'
                end if
                fmty=' f8.5'
                if(abs(yv).gt.1.5) fmty='f10.1'
                fmtot='(''X='','//fmtx//',3x,''Y='','//fmty//')'
                  write(*,fmtot) xv,yv

          result=waitonmouseevent(MOUSE$LBUTTONUP,keystate,mxn,myn)
          if(abs(mxn-mx).gt.abs(myn-my)) then
             xw=wx1+mxn*presx
             yw=wy1-myn*presy
             xmin=xmin-(xw-xv)
             xmax=xmax-(xw-xv)
             call drawframe(0)
             go to 111
          else if(myn.lt.my) then
            xcen=0.5*(xmin+xmax)
            cwid=xmax-xmin
            xmin=xcen-cwid
            xmax=xcen+cwid
            call drawframe(0)
            go to 111
          else if(myn.gt.my) then
            xcen=0.5*(xmin+xmax)
            cwid=xmax-xmin
            xmin=xcen-cwid/4.
            xmax=xcen+cwid/4.
            call drawframe(0)
            go to 111
          else
            call drawframe(0)
            go to 111
          end if
        end if
c===================================================================

c     erase the character output and reset the screen
          lol=(MOUSE$KS_LBUTTON.and.keystate) == MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) == MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) /= MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) /= MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc) then
                call drawframe(0)
                go to 111
          end if


c  id-range set (L-click with CTRL+SHIFT-key) display in short format
          lol=(MOUSE$KS_LBUTTON.and.keystate) == MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) /= MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) == MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) == MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc.and.(.not.lowaitid)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxbeg=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''id range begin:'',f8.2)') wxbeg
                write(*,'(''(give another SHIFT + L-click!)'')')
                lowaitid=.true.
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitid)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxend=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                wxendinput=wxend
                if(wxbeg.gt.wxend) then
                  twx=wxbeg
                  wxbeg=wxend
                  wxend=twx
                end if
               if(threseta.ge.0.01) then
               lclast=21
               else if(threseta.ge.0.001) then
               lclast=22
               else if(threseta.ge.0.0001) then
               lclast=23
               else
               lclast=24
               end if
                  do i=1,nide
                          read(lnident(i),'(3x,f9.3,f12.6,10x)') wla,eta
                          if(wla.lt.wxbeg.or.wla.gt.wxend) cycle
                          if(eta.lt.threseta) cycle
                          write(*,'(a)') lnident(i)(1:lclast)
                  end do
                write(*,'(''id range  end :'',f8.2)') wxendinput
c
c               calculate S/N ratio in this range if obs. spec. exists
                if(nd.gt.0) then
                call range(xs*dcfac-dshft,nd,wxbeg,wxend,n1,n2)
                nrg=n2-n1+1
                nrg=max(1,nrg)
                sumy=0.
                do n=n1,n2
                sumy=sumy+ys(n)*fz+yshift
                end do
                avy=sumy/nrg
                sumsqy=0.
                do n=n1,n2
                sumsqy=sumsqy+(ys(n)*fz+yshift-avy)**2
                end do
                sdev=sqrt(sumsqy/nrg)
                if(sdev.gt.0.) then
                sn=avy/sdev
                else
                sn=0.
                end if
                if(avy.gt.10000.) then
                fmty=' f7.0'
                else if (avy.gt.1000.) then
                fmty=' f7.1'
                else if (avy.gt.100.) then
                fmty=' f7.2'
                else if (avy.gt.10.) then
                fmty=' f7.3'
                else
                fmty=' f7.4'
                end if
                if(ifabs.eq.1) fmty='e11.4'
                write(*,'(''avy:'','//fmty//')') avy
                write(*,'(''sgy:'','//fmty//')') sdev
                write(*,'(''S/N:'',f7.1)') sn
                end if
c
                lowaitid=.false.
                go to 111
          end if

c  id-range set (R-click with CTRL+SHIFT-key) display in long format
          lol=(MOUSE$KS_LBUTTON.and.keystate) /= MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) == MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) == MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) == MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc.and.(.not.lowaitid)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxbeg=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''id range begin:'',f8.2)') wxbeg
                write(*,'(''(give another SHIFT + R-click!)'')')
                lowaitid=.true.
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitid)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxend=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                wxendinput=wxend
                if(wxbeg.gt.wxend) then
                  twx=wxbeg
                  wxbeg=wxend
                  wxend=twx
                end if
               if(threseta.ge.0.01) then
               lclast=21
               else if(threseta.ge.0.001) then
               lclast=22
               else if(threseta.ge.0.0001) then
               lclast=23
               else
               lclast=24
               end if
                  do i=1,nide
                          read(lnident(i),'(3x,f9.3,f12.6,10x)') wla,eta
                          if(wla.lt.wxbeg.or.wla.gt.wxend) cycle
                          if(eta.lt.threseta) cycle
                    write(*,'(a)') lnident(i)(1:lclast)//lnident(i)(25:)
                  end do
                write(*,'(''id range  end :'',f8.2)') wxendinput
c
c               calculate S/N ratio in this range in case of no lines
                if(nide.le.0) then
                call range(xs*dcfac-dshft,nd,wxbeg,wxend,n1,n2)
                nrg=n2-n1+1
                nrg=max(1,nrg)
                sumy=0.
                do n=n1,n2
                sumy=sumy+ys(n)*fz+yshift
                end do
                avy=sumy/nrg
                sumsqy=0.
                do n=n1,n2
                sumsqy=sumsqy+(ys(n)*fz+yshift-avy)**2
                end do
                sdev=sqrt(sumsqy/nrg)
                if(sdev.gt.0.) then
                sn=avy/sdev
                else
                sn=0.
                end if
                if(avy.gt.10000.) then
                fmty=' f7.0'
                else if (avy.gt.1000.) then
                fmty=' f7.1'
                else if (avy.gt.100.) then
                fmty=' f7.2'
                else if (avy.gt.10.) then
                fmty=' f7.3'
                else
                fmty=' f7.4'
                end if
                write(*,'(''avy:'','//fmty//')') avy
                write(*,'(''sgy:'','//fmty//')') sdev
                write(*,'(''S/N:'',f7.1)') sn
                end if
c
                lowaitid=.false.
                go to 111
          end if


c  EW integration-range set (L-click with SHIFT three times)
          lol=(MOUSE$KS_LBUTTON.and.keystate) == MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) /= MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) == MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) /= MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc.and.(.not.lowaitid)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                ewxbeg=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''begin:'',f8.2)') ewxbeg
                write(*,'(''(click for w2!)'')')
                lowaitid=.true.
                iw=1
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitid)
     &            .and.iw.eq.1) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                ewxend=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                wxendinput=ewxend
                if(ewxbeg.gt.ewxend) then
                  twx=ewxbeg
                  ewxbeg=ewxend
                  ewxend=twx
                end if
                write(*,'('' end :'',f8.2)') wxendinput
                write(*,'(''(click for yc!)'')')
                lowaitid=.true.
                iw=2
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitid)
     &            .and.iw.eq.2) then

                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxtmp=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                wy1=ymin-(ymax-ymin)*ydmargin
                wy2=ymax+(ymax-ymin)*ytmargin
                ycont=wy2-my*abs(wy2-wy1)/myscreen.numypixels
                if((ycont.lt.ymin).or.(ycont.gt.ymax).or.
     &             (wxtmp.lt.xmin).or.(wxtmp.gt.xmax)) ycont=1.
                lowaitid=.false.
                iw=0
                ifewid=1
                return
          end if



c  mask set (Right click with CTRL key)
          lol=(MOUSE$KS_LBUTTON.and.keystate) /= MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) == MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) /= MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) == MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc.and.(.not.lowaitmk)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                imk1=imk+1
                wms(imk1)=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''mask'',i2,'' begin:'',f8.2)') imk1,wms(imk1)
                write(*,'(''(give another CTRL+  R-click!)'')')
                lowaitmk=.true.
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitmk)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wme(imk1)=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''mask'',i2,''  end :'',f8.2)') imk1,wme(imk1)
                if(wms(imk1).gt.wme(imk1)) then
                  twx=wms(imk1)
                  wms(imk1)=wme(imk1)
                  wme(imk1)=twx
                end if
                write(*,*) 'Reset screen to confirm if this mask is OK'
                imk=imk1
                lowaitmk=.false.
                go to 111
          end if

c   new [xmin,xmax] range set (with CTRL-key)
          lol=(MOUSE$KS_LBUTTON.and.keystate) == MOUSE$KS_LBUTTON
          lor=(MOUSE$KS_RBUTTON.and.keystate) /= MOUSE$KS_RBUTTON
          los=(MOUSE$KS_SHIFT.and.keystate) /= MOUSE$KS_SHIFT
          loc=(MOUSE$KS_CONTROL.and.keystate) == MOUSE$KS_CONTROL
          if(lol.and.lor.and.los.and.loc.and.(.not.lowaitxx)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxbeg=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                write(*,'(''CTRL-clicked at new xmin ('',f8.2,'')'')')
     &          wxbeg
                write(*,'(''(give another CTRL-click at new xmax!)'')')
                lowaitxx=.true.
                go to 111
          else if (lol.and.lor.and.los.and.loc.and.(lowaitxx)) then
                wx1=xmin-(xmax-xmin)*xlmargin
                wx2=xmax+(xmax-xmin)*xrmargin
                wxend=wx1+mx*abs(wx2-wx1)/myscreen.numxpixels
                if(wxbeg.gt.wxend) then
                        twx=wxbeg
                        wxbeg=wxend
                        wxend=twx
                end if
                xmin=wxbeg
                xmax=wxend
                call bestsel(xmin,xmax)
ccc
ccc                return
                call drawframe(0)
                lowaitxx=.false.
                go to 111
ccc
          end if

        case (ichar('m'))
          do while (1)
c
c         clean the buggy input data
          do jjj=1,imk
          if(wms(jjj).eq.0..and.wme(jjj).eq.0.) then
          do jjm=jjj,imk-1
          wms(jjm)=wms(jjm+1)
          wme(jjm)=wme(jjm+1)
          end do
          imk=imk-1
          end if
          end do
c
          write (*,'(1x,i2,'' mask(s) currently registered:'')') imk
c
          do jjm=1,imk
          write (*,'(''No.'',i2,'' --> from'',f8.2,'' to '',f8.2)')
     %    jjm,wms(jjm),wme(jjm)
          end do
          write (*,*)
     %    'enter the mask No. you want to unregister ("0" to cancel)'
          read(*,*,err=9,end=9) numd
          if (numd.le.0) exit
          do jjm=numd,imk-1
          wms(jjm)=wms(jjm+1)
          wme(jjm)=wme(jjm+1)
          end do
          imk=imk-1
          end do


c        case (ichar('#'))
c          write(*,'(a)') ch
c          write(*,'(''inc. vertical shift (obs. spectrum) --> '',$)')
c          call readline(linetmp,ifok,nsvv,nevv)
c          if(ifok.eq.0) return
c          read(linetmp,*,err=9,end=9) delys
c          yshift=yshift+delys

c        case (ichar('a'))
c          write(*,'(a)') ch
c          if(ifn.eq.1) then
cc          write(*,
cc     &    '('' Sorry, this does not work in the m-option mode'')')
cc          write(*,'('' Press any key to proceed...'')')
cc          cdum=getcharqq()
c          return
c          end if
c          write(*,'(''list of atomic numbers --> '',$)')
c          call readline(linetmp,ifok,nsvv,nevv)
c          if(ifok.eq.0) return
c          call divline(linetmp,izsel,nzsel,99)
c          if(nzsel.eq.1.and.izsel(1).eq.0) then
c          write(*,'(''v_mic='',f6.2,''  ! microturbulence (km/s)'')') xi
c          go to 7810
c          end if
c          write(*,7808)
c 7808     format(2x,'  iz',' depsl',' log eps')
c          do iv=1,nzsel
c          jv=izsel(iv)
c          ela=log10(xabund0(jv)/xabund0(1))+12.
c          if(jv.ge.3) then
c            els=log10(xabund(jv)/xscale/xabund(1))+12.
c          else
c            els=log10(xabund(jv)/xabund(1))+12.
c          end if
c          elx=log10(xabund(jv)/xabund(1))+12.
c          write(*,7809) elem(jv),ncode(jv),depsl(jv),ela,elx,xscale,els
c 7809     format(a2,i4,f6.2,f8.2,3x,'( mdl:',f6.2,' [xscale=',
c     &    f10.5,']  std:',f6.2,' )')
c          end do
c 7810     continue
c          irt=0

        case (ichar('f'))
c               reset nspec
                nspec=1

        case (ichar('F'))
          if(dshft.ne.0..or.dopcor.ne.0.) then
            write(*,
     &      '(''Currest values of dshft & dopcor:'',f7.3,f7.1)') 
     &      dshft,dopcor
          end if          
          if(ifthex.eq.0.and.nr.eq.0) then
            write(*,*) 
     &      'Why theoretical (ifthex=1) mode without refspec?'
            go to 5081
          end if
          if(abs((xs(2)-xs(1))/(xs(nd)-xs(nd-1))-1.).gt.0.001) then
cLLLLLLLL
c           linearize wavelength spacing
            do j=1,numord
              do n=1,nump(j)
                xttt(n)=wlmul(n,j)
                yttt(n)=spmul(n,j)
              end do
              dddd=(xttt(nump(j))-xttt(1))/float(nump(j)-1)
              do n=1,nump(j)
                xuuu(n)=xttt(1)+dddd*float(n-1)
              end do
              idum=map1(xttt,yttt,nump(j),xuuu,yuuu,nump(j))
              do n=1,nump(j)
                wlmul(n,j)=xuuu(n)
                spmul(n,j)=yuuu(n)
              end do
              dddd=(xs(nd)-xs(1))/float(nd-1)
              do n=1,nd
                xuuu(n)=xs(1)+dddd*float(n-1)
              end do
            end do
            idum=map1(xs,ys,nd,xuuu,yuuu,nd)
            do n=1,nd
              xs(n)=xuuu(n)
              ys(n)=yuuu(n)
            end do
cLLLLLLLL
          end if
          call range(xs*dcfac-dshft,nd,xmin,xmax,nj1,nj2)
          xj1=xs(nj1)*dcfac-dshft
          xj2=xs(nj2)*dcfac-dshft
          nnj=nj2-nj1+1
c         First setting the observed spectrum
          do j=1,nnj
          xbas(j)=xs(j+nj1-1)*dcfac-dshft
          ysmap(j)=ys(j+nj1-1)*fz+yshift
          end do

          if(ifthex.eq.1) go to 5070
c         non-theoretical mode (ifthex=0) but with refspec (nr>0)
          if(nr.le.0) then
          write(*,*) 'Why not nr>0 in this case of ifthex=0?'
          stop
          end if
c          if(xj1.lt.xr(1)*drfac.or.xj2.gt.xr(nr)*drfac) then
c          write(*,*) 'Reference light-grey spectrum does not cover '//
c     &    'the observed red spectrum! '
c          write(*,*) 'Enlarge the former!'
c          go to 5081
c          else
          idum=map1(xr*drfac,yr,nr,xbas,ythmap,nnj)
          go to 5075
c          end if

c         theoretical mode (ifthex=1)
 5070     continue
c          if(xj1.lt.xthsv(1,1).or.xj2.gt.xthsv(npsv(1),1)) then
c          write(*,*) 'Theorerical blue spectrum does not cover '//
c     &    'the observed red spectrum! '
c          write(*,*) 'Enlarge the former!'
c          go to 5081
c          else
          idum=map1(xthsv(1,1),ythsv(1,1),npsv(1),xbas,ythmap,nnj)
          go to 5075
c          end if

 5075     continue
          call vcfind(xbas,ysmap,ythmap,nnj,dlacor,dvkmcor)
          wmiddle=0.5*(xbas(1)+xbas(nnj))
          write(*,*)
          if(dshft.ne.0..or.dopcor.ne.0.) then
            dlacor_=dlacor
            dlacor0=dlacor_+(wmiddle*dopcor/2.997925e5-dshft)
            dvkmcor_=dvkmcor
            dvkmcor0=dvkmcor_*dlacor0/dlacor_
            write(*,'(''dlacor_(A)='',f6.3,'' (relative)'')') dlacor_
            write(*,'(''dvkmcor_=  '',f6.1,'' (relative)'')') dvkmcor_
          else
            dlacor0=dlacor
            dvkmcor0=dvkmcor
          end if
          write(*,'(''dlacor0(A)='',f6.3,'' (absolute)'')') dlacor0
          write(*,'(''dvkmcor0=  '',f6.1,'' (absolute)'')') dvkmcor0
          write(*,*) 'Going to apply this absolute correction to dopcor'
          write(*,*) 'while setting dshft=0 ...'
          write(*,*) 'Hit any key to proceed (press "c" to cancel'//
     $    ' or "5" to manually input dvkmcor)...'
          cdum=getcharqq()
          if(cdum.eq.'c'.or.cdum.eq.'C') go to 5082
          if(cdum.eq.'5') then
            write(*,'('' New dvkmcor? '')')
            read(*,*) dvkmcor0         
          end if
          dopcor=dvkmcor0
          dcfac=1.+dopcor/2.997925e5
          dshft=0.
          absdop=abs(dopcor)
          if(absdop.lt.10.) then
            write(labchar12,'(''{'',SP,f4.1,''}'')') dopcor
          else if (absdop.lt.100) then
            write(labchar12,'(''{'',SP,f5.1,''}'')') dopcor
          else if (absdop.lt.1000) then
            write(labchar12,'(''{'',SP,f6.1,''}'')') dopcor
          else
            write(labchar12,'(''{'',SP,f7.1,''}'')') dopcor
          end if
          jbrk1=index(labchar12,'{')
          jbrk2=index(labchar12,'}')
          fnobspec_org=labchar12(jbrk1:jbrk2)//labobs
          irt=1
          return
 5081     continue
          write(*,*) 'Press any key to continue...'
          cdum=getcharqq()
 5082     continue

        case (ichar('h'))
         write(*,*)
         write(*,*)
     %   '---------------- quick help for key commands ----------------'
         write(*,*)
     %   'h: quick help  x: set X-range  y: set Y-range  w: set x-Width'
         write(*,*)
     %   'X: autoscale in x-range  Y: autoscale in y-range (focused sp)'
         write(*,*)
     %   'c: Centering at specified lambda     0: initialize parameters'
         write(*,*)
     %   'z: Zoom-in X-direction   u: Unzoom (zoom-out) in X-direction '
         write(*,*)
     %   'Z: Zoom-in Y-direction   U: Unzoom (zoom-out) in Y-direction '
         write(*,*)
     %   's: x-Shift obspec incrementally |:(vbar) toggle bisector mode'
         write(*,*)
     %   'n: load New obs. spectrum  R: specify Resolution (0 for inf.)'
         write(*,*)
     %   '): display region small right move     >: large right move   '
         write(*,*)
     %   '(: display region small left move      <: large left move    '
         write(*,*)
     %   '^: display reg. upward move   v: display reg. downward move  '
         write(*,*)
     %   '(blank): toggle spectrum focus (multispe case)               '
         write(*,*)
     %   ' j:prev. k:next l:spec (focus key only for browsing multispe)'
         write(*,*)
     %   ' +/-: Enter/Exit batch mode (only for non-theoretical case)  '
         write(*,*)
     %   ' ]: Next batch line     [: previous batch line               '
         write(*,*)
     %   'b: set Broadening width (km/s) (>0...Gaus-HWEM, <0...Rot vel)'
         write(*,*)
     %   'e: set Eta (line-center/continuum opacity ratio) threshold   '
         write(*,*)
     %   'O: Output cur. Obspec to a file   N: Setup multi-obspec file '
         write(*,*)
     %   'o: Output displayed spectrum to file       q: Quit SPSHOW    '
cM         write(*,*)
cM     %   'M: set relative y-margin (when measuring EW)                 ' 
         write(*,*)
     %   't : set obspec mulTiplier     T: reset obspec mulTiplier to 1'
         write(*,*)
     %   '/ : spectrum tilt correction  _: reset (remove) sp tilt corr.'
         write(*,*)
     %   'm: show/free Mask region "." (dot): toggle unfocus order plot'
         write(*,*)
     %   'P: prof. point offset     \ or Tab: enter the mouse mode     '
         write(*,*)
     %   'G: Go calc with new cpanel.txt  g: go cal. spec (commandline)'  
         write(*,*)
     %   'K: set/check K(=vr/vd) param  A: set/check A (damping param) '
         write(*,*)
     %   'C: Clears K(-->0) and A(-->0) to fit again with pure Gaussian'
         write(*,*)
     %   'f: Forget past history of overplots   @: set data for mpfit  '
         write(*,*)
     %   '%: data setup for WIDTH  BS: Erase EW measurement just done  '
         write(*,*)
     %   'I: [write line-str info (the), read them from file (non-the)]'
         write(*,*)
     %   'r: [load Reference spec (non-the),  write out sim.spec (the)]'
         write(*,*)
     %   'F: determine DVcor for wavelength match  V: Reset DVcor      '
         write(*,*)
     %   '"`" (B.Q.): toggle if DVcor is linked in reference spectrum  '
         write(*,*)
     %   '-------------------------------------------------------------'
         irt=0

        case (ichar('%'))
 3415     write(*,'(''Vturb list (up to three values) --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
c         check if data is really a number
          do ivv=nsvv,nevv
            if(ifnum(linetmp(ivv:ivv)).eq.1) go to 3416
          end do
          go to 3409
 3416     continue
          if(ifok.eq.0) return
          call divline1(linetmp,vtsel,nvt,21)
          if(nvt.gt.3) go to 3415
 3405     write(*,'(''session name ? (<=40 chars)'')')
          read(*,'(a)',err=9) idlabel
          call lablen(idlabel,40,nswz,newz)
          if(ns.gt.ne) then
          write(*,'(''session name can not be omitted !'')')
          go to 3405
          end if
c          write(*,'(''Comments? (<=60 chars: just enter to skip)'')')
c          read(*,'(a)',err=9) comment
          open (unit=13,file='linedat.tmp')
          rewind 13
          iln=0
          ict=0
          do i=1,9999
          read(13,'(3x,a1)',end=3408) ch
          ict=ict+1
          if(ch.eq.'.') iln=iln+1
          end do
 3408     continue
          nmline=iln
          ncount=ict
          rewind 13
          open (unit=14,file=idlabel(nswz:newz)//'.win')
          if(ifmol.eq.1) then
            write(14,'(''MOLE'')')
          end if
          write(14,'(''VTUR'')')
          write(14,'(i5,3f5.2)') nvt,(vtsel(ivt),ivt=1,nvt)
          write(14,'(''LINE'',i4,4x,(a60))') nmline,fnmodel
          do i=1,ncount
          read(13,'(a)') line80
          call lablen(line80,80,ns,ne)
          if(ns.gt.ne) cycle
          write(14,'(a)') line80
          end do
          close (13)
          write(14,'(''END'')')
          rewind 5
          do i=1,9999
          read(5,'(a)',end=3409) line80
          call lablen(line80,80,ns,ne)
          if(ns.gt.ne) cycle
          write(14,'(a)') line80
          end do
 3409     continue
          write(14,'(''END'')')
          write(14,'(''STOP'')')
          close(14)
          call retenv("DAT_DIR",datdir)
          call lablen(datdir,80,ndsdir,ndedir)
                open (unit=16,file='widfiles.lst')
                if(ifmol.eq.1) then
                write(16,'(a)')
     &            'f  2  '//datdir(ndsdir:ndedir)//'\molec.dat'
                end if
                write(16,'(a)') 'f  5 '//idlabel(nswz:newz)//'.win'
                write(16,'(a)') 'f  6 woutput.out'
                write(16,'(a)') 'f 13'
                write(16,'(a)') 'f 20'
                write(16,'(a)') 'f 22'
                write(16,'(a)') 'f-44 '//idlabel(nswz:newz)//'.csv'
                close (16)
c          linedat.tmp is renamed as linedat.bak
                inquire(file='linedat.bak',exist=loexist)
                if(loexist) result=systemqq('del linedat.bak')
                result= systemqq('ren linedat.tmp linedat.bak')

        case (ichar('@'))
cp *****
cp     mpfit default setting --> regfile shoould be in the "current" directory
cp     mpfit default setting --> session name to be the header name of 16 chars 
cp
cp      setup default idlabel
cp
              kdot=index(fnobspec,'.',.true.)
              if(kdot.le.0) then
              call lablen(fnobsec,60,kop_s,kop_e)
              kdot=kop_e+1
              end if
              klast=kdot-1
              nnnsla=index(fnobspec,'\',.true.)
              if(nnnsla.gt.0) then
                kopf=nnnsla+1
              else
                kopf=1
              end if
              nnnbrr=index(fnobspec,'}')
              if(nnnbrr.gt.0.and.nnnbrr+1.gt.kopf) kopf=nnnbrr+1
              idlabel_def=fnobspec(kopf:klast)
cp *****
          write(*,'(a)') ch
          write(*,'(''Main atomic elements in mask-free region:'')')
          do lz=-68,99
          lznum(lz)=lz
          etama(lz)=-1.e30
          end do
          if(vw.lt.0.) then
            dwzu=0.5*(xmin+xmax)*(abs(vw)+5.)/2.997925e5
          else
            dwzu=0.5*(xmin+xmax)*(2.*vw+5.)/2.997925e5
          end if
          do l=1,nide
          read(lnident(l),'(3x,f9.3,f12.6,f10.2)') wq,eq,cq
          iq=int(cq+0.5)
          if(cq.ge.100.) then
          iq=invcode(cq)
          end if
          if(wq.lt.xmin.or.wq.gt.xmax) go to 409
          do im=1,imk
          if(wq.gt.wms(im).and.wq.lt.wme(im)) go to 409
          end do
          if(eq.gt.etama(iq)) etama(iq)=eq
  409     continue
          end do
          do k=99,-67,-1
          do i=-68,k-1
          if(etama(i).lt.etama(i+1)) then
          etamat=etama(i+1)
          etama(i+1)=etama(i)
          etama(i)=etamat
          lznumt=lznum(i+1)
          lznum(i+1)=lznum(i)
          lznum(i)=lznumt
          end if
          end do
          end do
          do i=-68,-59
          if(etama(i).le.0.) cycle
          if(lznum(i).gt.0) then
          write(*,'(i2,2x,a2,2x,f9.3)') lznum(i),elem(lznum(i)),etama(i)
          else
          tcod=cm(iabs(lznum(i)))
          ijel=int(tcod+0.5)
          call calzam(ijel,elm,tatmas,mola,iza)
          write(*,'(i3,1x,a2,2x,f9.3)') lznum(i),elm,etama(i)
          end if
          end do
          nvarmp=-999
          do while (1)
          write(*,'('' Do you want to set input data for mpfit ?'')')
          write(*,'('' If so, input how many elements you want '')')
          write(*,'('' to vary (<=10). (input 0 to cancel):'')')
          read(*,*,err=9,end=9) nvarmp
          if(nvarmp.eq.0) go to 1
          if(nvarmp.ge.1.and.nvarmp.le.10) go to 102
          if(nvarmp.ge.100) then
cp
cp        idlabel is set at the default string (from obspec file name)
            idlabel=idlabel_def
cp
            if(nvarmp.ge.100.and.nvarmp.le.999) then
              write(labreg,'(i3.3)') nvarmp
            else if (nvarmp.ge.1000.and.nvarmp.le.9999) then
              write(labreg,'(i4.4)') nvarmp
            else if (nvarmp.ge.10000.and.nvarmp.le.99999) then
              write(labreg,'(i5.5)') nvarmp
            else
              write(*,*) 'Too large nvarmp -->', nvarmp
              stop
            end if
            call lablen(labreg,5,krs,kre)
c
            write(*,*) 
     &      'parameter setup with the file reg'//labreg(krs:kre)
            inquire(file='reg'//labreg(krs:kre)//'.dat',exist=loexist)
            if(.not.loexist) then
              write(*,*) 'necessary file: reg'//labreg(krs:kre)//
     &        '.dat does not exist in the currect directory!'
              cycle
            else
              open (unit=56,file='reg'//labreg(krs:kre)//'.dat')
              read(56,*)
              read(56,*) xmindum,xmaxdum
              if(xmindum.gt.0.and.xmaxdum.gt.0.) then
                xmin=xmindum
                xmax=xmaxdum
              end if
              read(56,*) nvarmp
              read(56,*) (iz(k),k=1,nvarmp)
              close (56)
              xiadopt=xi
c         set default resolu if rp is already set
              resolu=0.
              if(rp.gt.0.) resolu=rp
c         set default ep to epsel if already set
              epsel=ep

              call lablen(idlabel,40,ns,ne)
              com40='reg'//labreg
              go to 305
            end if
          end if
          end do
  102     write(*,'(''Input atomic number(s) for '',i2,'' elements:'')')
     &    nvarmp
          read(*,*,err=9,end=9) (iz(k),k=1,nvarmp)
c         set default resolu if rp is already set
          if(rp.gt.0.) resolu=rp
c
          write(*,
     &    '(''resolution ? (maybe 0 if not relevant) ['',i6,'']'')')
     &    int(resolu+0.5)
          respre=resolu
          read(*,'(a)',err=9) linetmp
          call lablen(linetmp,60,ns,ne)
          if(ns.gt.ne) then
                resolu=respre
          else
                read(linetmp,*,err=9,end=9) tresol
                resolu=tresol
          end if
          if(vw.lt.0.) then
            if(nlimda.le.1) then
              write(*,
     &        '(''Default limb-dark coeff OK ? ['',f5.3,'']'')') ep
            else
              write(*,
     &        '(''Interp. limb-dark coeff OK ? ['',f5.3,'']'')') ep
            end if
          epspre=ep
          read(*,'(a)',err=9) linetmp
          call lablen(linetmp,60,ns,ne)
                if(ns.gt.ne) then
                        epsel=epspre
                else
                        read(linetmp,*,err=9,end=9) tepsld
                        epsel=tepsld
                end if
          end if

          write(*,
     &    '(''microturbulence ? ['',f4.1,'']'')') xi
          xipre=xi
          read(*,'(a)',err=9) linetmp
          call lablen(linetmp,60,ns,ne)
                if(ns.gt.ne) then
                        xiadopt=xipre
                else
                        read(linetmp,*,err=9,end=9) tmpxi
                        xiadopt=tmpxi
                end if


  109     write(*,'(''session name for this job? (<=40 chars)'')')
          read(*,'(a)',err=9) idlabel
          call lablen(idlabel,40,ns,ne)
          if(ns.gt.ne) then
c            write(*,'(''session name can not be omitted !'')')
c            go to 109
            write(idlabel,'(''a'',i5.5,''w'',i2.2)') 
     &      int(0.5*(xmin+xmax)+0.5),int((xmax-xmin)+0.5)
           idlabel=idlabel(1:9)//'_'//trim(idlabel_def)
            call lablen(idlabel,40,ns,ne)
            write(*,'(a)') 'assumed idlabel:'//idlabel(ns:ne)
          end if
          write(*,'(''Comments? (<=40 chars: just enter to skip)'')')
          read(*,'(a)',err=9) com40
  305     continue
          call lablen(com40,40,ns_c,ne_c)
          call lablen(fnobspec,60,ns_o,ne_o)
          kfits=index(fnobspec,'.fits')
          if(kfits.gt.0) then
            ns_o=kfits-16
            ne_o=kfits-16+15
          end if
          call lablen(fnmodel,60,ns_m,ne_m)
          ifyen=index(fnmodel,'\',.true.)
          if(ifyen.gt.0) ns_m=ifyen+1
          write(labdc,'("{",SP,f6.1,"}")') dopcor
          if(ns_c.gt.ne_c) then
          comment=labdc//' '//fnobspec(ns_o:ne_o)//'|'//
     &    fnmodel(ns_m:ne_m)
          else
          comment=labdc//' '//fnobspec(ns_o:ne_o)//'|'//
     &    fnmodel(ns_m:ne_m)//'|'//com40(ns_c:ne_c)
          end if
          open (unit=13,file='ksetin.bak')
          open (unit=14,file='msetin.bak')
          write(13,'(''Model parameters:'',0pf8.0,0pf7.3,1pe10.3)')
     &    teff,glog,xscale
          write(13,'(a)') fnmodel
          write(13,'(i2)') ifmol
          write(13,'(a)') fnlines
          iw1=int(xmin-dwzu)
          iw2=int(xmax+dwzu)+1
          write(13,'(2i6)') iw1,iw2
          write(13,'(i2)') nvarmp
          write(13,'(20i4)') (iz(k),k=1,nvarmp)
          close(13)
          open (unit=14,file='msetin.bak')
          write(14,'(a)') '('//idlabel//'): '//comment
c          write(14,'(a)') fnobspec
          write(14,'(a)') 'obspec_'//idlabel(ns:ne)//'.txt'
          inquire(59,opened=loopen)
          if(loopen) close(59)
          open (unit=59,file='obspec_'//idlabel(ns:ne)//'.txt')
c          call range(xs*dcfac-dshft,nd,xmin,xmax,n1,n2)
c         we take 10A margin on both sides of obspec
          call range(xs*dcfac-dshft,nd,xmin-10.,xmax+10.,nad1,nad2)
          do n=nad1,nad2
          	write(59,'(0pf10.3,1pe14.5)') xs(n)*dcfac,max(0.,ys(n))
          end do
          close (59)
          do k=1,nvarmp
          if(iz(k).gt.0) then
          write(14,'(2i3,f7.3)')
     &    iz(k),1,log10(xabund(iz(k))/xabund(1))+12.+depsl(iz(k))
          else
          tcod=cm(iabs(iz(k)))
          ijel=int(tcod+0.5)
          call calzam(ijel,elm,tatmas,mola,iza)
          sumepsl=0.
                do m=1,mola
                        sumepsl=sumepsl+depsl(iza(m))
                end do
          write(14,'(2i3,f7.3)') iz(k),1,sumepsl
          end if
          end do
          write(14,'(f8.0)') resolu
          write(14,'(f6.2)') xiadopt
          ifmac=2
          if(vw.lt.0.) ifmac=1
          write(14,'(i2)') ifmac
          write(14,'(f6.1)') max(abs(vw),3.)
          if(vw.lt.0.) write(14,'(f6.3)') epsel
          write(14,'(f8.4)') dshft
          write(14,'(2f10.2)') xmin+dshft,xmax+dshft
          write(14,'(i2)') imk
          if(imk.gt.0) then
          do im=1,imk
          write(14,'(2f10.2)') wms(im),wme(im)
          end do
          end if
          do l=1,40
          if(idlabel(l:l).ne.' ') go to 601
          end do
  601     l1=l
          do l=40,1,-1
          if(idlabel(l:l).ne.' ') go to 602
          end do
  602     l2=l
          write(14,'(a)') idlabel(l1:l2)//'.sav'
          close(14)
          inquire(5,opened=loopen)
          if(loopen) close(5)
          inquire(8,opened=loopen)
          if(loopen) close(8)
          inquire(9,opened=loopen)
          if(loopen) close(9)
         call retenv("DAT_DIR",datdir)
         call lablen(datdir,80,ndsdir,ndedir)

        open (unit=10,file='kapfiles.lst')
        if(ifmol.eq.1) then
          write(10,'(a)') 'f  2  '//datdir(ndsdir:ndedir)//'\molec.dat'
        end if
        write(10,'(a)') 'f  5  kinput.in'
        write(10,'(a)') 'f  6  koutput.out'
        write(10,'(a)') 'f  9  selgf.out'
        write(10,'(a)') 'f 13'
        write(10,'(a)') 'f 14  prof.out'
        write(10,'(a)') 'f 15  eta.out'
        write(10,'(a)') 'f 30  kapsave.tmp'
        write(10,'(a)') 'u 40'
        close (10)

          lores = systemqq(linedir(nsdir:nedir)//'\kdatset <ksetin.bak')
          lores = systemqq(linedir(nsdir:nedir)//'\kaprep')
          lores = systemqq(linedir(nsdir:nedir)//'\mdatset <msetin.bak')
c
c       file 5 recovered
        open (unit=5,file=fnmodel,shared)
        rewind 5
c
        case default
          write(*,*) 'Invalid command input!'
        end select
        return
   19 write(*,*) 'Specified file does not exist! Check the filename!'
      irt=0
      return
    9 write(*,*) 'Incorrect data input ! Clear screen and try again!'
      irt=0
      return
      end

      subroutine readline(linetmp,ifok,ns,ne)
      implicit real*8 (a-h,o-z)
      character*60 linetmp
          read(*,'(a)') linetmp
          call lablen(linetmp,60,ns,ne)
          if(ns.gt.ne) then
                ifok=0
          else
                ifok=1
          end if
      return
      end

      subroutine divline(linetmp,izsel,nzsel,nn)
      implicit real*8 (a-h,o-z)
      character*60 linetmp
      dimension izsel(nn),nreg(100)
      call lablen(linetmp,60,ns,ne)
      ireg=1
      nreg(1)=ns
      do n=ns+1,ne
      if(linetmp(n-1:n-1).eq.' ' .and. ifnum(linetmp(n:n)).eq.1 ) then
      ireg=ireg+1
      nreg(ireg)=n
      end if
      end do
      nreg(ireg+1)=ne+1
      nzsel=ireg
      do ireg=1,nzsel
      read(linetmp(nreg(ireg):nreg(ireg+1)-1),*) izsel(ireg)
      end do
      return
      end

      subroutine divline1(linetmp,xzsel,nzsel,nn)
      implicit real*8 (a-h,o-z)
      character*60 linetmp
      dimension xzsel(nn),nreg(100)
      call lablen(linetmp,60,ns,ne)
      ireg=1
      nreg(1)=ns
      do n=ns+1,ne
      if(linetmp(n-1:n-1).eq.' ' .and.
     & (ifnum(linetmp(n:n)).eq.1.or.linetmp(n:n).eq.'.') ) then
      ireg=ireg+1
      nreg(ireg)=n
      end if
      end do
      nreg(ireg+1)=ne+1
      nzsel=ireg
      do ireg=1,nzsel
      read(linetmp(nreg(ireg):nreg(ireg+1)-1),*) xzsel(ireg)
      end do
      return
      end

      function invcode(code)
      implicit real*8 (a-h,o-z)
      dimension cm(68)
      data cm/
     a 100.00,101.00,101.01,106.00,106.01,107.00,108.00,108.01,
     b 109.00,112.00,113.00,114.00,114.01,116.00,117.00,600.00,
     c 606.00,607.00,607.01,608.00,613.00,614.00,616.00,707.00,
     d 707.01,708.00,708.01,712.00,713.00,714.00,716.00,800.00,
     e 808.00,808.01,812.00,813.00,814.00,816.00,820.00,822.00,
     f 826.00,900.00,1216.00,1300.00,1316.00,1416.00,1600.00,1616.00,
     g 1620.00,1626.00,1700.00,2600.00,10100.00,10106.00,10107.00,
     h 10108.00,10116.00,10606.00,10607.00,10608.00,10708.00,
     i 10800.00,10808.00,60600.00,60700.00,60808.00,70700.00,
     j 80800.00/
      if(code.lt.100.) then
        invcode=int(code+0.5)
        return
      end if
      do j=1,68
        if(code.eq.cm(j)) then
          invcode=-j
          return
        end if
      end do
      write(*,*) 'Do not understand code=',code
      call exit
      end function

      SUBROUTINE SYNSPEC
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      PARAMETER(KPNT=100001,KCN=2001,MAXIDE=100000)
      EXTERNAL BLOCKE,BLOCKR,BLOCKT
      EXTERNAL FSET
      COMMON/FNAMES/FNMODEL,FNLINES,FNOBSPEC
      character*60 fnmodel,FNLINES,FNOBSPEC
      COMMON/LNRANGE/WLA1,WLA2,CBV
      COMMON/LCALDATA/XI,STWV,ENWV,NPOINT,NCON,NVAR,NCODE(99),DEPSL(99)
      COMMON/SYNPROF/WLTH(KPNT),AINT(KPNT),RESIDF(KPNT),ABSF(KPNT)
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)
      COMMON /ABTOT/ABTOT(kw),ALPHA(kw)
      COMMON /CONT/ABTOTC(kw),ALPHAC(kw),TAUNUC(kw),SNUC(kw),HNUC(kw),
     1             JNUC(kw),JMINSC(kw),RESIDC(kw)
      REAL*8 JNUC,JMINSC
      COMMON /CONV/DLTDLP(kw),HEATCP(kw),DLRDLT(kw),VELSND(kw),
     1             GRDADB(kw),HSCALE(kw),FLXCNV(kw),VCONV(kw),MIXLTH,
     2             IFCONV,OVERWT,FLXCNV0(kw),FLXCNV1(kw)
      REAL*8 MIXLTH
      COMMON /DEPART/BHYD(kw,6),BMIN(kw),NLTEON
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)
      character*2 elem
      COMMON /EDENS/EDENS(kw),IFEDNS
      COMMON /FILENAME/FILENAME
      CHARACTER*60 FILENAME
      COMMON /FLUX/ FLUX,FLXERR(kw),FLXDRV(kw),FLXRAD(kw)
      COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw)
      COMMON /FRESET/FRESET(1563),RCOSET(1563),NULO,NUHI,NUMNU
      COMMON /HEIGHT/HEIGHT(kw)
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL
      COMMON /IFOP/IFOP(20)
      COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3)
      COMMON /ITER/ ITER,IFPRNT(15),IFPNCH(15),NUMITS
      COMMON /JUNK/TITLE(74),FREQID(6),WLTE,XSCALE
      COMMON /MUS/ANGLE(20),SURFI(20),NMU
      COMMON /OPS/AHYD(kw),AH2P(kw),AHMIN(kw),SIGH(kw),AHE1(kw),
     1       AHE2(kw),AHEMIN(kw),SIGHE(kw),ACOOL(kw),ALUKE(kw),AHOT(kw),
     2            SIGEL(kw),SIGH2(kw),AHLINE(kw),ALINES(kw),SIGLIN(kw),
     3            AXLINE(kw),SIGXL(kw),AXCONT(kw),SIGX(kw),SHYD(kw),
     4            SHMIN(kw),SHLINE(kw),SXLINE(kw),SXCONT(kw)
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),
     1              SIGMAL(kw)
      COMMON /PTOTAL/PTOTAL(kw)
      COMMON /PUT/PUT,IPUT
      COMMON /PZERO/PZERO,PCON,PRADK0,PTURB0,KNU(kw),PRADK(kw),RADEN(kw)
      REAL*8 KNU
      COMMON /RAD/ ACCRAD(kw),PRAD(kw)
      COMMON /RHOX/RHOX(kw),NRHOX
      COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)
      REAL*8 JNU,JMINS
      COMMON /STEPLG/STEPLG,TAU1LG,KRHOX
      COMMON /TEFF/TEFF,GRAV,GLOG
      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,
     1               IFTURB
      COMMON /WAVEY/WBEGIN,DELTAW,IFWAVE
      COMMON /XABUND/XABUND(99),WTMOLE
      COMMON /XNF/XNFC(kw,6),XNFN(kw,6),XNFO(kw,6),XNFNE(kw,6),
     1            XNFMG(kw,6),XNFSI(kw,6),XNFS(kw,6),XNFFE(kw,5)
      COMMON /XNFP/XNFPC(kw,4),XNFPN(kw,5),XNFPO(kw,6),XNFPNE(kw,6),
     1             XNFPAL(kw,1),XNFPMG(kw,2),XNFPSI(kw,2),XNFPCA(kw,2),
     2             XNFPFE(kw,1),XNFPCH(kw),XNFPOH(kw)
      DIMENSION PART(kw,6)
C
      COMMON /CONTIN/CONTIN
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV
      LOGICAL LOCONV
      REAL*8 MINLOG
      COMMON /GAM/GLOGR,GLOGS,GLOGW
      COMMON /IFPROF/IFPROF
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,
     2               X2,OTHER1,OTHER2,ELO,GF
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)
      REAL*8 LINE0
      COMMON /OBS/EW,WLOBS,STAR(9)
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)
      COMMON /VTS/VTS(3),NVT
      COMMON /XLABEL/LAB,EXPOT
      COMMON /ABDIF/ABCOR
      COMMON /PLOTCG/MODECG,PDATA(9,3,2)
      DIMENSION POTION(594)
      DIMENSION POTA(114),POTB(114),POTC(114),POTD(114),POTE(114)
      DIMENSION POTF(24)
      EQUIVALENCE (POTION(1),POTA(1)),(POTION(115),POTB(1))
      EQUIVALENCE (POTION(229),POTC(1)),(POTION(343),POTD(1))
      EQUIVALENCE (POTION(457),POTE(1)),(POTION(571),POTF(1))
      CHARACTER LAB*28,STAR*8
      character*60 fnmsave
      data fnmsave/' '/
      common/ident/nide,lnident(MAXIDE)
      character*66 lnident
      character*10 molcode
      character*2 elm
      dimension iza(8)
      common/varpass/resolu,ifmole,ifnorm,ifthex,epsld,ifqcal,ifewid
      common/xabzero/xabund0(99)
      common/crit_eta/etacrt
      character*120 line120
      logical logfcor

      common/fnorgpass/fnobspec_org
      character*60 fnobspec_org
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/fluxmode/ifabs
      common/synfincheck/ifsame,ifsynfin
      common/iabsfchk/iabsfirst,ymaxkeep,yminkeep

      character*80 linedir
      logical lovcsex,lovbalm

      DIMENSION PABCO(kw,KPNT),WVCON(KCN),CONFLX(KCN)
      DIMENSION KCSV(KPNT),ACONSV(KCN,kw),ETA0(kw)
      DIMENSION TAU5(kw)
      DIMENSION AHSAVE(KCN,kw),SAVEAL(kw)
      DIMENSION SV1(kw,KCN),SV2(kw,KCN),SV3(kw,KCN),SV4(kw,KCN)
      DIMENSION SV5(kw,KCN),SV6(kw,KCN)
cc      DIMENSION ICD(20),SABCO(64,KPNT)
cc      LOGICAL LOSEP
      character*6 lbgr,lbgs,lbgw
      DATA POTA/
     1   13.598,   0.   ,   0.   ,   0.   ,   0.   ,   0.   ,
     2   24.587,  54.416,   0.   ,   0.   ,   0.   ,   0.   ,
     3    5.392,  75.638, 122.451,   0.   ,   0.   ,   0.   ,
     4    9.322,  18.211, 153.893, 217.713,   0.   ,   0.   ,
     5    8.298,  25.154,  37.930, 259.368, 340.217,   0.   ,
     6   11.260,  24.383,  47.887,  64.492, 392.077, 489.981,
     7   14.534,  29.601,  47.448,  77.472,  97.888, 552.057,
     8   13.618,  35.116,  54.934,  77.412, 113.896, 138.116,
     9   17.422,  34.970,  62.707,  87.138, 114.240, 157.161,
     T   21.564,  40.962,  63.45 ,  97.11 , 126.21 , 157.93 ,
     1    5.139,  47.286,  71.64 ,  98.91 , 138.39 , 172.15 ,
     2    7.646,  15.035,  80.143, 109.24 , 141.26 , 186.50 ,
     3    5.986,  18.828,  28.447, 119.99 , 153.71 , 190.47 ,
     4    8.151,  16.345,  33.492,  45.141, 166.77 , 205.05 ,
     5   10.486,  19.725,  30.18 ,  51.37 ,  65.023, 220.43 ,
     6   10.36 ,  23.33 ,  34.83 ,  47.30 ,  72.68 ,  88.049,
     7   12.967,  23.81 ,  39.61 ,  53.46 ,  67.80 ,  97.03 ,
     8   15.759,  27.629,  40.74 ,  59.81 ,  75.02 ,  91.007,
     9    4.341,  31.625,  45.72 ,  60.91 ,  82.66 , 100.0  /
      DATA POTB/
     1    6.113,  11.871,  50.908,  67.10 ,  84.41 , 108.78 ,
     2    6.54 ,  12.80 ,  24.76 ,  73.47 ,  91.66 , 111.1  ,
     3    6.82 ,  13.58 ,  27.491,  43.266,  99.22 , 119.36 ,
     4    6.74 ,  14.65 ,  29.310,  46.707,  65.23 , 128.12 ,
     5    6.766,  16.50 ,  30.96 ,  49.1  ,  69.3  ,  90.56 ,
     6    7.435,  15.640,  33.667,  51.2  ,  72.4  ,  95.   ,
     7    7.870,  16.18 ,  30.651,  54.8  ,  75.0  ,  99.0  ,
     8    7.86 ,  17.06 ,  33.50 ,  51.3  ,  79.5  , 102.0  ,
     9    7.635,  18.168,  35.17 ,  54.9  ,  75.5  , 108.0  ,
     T    7.726,  20.292,  36.83 ,  55.2  ,  79.9  , 103.0  ,
     1    9.394,  17.964,  39.722,  59.4  ,  82.6  , 108.0  ,
     2    5.999,  20.51 ,  30.71 ,  64.0  ,   0.   ,   0.   ,
     3    7.899,  15.934,  34.22 ,  45.71 ,  93.5  ,   0.   ,
     4    9.81 ,  18.633,  28.351,  50.13 ,  62.63 , 127.6  ,
     5    9.752,  21.19 ,  30.820,  42.944,  68.3  ,  81.70 ,
     6   11.814,  21.8  ,  36.   ,  47.3  ,  59.7  ,  88.6  ,
     7   13.999,  24.359,  36.95 ,  52.5  ,  64.7  ,  78.5  ,
     8    4.177,  27.28 ,  40.0  ,  52.6  ,  71.0  ,  84.4  ,
     9    5.695,  11.030,  43.6  ,  57.0  ,  71.6  ,  90.8  /
      DATA POTC/
     1    6.38 ,  12.24 ,  20.52 ,  61.8  ,  77.0  ,  93.0  ,
     2    6.84 ,  13.13 ,  22.99 ,  34.34 ,  81.50 ,   0.   ,
     3    6.88 ,  14.32 ,  25.04 ,  38.3  ,  50.55 , 102.6  ,
     4    7.099,  16.15 ,  27.16 ,  46.4  ,  61.2  ,  68.0  ,
     5    7.28 ,  15.26 ,  29.54 ,   0.   ,   0.   ,   0.   ,
     6    7.37 ,  16.76 ,  28.47 ,   0.   ,   0.   ,   0.   ,
     7    7.46 ,  18.08 ,  31.06 ,   0.   ,   0.   ,   0.   ,
     8    8.34 ,  19.43 ,  32.93 ,   0.   ,   0.   ,   0.   ,
     9    7.576,  21.49 ,  34.83 ,   0.   ,   0.   ,   0.   ,
     T    8.993,  16.908,  34.48 ,   0.   ,   0.   ,   0.   ,
     1    5.786,  18.869,  28.03 ,  54.0  ,   0.   ,   0.   ,
     2    7.344,  14.632,  30.502,  40.734,  72.28 ,   0.   ,
     3    8.641,  16.53 ,  25.3  ,  44.2  ,  56.0  , 108.0  ,
     4    9.009,  18.6  ,  27.96 ,  37.41 ,  58.75 ,  70.7  ,
     5   10.451,  19.131,  33.0  ,   0.   ,   0.   ,   0.   ,
     6   12.130,  21.21 ,  32.1  ,   0.   ,   0.   ,   0.   ,
     7    3.894,  25.1  ,  35.0  ,   0.   ,   0.   ,   0.   ,
     8    5.212,  10.004,  37.000,   0.   ,   0.   ,   0.   ,
     9    5.577,  11.06 ,  19.177,  49.954,   0.   ,   0.   /
      DATA POTD/
     1    5.47 ,  10.85 ,  20.197,  36.758,   0.   ,   0.   ,
     2    5.42 ,  10.55 ,  21.624,  38.981,   0.   ,   0.   ,
     3    5.49 ,  10.72 ,  22.14 ,  40.42 ,   0.   ,   0.   ,
     4    5.55 ,  10.90 ,  22.42 ,  41.09 ,   0.   ,   0.   ,
     5    5.63 ,  11.07 ,  23.45 ,  41.47 ,   0.   ,   0.   ,
     6    5.67 ,  11.25 ,  24.71 ,  42.65 ,   0.   ,   0.   ,
     7    6.14 ,  12.1  ,  20.38 ,  44.03 ,   0.   ,   0.   ,
     8    5.85 ,  11.52 ,  21.98 ,  39.84 ,   0.   ,   0.   ,
     9    5.93 ,  11.67 ,  22.83 ,  41.56 ,   0.   ,   0.   ,
     T    6.02 ,  11.80 ,  22.84 ,  42.51 ,   0.   ,   0.   ,
     1    6.10 ,  11.93 ,  22.74 ,  42.66 ,   0.   ,   0.   ,
     2    6.18 ,  12.05 ,  23.68 ,  42.69 ,   0.   ,   0.   ,
     3    6.254,  12.17 ,  25.03 ,  43.74 ,   0.   ,   0.   ,
     4    5.426,  13.9  ,  20.960,  45.193,   0.   ,   0.   ,
     5    7.0  ,  14.9  ,  23.3  ,  33.319,   0.   ,   0.   ,
     6    7.89 ,  16.200,  24.0  ,   0.   ,   0.   ,   0.   ,
     7    7.98 ,  17.70 ,  25.0  ,   0.   ,   0.   ,   0.   ,
     8    7.88 ,  16.6  ,  26.0  ,   0.   ,   0.   ,   0.   ,
     9    8.7  ,  17.0  ,  27.0  ,   0.   ,   0.   ,   0.   /
      DATA POTE/
     1    9.1  ,  20.0  ,  28.0  ,   0.   ,   0.   ,   0.   ,
     2    9.0  ,  18.563,  29.0  ,   0.   ,   0.   ,   0.   ,
     3    9.225,  20.5  ,  30.0  ,   0.   ,   0.   ,   0.   ,
     4   10.437,  18.756,  34.2  ,   0.   ,   0.   ,   0.   ,
     5    6.108,  20.428,  29.83 ,   0.   ,   0.   ,   0.   ,
     6    7.416,  15.032,  31.937,  42.32 ,  68.8  ,   0.   ,
     7    7.289,  16.69 ,  25.56 ,  45.3  ,  56.0  ,  88.3  ,
     8    8.42 ,  19.0  ,  27.0  ,   0.   ,   0.   ,   0.   ,
     9    9.3  ,  20.0  ,  30.   ,   0.   ,   0.   ,   0.   ,
     T   10.748,  20.0  ,  30.0  ,   0.   ,   0.   ,   0.   ,
     1    4.0  ,  22.0  ,  33.0  ,   0.   ,   0.   ,   0.   ,
     2    5.279,  10.147,  34.0  ,   0.   ,   0.   ,   0.   ,
     3    6.9  ,  12.1  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     4    6.0  ,  11.5  ,  20.0  ,  28.8  ,   0.   ,   0.   ,
     5    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     6    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     7    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     8    5.800,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     9    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   /
      DATA POTF/
     1    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     2    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     3    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,
     4    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   /
      DATA TAUREF/0.2/
c      IFPROF=0
c      ITEMP=0
      NABLOG=0
 2222 REWIND 13
      VTS(1)=0.
      VTS(2)=0.
      VTS(3)=0.
      NVT=1
      IFSURF=1
    3 CALL READIN(20)
C     IFOP(14) VS. IFOP(15)
      IF(IFOP(15).EQ.1) THEN
       IF(IFOP(14).EQ.1) THEN
       WRITE(*,*)'WHY BOTH OF IFOP(14) AND IFOP(15) EQUAL TO UNITY ???'
       STOP
       END IF
      IFOP(15)=0
      IFOP(14)=1
      END IF
      ABCOR=DLOG10(ABUND(1))
      if(fnmodel.ne.fnmsave) then
      fnmsave=fnmodel
      ITEMP=ITEMP+1
      end if
      CALL INTEG(RHOX,ABROSS,TAUROS,NRHOX,ABROSS(1)*RHOX(1))
      IF(IFPRES.NE.0)CALL POPS(0.D0,1,XNE)
      CALL POPS(1.01D0,11,XNFPH)
      CALL POPS(2.02D0,11,XNFPHE)
      CALL POPS(6.03D0,11,XNFPC)
      CALL POPS(7.04D0,11,XNFPN)
      CALL POPS(8.05D0,11,XNFPO)
      CALL POPS(10.05D0,11,XNFPNE)
      CALL POPS(12.01D0,11,XNFPMG)
      CALL POPS(13.00D0,11,XNFPAL)
      CALL POPS(14.01D0,11,XNFPSI)
      CALL POPS(20.01D0,11,XNFPCA)
      CALL POPS(26.00D0,11,XNFPFE)
      IF(IFMOL.EQ.0)THEN
      CALL POPS(1.01D0,12,XNFH)
      CALL POPS(2.02D0,12,XNFHE)
      CALL POPS(6.05D0,12,XNFC)
      CALL POPS(7.05D0,12,XNFN)
      CALL POPS(8.05D0,12,XNFO)
      CALL POPS(10.05D0,12,XNFNE)
      CALL POPS(12.05D0,12,XNFMG)
      CALL POPS(14.05D0,12,XNFSI)
      CALL POPS(16.05D0,12,XNFS)
      CALL POPS(26.04D0,12,XNFFE)
      ENDIF
      IF(IFMOL.EQ.1)THEN
      CALL POPS(106.00D0,11,XNFPCH)
      CALL POPS(108.00D0,11,XNFPOH)
      CALL W(6HXNFPCH,XNFPCH,NRHOX)
      CALL W(6HXNFPOH,XNFPOH,NRHOX)
C     THE POPS WILL NOT RETURN NUMBER DENSITIES WHEN MOLECULES ARE ON
C     SO WE COMPUTE NUMBER DENSITIES/PART FUNCTIONS  AND PART FUNCTIONS
      CALL POPS(6.05D0,11,XNFC)
      CALL POPS(7.05D0,11,XNFN)
      CALL POPS(8.05D0,11,XNFO)
      CALL POPS(10.05D0,11,XNFNE)
      CALL POPS(12.05D0,11,XNFMG)
      CALL POPS(14.05D0,11,XNFSI)
      CALL POPS(16.05D0,11,XNFS)
      CALL POPS(26.04D0,11,XNFFE)
      DO 444 J=1,NRHOX
      CALL PFSAHA(J,1,1,3,PART)
      XNFH(J,1)=XNFPH(J,1)*PART(J,1)
      XNFH(J,2)=XNFPH(J,2)
      CALL PFSAHA(J,2,2,13,PART)
      XNFHE(J,1)=XNFPHE(J,1)*PART(J,1)
      XNFHE(J,2)=XNFPHE(J,2)*PART(J,2)
      XNFHE(J,3)=XNFPHE(J,3)
      CALL PFSAHA(J,6,6,13,PART)
      XNFC(J,1)=XNFC(J,1)*PART(J,1)
      XNFC(J,2)=XNFC(J,2)*PART(J,2)
      XNFC(J,3)=XNFC(J,3)*PART(J,3)
      XNFC(J,4)=XNFC(J,4)*PART(J,4)
      XNFC(J,5)=XNFC(J,5)*PART(J,5)
      XNFC(J,6)=XNFC(J,6)*PART(J,6)
      CALL PFSAHA(J,7,6,13,PART)
      XNFN(J,1)=XNFN(J,1)*PART(J,1)
      XNFN(J,2)=XNFN(J,2)*PART(J,2)
      XNFN(J,3)=XNFN(J,3)*PART(J,3)
      XNFN(J,4)=XNFN(J,4)*PART(J,4)
      XNFN(J,5)=XNFN(J,5)*PART(J,5)
      XNFN(J,6)=XNFN(J,6)*PART(J,6)
      CALL PFSAHA(J,8,6,13,PART)
      XNFO(J,1)=XNFO(J,1)*PART(J,1)
      XNFO(J,2)=XNFO(J,2)*PART(J,2)
      XNFO(J,3)=XNFO(J,3)*PART(J,3)
      XNFO(J,4)=XNFO(J,4)*PART(J,4)
      XNFO(J,5)=XNFO(J,5)*PART(J,5)
      XNFO(J,6)=XNFO(J,6)*PART(J,6)
      CALL PFSAHA(J,10,6,13,PART)
      XNFNE(J,1)=XNFNE(J,1)*PART(J,1)
      XNFNE(J,2)=XNFNE(J,2)*PART(J,2)
      XNFNE(J,3)=XNFNE(J,3)*PART(J,3)
      XNFNE(J,4)=XNFNE(J,4)*PART(J,4)
      XNFNE(J,5)=XNFNE(J,5)*PART(J,5)
      XNFNE(J,6)=XNFNE(J,6)*PART(J,6)
      CALL PFSAHA(J,12,6,13,PART)
      XNFMG(J,1)=XNFMG(J,1)*PART(J,1)
      XNFMG(J,2)=XNFMG(J,2)*PART(J,2)
      XNFMG(J,3)=XNFMG(J,3)*PART(J,3)
      XNFMG(J,4)=XNFMG(J,4)*PART(J,4)
      XNFMG(J,5)=XNFMG(J,5)*PART(J,5)
      XNFMG(J,6)=XNFMG(J,6)*PART(J,6)
      CALL PFSAHA(J,14,6,13,PART)
      XNFSI(J,1)=XNFSI(J,1)*PART(J,1)
      XNFSI(J,2)=XNFSI(J,2)*PART(J,2)
      XNFSI(J,3)=XNFSI(J,3)*PART(J,3)
      XNFSI(J,4)=XNFSI(J,4)*PART(J,4)
      XNFSI(J,5)=XNFSI(J,5)*PART(J,5)
      XNFSI(J,6)=XNFSI(J,6)*PART(J,6)
      CALL PFSAHA(J,16,6,13,PART)
      XNFS(J,1)=XNFS(J,1)*PART(J,1)
      XNFS(J,2)=XNFS(J,2)*PART(J,2)
      XNFS(J,3)=XNFS(J,3)*PART(J,3)
      XNFS(J,4)=XNFS(J,4)*PART(J,4)
      XNFS(J,5)=XNFS(J,5)*PART(J,5)
      XNFS(J,6)=XNFS(J,6)*PART(J,6)
      CALL PFSAHA(J,26,5,13,PART)
      XNFFE(J,1)=XNFFE(J,1)*PART(J,1)
      XNFFE(J,2)=XNFFE(J,2)*PART(J,2)
      XNFFE(J,3)=XNFFE(J,3)*PART(J,3)
      XNFFE(J,4)=XNFFE(J,4)*PART(J,4)
      XNFFE(J,5)=XNFFE(J,5)*PART(J,5)
  444 CONTINUE
      ENDIF
      WL=500.0
      FREQ=2.997925E17/WL
      FREQLG=DLOG(FREQ)
      DO 33 J=1,NRHOX
      EHVKT(J)=EXP(-FREQ*HKT(J))
      STIM(J)=1.0-EHVKT(J)
      BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)
   33 CONTINUE
      N=1
      CALL KAPP(N,NSTEPS,STEPWT)
      DO 34 J=1,NRHOX
   34 ACONT(J)=ACONT(J)+SIGMAC(J)
      CALL INTEG(RHOX,ACONT,TAU5,NRHOX,ACONT(1)*RHOX(1))
      WRITE(6,333)
  333 FORMAT(1H1)
      IF(TRBSND.EQ.0.)GO TO 6
      WRITE(6,7)
    7 FORMAT(40HREWRITE WIDTH5 TO INCLUDE SOUND VELOCITY)
      STOP
    6 DO 5 J=1,NRHOX
      VELSND(J)=0.
    5 VTURB(J)=(TRBFDG*RHO(J)**TRBPOW+TRBSND*VELSND(J)/1.E5+TRBCON)*1.E5
      SSTWV=STWV/10.0
      EENWV=ENWV/10.0
      MIDCON=(1+NCON)/2
      DELC=(EENWV-SSTWV)/FLOAT(NCON-1)
      DO 930 L=1,NCON
  930 WVCON(L)=SSTWV+FLOAT(L-1)*DELC
      LCONT=1
  932 CONTINUE
      DO WHILE (LCONT.LE.NCON)
      WL=WVCON(LCONT)
  928 CONTINUE
      FREQ=2.997925E17/WL
      FREQLG=DLOG(FREQ)
      DO 61 J=1,NRHOX
      EHVKT(J)=EXP(-FREQ*HKT(J))
      STIM(J)=1.-EHVKT(J)
      BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)
   61 CONTINUE
C     CALCULATES CONTINUOUS OPACITIES
      N=1
      CALL KAPP(N,NSTEPS,STEPWT)
      DO 991 J=1,NRHOX
      SAVEAL(J)=ALINE(J)
      ALINE(J)=0.0
  991 CONTINUE
C     CALCULATES THE SOURCE FUNCTION AND SURFACE FLUX OR SURFACE INTENSI
      CALL JOSH(IFSCAT,IFSURF)
      IF(IFSURF.LT.2)CONTIN=HNU(1)
      IF(IFSURF.EQ.2)CONTIN=SURFI(1)
C     CALL W(6HCONTIN,CONTIN,1)
C     TREAT HYDROGEN LINES AS CONTINUUM
      IF(IFSCAT.EQ.0.)GO TO 162
      DO 63 J=1,NRHOX
      SCONT(J)=(ACONT(J)*SCONT(J)+ALINE(J)*SLINE(J))/(ACONT(J)+ALINE(J))
      ACONT(J)=ACONT(J)+ALINE(J)
      SLINE(J)=BNU(J)
   63 CONTINUE
      GO TO 164
C     SOURCE FUNCTION WILL BE WEIGHTED MEAN OF CONTINUUM SOURCE
C        FUNCTION (INCLUDING JNU) AND BNU
  162 DO 163 J=1,NRHOX
      SCONT(J)=SNU(J)
      SLINE(J)=BNU(J)
  163 ACONT(J)=ACONT(J)+ALINE(J)
  164 CONTINUE
      DO 917 J=1,NRHOX
      AHSAVE(LCONT,J)=SAVEAL(J)
  917 ACONSV(LCONT,J)=ACONT(J)
      IF(LCONT.NE.MIDCON) GO TO 919
      CALL INTEG(RHOX,ACONT,TAUNU,NRHOX,ACONT(1)*RHOX(1))
      DO 918 J=1,NRHOX
      IF(TAUNU(J).GT.TAUREF) GO TO 973
  918 CONTINUE
  973 JREF=J
c      WRITE(6,3456) JREF,TAU5(JREF),DLOG10(TAU5(JREF))
c 3456 FORMAT(1H ,3X,'JREF=',I3,3X,'TAU5=',1PE11.4,3X,'LOG TAU5=',0PF8.4)
  919 CONTINUE
      CONFLX(LCONT)=CONTIN
      DO 915 J=1,NRHOX
      SV1(J,LCONT)=EHVKT(J)
      SV2(J,LCONT)=STIM(J)
      SV3(J,LCONT)=BNU(J)
      SV4(J,LCONT)=SCONT(J)
      SV5(J,LCONT)=ACONT(J)
  915 SV6(J,LCONT)=SIGMAC(J)
      LCONT=LCONT+1
      END DO
      DELTA=(EENWV-SSTWV)/FLOAT(NPOINT-1)
      DO 910 K=1,NPOINT
  910 WLTH(K)=SSTWV+FLOAT(K-1)*DELTA
c      DO 911 K=2,NPOINT-1
c      KC=INT((WLTH(K)-SSTWV)/DELC)+1
c      IF(ABS(WLTH(K)-WVCON(KC+1)).LE.ABS(WLTH(K)-WVCON(KC))) THEN
c      KCSV(K)=KC+1
c      ELSE
c      KCSV(K)=KC
c      END IF
c  911 CONTINUE
c      KCSV(1)=1
c      KCSV(NPOINT)=NCON
      do k=2,npoint-1
      kc=int((wlth(k)-sstwv)/delc)+1
      kcsv(k)=kc
      end do
      kcsv(1)=1
      kcsv(npoint)=ncon-1
C
ccc      WRITE(30,872) NPOINT,'NPOINT'
ccc      WRITE(30,872) NCON,'NCON'
ccc      WRITE(30,871) SSTWV,EENWV
cc      WRITE(30) NPOINT
cc      WRITE(30) NCON
cc      WRITE(30) SSTWV,EENWV
cc      NSEP=0
C
      DO 926 K=1,NPOINT
      DO 927 J=1,NRHOX
cc      SABCO(J,K)=0.0
  927 PABCO(J,K)=0.0
  926 CONTINUE
C
      DO 268 IC=1,99
  268 xabund0(IC)=xabund(IC)
C     changing the abundances as specified
      DO 269 IV=1,NVAR
      DO 270 IC=1,99
  270 IF(NCODE(IV).EQ.IC) xabund0(IC)=xabund(IC)*EXP10(DEPSL(IV))
  269 CONTINUE
C
        open (unit=4,file='cpanel.txt')
        write(4,'(a60,a11)') fnobspec_org,'|(fnobspec)'
        write(4,'(a60,a10)')  fnmodel,'|(fnmodel)'
        write(4,'(a60,a10)')  fnlines,'|(fnlines)'
        write(4,'(i1,59x,''|(ifmole)'')') ifmole
        write(4,'(a)') '#CPANEL@'
        write(4,'(a)') '# << xi/abundance data used for synthesis>>'
        write(4,'(a)') '# (Recommending to change to overwrite mode)'
        write(4,'(a)') '# '
        write(4,'(a)') '# What you can edit is from columns 7 to 12'
        write(4,'(a)') '#                      ~~~~~~~~~~~~~~~~~~~~'
        write(4,'(a)') '# (logarithmic abundance change relative to'
        write(4,'(a)') '# the standard abundance of the model)'
        write(4,'(a)') '# '
        write(4,'(a)') '# Touching other parts is meaningless,'
        write(4,'(a)') '# since they are to be filled by the program'
        write(4,'(a)') '# '
        write(4,'(a)') '#     @@@@@@'
        write(4,'(a)') '# '
        write(4,'(6x,f6.2,f6.1,f8.0,i4,''  ! xi, vw, rp, ifabs'')')
     &  xi,vw,rp,ifabs
        do iv=1,nvar
        ela=log10(xabund0(iv)/xabund0(1))+12.
        if(iv.ge.3) then
          els=log10(xabund(iv)/xscale/xabund(1))+12.
        else
          els=log10(xabund(iv)/xabund(1))+12.
        end if
        elx=log10(xabund(iv)/xabund(1))+12.
        write(4,1809) elem(iv),ncode(iv),depsl(iv),ela,elx,xscale,els
 1809   format(a2,i4,f6.2,f8.2,3x,'( mdl:',f6.2,' [xscale=',
     &  f10.5,']  std:',f6.2,' )')
        end do
        close (4)

      nvt=1
      VTS(1)=0
      WLNS=WLA1/10.*(1.-CBV/2.997925E5)
      WLNE=WLA2/10.*(1.+CBV/2.997925E5)
      ide=0
      open (unit=9,file=fnlines)
      REWIND 9
      NUML=0
      write(*,'(''First, summing-up the line opacities ..... '')') 
c--------- start of the loop ------------
      do while (1)
c!      READ(9,7760,END=199) WL,GFLOG,CODE,EXLOW,XJLOW,EXUP,XJUP,molcode
c! 7760 FORMAT(F11.4,F7.3,F6.2,2(F12.3,F5.1,11X),a10)
c!      if(code.le.0.) read(molcode,*) code
      read(9,'(a)',end=199) line120
      call lablen(line120,120,nsln,neln)
      if(ifnum(line120(nsln:nsln)).eq.0) cycle
      logfcor=.false.
      dgfl=0.
      if(scan(line120,'@')*scan(line120,'&').ne.0) then
        logfcor=.true.
        iat=index(line120,'@')
        ish=index(line120,'&')
        read(line120(iat+1:ish-1),*) dgfl
      end if
      read(line120,*) code,wla,expot,gflog,gammar,gammas,gammaw
      if(logfcor) gflog=gflog+dgfl

      dlgamr=0.
      if (gammar.gt.90..and.gammar.lt.110.) then
      dlgamr=gammar-100.
      gammar=0.
      end if

      dlgams=0.
      if (gammas.gt.90..and.gammas.lt.110.) then
      dlgams=gammas-100.
      gammas=0.
      end if

      dlgamw=0.
      if (gammaw.gt.90..and.gammaw.lt.110.) then
      dlgamw=gammaw-100.
      gammaw=0.
      end if

      wl=wla/10.
      IF(WL.LT.WLNS.OR.WL.GT.WLNE) CYCLE
      NUML=NUML+1
      IJEL=INT(CODE+0.5)
      KLEL=INT((CODE-FLOAT(IJEL))*100.+0.5)
c!      EXPOT=DMIN1(EXLOW,EXUP)*1.23981E-4
C     ESTIMATE NELION
      MDUM=CODE*100.0+0.5
      MION=MOD(MDUM,100)
      MELM=(MDUM-MION)/100
      NELION=6*(MELM-1)+MION+1
C     WRITE(6,*) 'NELION=',NELION
      GF=EXP(GFLOG*2.30258509299405E0)
      EPUP=EXPOT+1.23981E3/WL
      ELO=EXPOT/1.23981E-4
      E=ELO
      EP=EPUP/1.23981E-4
c!C*****  ASSUMED *****
c!      GAMMAR=0.
c!      GAMMAS=0.
c!      GAMMAW=0.
c!C********************

      gamsvr=gammar
      gamsvs=gammas
      gamsvw=gammaw

      GAMMAR=EXP(GAMMAR*2.30258509299405E0)
      GAMMAS=EXP(GAMMAS*2.30258509299405E0)
      GAMMAW=EXP(GAMMAW*2.30258509299405E0)
C     CLASSICAL DAMPING CONSTANT
      IF(GAMMAR.EQ.1.)GAMMAR=2.223E13/WL**2
      IF(GAMMAS.NE.1..AND.GAMMAW.NE.1.)GO TO 141
      IF(GAMMAS.NE.1.)GO TO 138
      IF(CODE.GE.100.)GO TO 137
c      ZEFF=(CODE-FLOAT(IFIX(CODE)))*100.+1.
      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.
      EFFNSQ=25.
      DEPUP=POTION(NELION)-EPUP
      IF(DEPUP.GT.0.)EFFNSQ=13.595*ZEFF**2/DEPUP
      GAMMAS=1.0E-8*EFFNSQ**2*SQRT(EFFNSQ)
      GO TO 138
  137 GAMMAS=1.0E-5
  138 IF(GAMMAW.NE.1.)GO TO 141
      IF(CODE.GE.100.)GO TO 139
c      ZEFF=(CODE-FLOAT(IFIX(CODE)))*100.+1.
      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.
      EFFNSQ=25.
      DEPUP=POTION(NELION)-EPUP
      IF(DEPUP.GT.0.)EFFNSQ=13.595*ZEFF**2/DEPUP
      RSQ=2.5*(EFFNSQ/ZEFF)**2
      NSEQ=CODE-ZEFF+1.5
C     WRITE(6,*) 'NSEQ=',NSEQ
      IF(NSEQ.GT.20.AND.NSEQ.LT.29)RSQ=(45.-FLOAT(NSEQ))/ZEFF
      GAMMAW=4.5E-9*RSQ**.4
      GO TO 141
  139 GAMMAW=1.E-7/ZEFF
  141 GLOGR=DLOG10(GAMMAR)
C     CALL W(6HGLOGR ,GLOGR,1)
      GLOGS=DLOG10(GAMMAS)
C     CALL W(6HGLOGS ,GLOGS,1)
      GLOGW=DLOG10(GAMMAW)
C     CALL W(6HGLOGW ,GLOGW,1)

      if(gamsvr.eq.0.) then
        glogr=glogr+dlgamr
        GAMMAR=EXP(glogr*2.30258509299405E0)
        if (dlgamr.lt.0.) write(lbgr,'(''d-'',f4.2)') abs(dlgamr)
        if (dlgamr.eq.0.) write(lbgr,'(''  '',f4.2)') abs(dlgamr)
        if (dlgamr.gt.0.) write(lbgr,'(''d+'',f4.2)') abs(dlgamr)
      else
        write(lbgr,'(f6.2)') glogr
      end if

      if(gamsvs.eq.0.) then
        glogs=glogs+dlgams
        GAMMAS=EXP(glogs*2.30258509299405E0)
        if (dlgams.lt.0.) write(lbgs,'(''d-'',f4.2)') abs(dlgams)
        if (dlgams.eq.0.) write(lbgs,'(''  '',f4.2)') abs(dlgams)
        if (dlgams.gt.0.) write(lbgs,'(''d+'',f4.2)') abs(dlgams)
      else
        write(lbgs,'(f6.2)') glogs
      end if

      if(gamsvw.eq.0.) then
        glogw=glogw+dlgamw
        GAMMAW=EXP(glogw*2.30258509299405E0)
        if (dlgamw.lt.0.) write(lbgw,'(''d-'',f4.2)') abs(dlgamw)
        if (dlgamw.eq.0.) write(lbgw,'(''  '',f4.2)') abs(dlgamw)
        if (dlgamw.gt.0.) write(lbgw,'(''d+'',f4.2)') abs(dlgamw)
      else
        write(lbgw,'(f6.2)') glogw
      end if

      FREQ=2.997925E17/WL
      FREQLG=DLOG(FREQ)
      DO 161 J=1,NRHOX
      EHVKT(J)=EXP(-FREQ*HKT(J))
      STIM(J)=1.-EHVKT(J)
      BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)
  161 CONTINUE
      CALL LINCEN(ABUND1,VTS,NVT)
C
cc      LOSEP=.FALSE.
cc      DO 880 L=1,NELV
cc      IF(IJEL.EQ.ICD(L)) THEN
cc      LOSEP=.TRUE.
cc      GO TO 881
cc      END IF
cc  880 CONTINUE
cc      GO TO 832
cc  881 NSEP=NSEP+1
cc      write(6,9875) nsep,ijel,klel,wl,expot,gflog
cc 9875 format(1h ,'#### nsep=',i4,' #### ',2i4,f9.3,f7.2,f7.3)
ccc      WRITE(30,875) NSEP
ccc  875 FORMAT('####',I4,'  NSEP  ####')
ccc      WRITE(30,874) IJEL,KLEL,WL,EXPOT,GFLOG
ccc  874 FORMAT(2I4,F9.3,F7.2,F7.3)
ccc      WRITE(30,870) (BNU(J),J=1,NRHOX)
ccc      WRITE(30,870) (LINE0(1,J),J=1,NRHOX)
ccc      WRITE(30,870) (DOPWAV(1,J),J=1,NRHOX)
ccc      WRITE(30,870) (ADAMP(1,J),J=1,NRHOX)
cc      WRITE(30) NSEP
cc      WRITE(30) IJEL,KLEL,WL,EXPOT,GFLOG
cc      WRITE(30) (BNU(J),J=1,NRHOX)
cc      WRITE(30) (LINE0(1,J),J=1,NRHOX)
cc      WRITE(30) (DOPWAV(1,J),J=1,NRHOX)
cc      WRITE(30) (ADAMP(1,J),J=1,NRHOX)
cc  832 CONTINUE
C
      KCT=(WL-SSTWV)/DELC+1.000D0
      KCT=MAX0(1,KCT)
      KCT=MIN0(NCON,KCT)
      if(code.lt.100.) then
        elm=elem(ijel)
        xabmul=xabund0(ijel)
        tatmas=atmass(ijel)
      else
        call calzam(ijel,elm,tatmas,mola,iza)
        xabmul=1.
        do i=1,mola
          xabmul=xabmul*xabund0(iza(i))
        end do
      end if
      DO 922 J=1,NRHOX
      ETA0(J)=xabmul*LINE0(1,J)/ACONSV(MIDCON,J)
c      IF(ETA0(J).LT.ETACRT) GO TO 922
      IF(ETA0(J).LT.ETACRT.or.code.eq.1.00) GO TO 922
      DOPCOR=SQRT(1.0+60.1391*tatmas*XI**2/T(J))
      ETA1=ETA0(J)/DOPCOR
      DMW=1.0E-3*DOPWAV(1,J)*SQRT(ETA0(J)*ADAMP(1,J)/ETACRT*.56419)
      MK1=(WL-SSTWV-DMW)/DELTA
      MK2=(WL-SSTWV+DMW)/DELTA
      KMN=MAX0(MK1,1)
      KMN=MIN0(KMN,NPOINT)
      KMX=MIN0(MK2+1,NPOINT)
      KMX=MAX0(KMX,1)
      DO 923 K=KMN,KMX
      V=ABS(WLTH(K)-WL)*1.0E3/(DOPWAV(1,J)*DOPCOR)
      DUM=xabmul*(LINE0(1,J)/DOPCOR)*VOIGT(V,ADAMP(1,J)/DOPCOR)
      PABCO(J,K)=PABCO(J,K)+DUM
cc      IF(LOSEP) GO TO 923
cc      SABCO(J,K)=SABCO(J,K)+DUM
  923 CONTINUE
  922 CONTINUE
c     special for HI line
      if(code.eq.1.00) eta0(jref)=1000.000000
c
      iion=klel+1
        if(eta0(jref).gt.etacrt) then
        ide=ide+1
          if(ide.gt.MAXIDE) then
          write(*,*) 'Too large ide'
          cycle
c          stop
          end if
        if(wl*10..lt.10000.) then
         write(lnident(ide),'(a2,i1,f9.3,f12.6,f10.2,2f7.3,3a6)')
     &   elm,iion,wl*10.,min(9999.999999,eta0(jref)),code,expot,gflog,
     &   lbgr,lbgs,lbgw
        else
         write(lnident(ide),'(a2,i1,f9.2,f12.6,f10.2,2f7.3,3a6)')
     &   elm,iion,wl*10.,min(9999.999999,eta0(jref)),code,expot,gflog,
     &   lbgr,lbgs,lbgw
        end if
        end if
Cx      IION=KLEL+1
Cx      WRITE(*,941) WL,elm,IION,ETA0(JREF),EXPOT,GFLOG,
Cx     #GLOGR,GLOGS,GLOGW
Cx  941 FORMAT(F9.3,1X,A2,I1,2X,1PE10.3,5X,0P5F8.2,10X)
        end do
c--------- end of the loop ------------
  199 nlines=numl
      nide=ide
      close (9)
C
ccc      WRITE(30,876)
ccc  876 FORMAT('@@@@ CONT DATA FOLLOW @@@@')
ccc      WRITE(30,872) NCON,'NCON'
ccc***** if nsel to be read is -999 then end of line data *****
cc      ieflg=-999
cc      write(30) ieflg
cc      WRITE(30) NCON
cc      DO 890 II=1,NCON
cc      JJ=II
cc      DO 891 J=1,NRHOX
cc      EHVKT(J)=SV1(J,JJ)
cc      STIM(J)=SV2(J,JJ)
cc      BNU(J)=SV3(J,JJ)
cc      SCONT(J)=SV4(J,JJ)
cc      ACONT(J)=SV5(J,JJ)
cc  891 SIGMAC(J)=SV6(J,JJ)
ccc      WRITE(30,872) JJ,'JJ'
ccc      WRITE(30,870) (EHVKT(J),STIM(J),BNU(J),SCONT(J),ACONT(J),
ccc     #SIGMAC(J),J=1,NRHOX)
cc      WRITE(30) JJ
cc      WRITE(30) (EHVKT(J),STIM(J),BNU(J),SCONT(J),ACONT(J),
cc     #SIGMAC(J),J=1,NRHOX)
cc  890 CONTINUE
ccc      WRITE(30,878)
ccc  878 FORMAT('@@@@ LINE OPACITY DATA (SABCO) FOLLOW @@@@')
C
c      LCONT=0
      write(*,'(''Now calculating the emergent spectrum ..... '')') 
      DO 953 K=1,NPOINT
c      IF(KCSV(K).EQ.LCONT) GO TO 955
      LCONT=KCSV(K)
      DO 914 J=1,NRHOX
      EHVKT(J)=SV1(J,LCONT)
      STIM(J)=SV2(J,LCONT)
      BNU(J)=SV3(J,LCONT)
      SCONT(J)=SV4(J,LCONT)
      ACONT(J)=SV5(J,LCONT)
  914 SIGMAC(J)=SV6(J,LCONT)
      DO 954 J=1,NRHOX
  954 SLINE(J)=BNU(J)
c  955 CONTINUE
      DO 956 J=1,NRHOX
  956 ALINE(J)=PABCO(J,K)
      IF(IFOP(14).EQ.0) GO TO 938
c---                     
      call retenv("DAT_DIR",linedir)
      call lablen(linedir,80,nsdir,nedir)
      inquire (file=linedir(nsdir:nedir)//'\'//'vcslemke.bdf',
     & exist=lovcsex)
      inquire (file=linedir(nsdir:nedir)//'\'//'vcsbalm.dat',
     & exist=lovbalm)     
        do j=1,nrhox
          ahline(j)=0.
        end do
        wlam=wlth(k)*10.
        FREQ=2.997925E17/wlth(k)                                               
        FREQLG=DLOG(FREQ)                                                 
        DO J=1,NRHOX                                                   
          EHVKT(J)=EXP(-FREQ*HKT(J))                                        
          STIM(J)=1.0-EHVKT(J)                                              
          BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)                       
        END DO                                                          

        if(wlam.ge.4035..and.wlam.lt.(4101.74+100.)) then
          line=4
        else if(wlam.ge.(4340.47-100.).and.wlam.lt.(4340.47+100.)) then
          line=3
        else if(wlam.ge.(4861.33-100.).and.wlam.lt.(4861.33+100.)) then
          line=2
        else if(wlam.ge.(6562.73-100.).and.wlam.lt.(6562.73+100.)) then
          line=1
        else
          line=0
        end if
        if(line.le.0) then
          call hlinop
        else
          call balmer(line,wlam)
        end if

       do j=1,nrhox
         aline(j)=aline(j)+ahline(j)
c         sabco(j,k)=sabco(j,k)+ahline(j)
       end do
c---

c      LCT=LCONT
c      IF(LCT.EQ.NCON) LCT=NCON-1
c      DO 939 J=1,NRHOX
c      DUM=AHSAVE(LCONT,J)+(WLTH(K)-WVCON(LCONT))*
c     #(AHSAVE(LCONT+1,J)-AHSAVE(LCONT,J))/(WVCON(LCONT+1)-WVCON(LCONT))
c      idum=map1(wvcon,ahsave(1,j),ncon,wlth(k),dum,1)
c      ALINE(J)=ALINE(J)+DUM
cc      SABCO(J,K)=SABCO(J,K)+DUM
c  939 CONTINUE
  938 CONTINUE
C
ccc      WRITE(30,877) K,WLTH(K)
ccc  877 FORMAT('WLTH(',I4,')=',F8.3,'   SABCO DATA ')
ccc      WRITE(30,870) (SABCO(J,K),J=1,NRHOX)
cc      WRITE(30) K,WLTH(K)
cc      WRITE(30) (SABCO(J,K),J=1,NRHOX)
C
      CALL JOSH(IFSCAT,IFSURF)

      AINT(K)=HNU(1)
      RESIDF(K)=AINT(K)/CONFLX(LCONT)
  953 CONTINUE
c     computes the absolute HLAM flux (erg/cm^2/s/A) for the case of ifabs=1
      do k=1,npoint
        absf(k)=aint(k)*2.997925e10/(wlth(k)*1.e-7)**2*1.e-8
      end do
C
      ifsynfin=1
      iabsfirst=1
      RETURN
      END
      FUNCTION EXP10(X)
      IMPLICIT REAL*8 (A-H,O-Z)
      EXP10=EXP(X*2.30258509299405D0)
      RETURN
      END
      SUBROUTINE COG(IVT,ABLG,TAULG)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      COMMON /CONTIN/CONTIN
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV
      LOGICAL LOCONV
      REAL*8 MINLOG
      COMMON /GAM/GLOGR,GLOGS,GLOGW
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,
     2               X2,OTHER1,OTHER2,ELO,GF
      COMMON /OBS/EW,WLOBS,STAR(9)
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)
      COMMON /TAUBAR/TAUBAR
      COMMON /VTS/VTS(3),NVT
      COMMON /XLABEL/LAB,EXPOT
      COMMON /ABDIF/ABCOR
      COMMON /PLOTCG/MODECG,PDATA(9,3,2)
      DIMENSION SEWLOG(9)
      DIMENSION ABLOG(9),EWLOG(9),TAULOG(9)
      DIMENSION RESID0(9)
      DIMENSION WDOLM(9)
      DIMENSION PEWLOG(9),PABLOG(9)
      CHARACTER STAR*8,LAB*28
C
      IF(NABLOG.EQ.0)GO TO 63
      ABLOG(1)=MINLOG
      EWLOG(1)=DLOG10(WID(EXP10(ABLOG(1)),IVT))
      RESID0(1)=RESIDU(1)
      TAULOG(1)=DLOG10(TAUBAR)
      IF(NABLOG.EQ.1) GO TO 23
      DO 162 I=2,NABLOG
      ABLOG(I)=ABLOG(I-1)+DABLOG
      EWLOG(I)=DLOG10(WID(EXP10(ABLOG(I)),IVT))
      RESID0(I)=RESIDU(1)
  162 TAULOG(I)=DLOG10(TAUBAR)
   23 CONTINUE
      NAB=NABLOG
      OBEWLG=0.
      GO TO 76
   63 OBEWLG=DLOG10(EW)
      ABLOG(1)=ABLG
      EWLOG(1)=DLOG10(WID(EXP10(ABLOG(1)),IVT))
      TAULOG(1)=DLOG10(TAUBAR)
      IF(EWLOG(1).GT.OBEWLG)GO TO 71
      ABLOG(2)=ABLOG(1)+1.
      EWLOG(2)=DLOG10(WID(EXP10(ABLOG(2)),IVT))
      TAULOG(2)=DLOG10(TAUBAR)
      ABLOG(3)=ABLOG(2)+1.
      IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5
      GO TO 72
   71 ABLOG(2)=ABLOG(1)-1.
      EWLOG(2)=DLOG10(WID(EXP10(ABLOG(2)),IVT))
      TAULOG(2)=DLOG10(TAUBAR)
      ABLOG(3)=ABLOG(2)+.5
      IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5
   72 EWLOG(3)=DLOG10(WID(EXP10(ABLOG(3)),IVT))
      TAULOG(3)=DLOG10(TAUBAR)
      DO 73 IAB=3,8
      NAB=IAB
      IF(ABS(OBEWLG-EWLOG(IAB)).LT..005)GO TO 76
      NAB1=NAB-1
      DO 79 KK=1,NAB1
      DO 79 II=1,NAB1
      IF(ABLOG(II+1).GE.ABLOG(II))GO TO 79
      DUMMY=ABLOG(II+1)
      ABLOG(II+1)=ABLOG(II)
      ABLOG(II)=DUMMY
      DUMMY=EWLOG(II+1)
      EWLOG(II+1)=EWLOG(II)
      EWLOG(II)=DUMMY
      DUMMY=TAULOG(II+1)
      TAULOG(II+1)=TAULOG(II)
      TAULOG(II)=DUMMY
   79 CONTINUE
      DO 80 I=2,NAB
      K=I
      IF(OBEWLG.LT.EWLOG(I))GO TO 81
   80 CONTINUE
   81 ABLOG(NAB+1)=ABLOG(K-1)+(ABLOG(K)-ABLOG(K-1))/(EWLOG(K)-EWLOG(K-1)
     1)*(OBEWLG-EWLOG(K-1))
      EWLOG(IAB+1)=DLOG10(WID(EXP10(ABLOG(IAB+1)),IVT))
   73 TAULOG(IAB+1)=DLOG10(TAUBAR)
      WRITE(6,75)
   75 FORMAT(//14H NOT CONVERGED)
      NAB=NAB+1
   76 CONTINUE
C     CONVERT LOG(N/NT) TO LOG(N/NH)+12
C     CONVERT PM TO MA AND NM TO A
      EEW=EW*10.0
      WWL=WL*10.0
      DO 85 IAB=1,NAB
      PEWLOG(IAB)=EWLOG(IAB)+1.0
   85 PABLOG(IAB)=ABLOG(IAB)+12.0-ABCOR
      WRITE(6,3333) CODE,WWL,EXPOT,GFLOG,GLOGR,GLOGS,GLOGW,LAB
 3333 FORMAT(1H0,5X,'EL:',F5.2,5X,'WL:',F9.3,5X,'CHI:',F5.2,5X,
     1 'LOGGF:',F6.3,5X,'GRLOG:',F6.2,5X,'GSLOG:',F6.2,5X,
     2 'GWLOG:',F6.2,5X/10X,'LABEL:'A28/)
      IF(NABLOG.EQ.0) WRITE(6,820) EEW,PABLOG(NAB)
  820 FORMAT(1H0,10X,'***** FOR OBSERVED E.W. ',F6.1,' M.A.  ',
     1 'LOG(N/NH)+12 IS ',F6.2,' *****'/)
      WRITE(6,77)(PABLOG(IAB),IAB=1,NAB)
   77 FORMAT(9X,5HVTURB,2X,5HABUND,9F9.2)
      WRITE(6,78)VTS(IVT),(PEWLOG(IAB),IAB=1,NAB)
   78 FORMAT(9X,F5.2,2X,'EWLOG',9F9.3)
      ALGWL=DLOG10(WWL)
      DO 113 IAB=1,NAB
      WDOLM(IAB)=PEWLOG(IAB)-ALGWL-3.0
      SEWLOG(IAB)=PEWLOG(IAB)
  113 PEWLOG(IAB)=EXP10(PEWLOG(IAB))
      WRITE(6,114)(PEWLOG(IAB),IAB=1,NAB)
  114 FORMAT(18X,'EW ',9F9.2)
      WRITE(6,177)(TAULOG(IAB),IAB=1,NAB)
  177 FORMAT(16X,5HLGTAU,9F9.2)
      IF(NABLOG.GT.0)WRITE(6,178)(RESID0(IAB),IAB=1,NAB)
  178 FORMAT(16X,5HRESID,9F9.2)
      IF(NABLOG.GT.0) WRITE(6,179) (WDOLM(IAB),IAB=1,NAB)
  179 FORMAT(14X,'LG(W/L)',9F9.2)
      ABLG=PABLOG(NAB)
      TAULG=TAULOG(NAB)
      IF(MODECG.EQ.0) RETURN
      IF(MODECG.EQ.2) GO TO 182
      DO 181 I=1,NABLOG
      PDATA(I,IVT,1)=PABLOG(I)
  181 PDATA(I,IVT,2)=SEWLOG(I)
      RETURN
  182 DO 183 I=1,NABLOG
  183 PABLOG(I)=PABLOG(I)+GFLOG
      DO 184 I=1,NABLOG
      PDATA(I,IVT,1)=PABLOG(I)
  184 PDATA(I,IVT,2)=WDOLM(I)
      RETURN
      END
      FUNCTION WID(ABUND,IVT)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL
      COMMON /MUS/ANGLE(20),SURFI(20),NMU
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),
     1              SIGMAL(kw)
      COMMON /RHOX/RHOX(kw),NRHOX
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)
      REAL*8 JNU,JMINS
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,
     1               IFTURB
C
      COMMON /CONTIN/CONTIN
      COMMON /IFPROF/IFPROF
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,
     2               X2,OTHER1,OTHER2,ELO,GF
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)
      REAL*8 LINE0
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)
      COMMON /TAUBAR/TAUBAR
      COMMON /VTS/VTS(3),NVT
      DIMENSION DEL(15),WEIGHT(15),ALINE0(kw)
      DIMENSION PDELS(15)
C     IN PM
      DATA DEL/0.,.5,1.,1.5,2.,2.5,3.,3.5,4.,4.5,5.,6.25,7.5,8.75,10./
      DATA WEIGHT/.166667,.666667,.333333,.666667,.333333,.666667,
     1.333333,.666667,.333333,.666667,.583333,1.666667,.833333,1.666667,
     2 10.416667/
c      EXP10(X)=EXP(X*2.30258509299405E0)
      DO 1 J=1,NRHOX
    1 ALINE0(J)=LINE0(IVT,J)*ABUND
      ASSIGN 73 TO ISWTCH
C     MICROTURBULENCE IN PM
      DOPVT=(VTS(IVT)*(1.E5/2.997925E10))*(WL*1000.)
      SCALE=SQRT(2.5**2+DOPVT**2)/2.5
      DO 70 MDUMMY=1,10
      CCC=5.*SCALE
      DO 71 J=1,NRHOX
   71 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))
      CALL JOSH(IFSCAT,IFSURF)
      IF(IFSURF.LT.2)RESID=HNU(1)/CONTIN
      IF(IFSURF.EQ.2)RESID=SURFI(1)/CONTIN
      IF(MDUMMY.EQ.1)GO TO 75
      IF(RESID.GT..93)GO TO 74
      GO TO ISWTCH,(73,76)
   75 IF(RESID.GE..91)GO TO 80
   73 SCALE1=SCALE
      SCALE=SCALE*2.
      ASSIGN 73 TO ISWTCH
      GO TO 70
   74 SCALE2=SCALE
      SCALE=(SCALE1+SCALE2)/2.
      ASSIGN 76 TO ISWTCH
      GO TO 70
   76 SCALE1=SCALE
      SCALE=(SCALE1+SCALE2)/2.
   70 CONTINUE
   80 WIDTH=0.
      TAUSUM=0.
      DO 81 I=1,15
      CCC=DEL(I)*SCALE
      DELWAV(I)=CCC
      DO 82 J=1,NRHOX
   82 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))
      CALL JOSH(IFSCAT,IFSURF)
      IF(IFSURF.LT.2)RESIDU(I)=HNU(1)/CONTIN
      IF(IFSURF.EQ.2)RESIDU(I)=SURFI(1)/CONTIN
      MAX=MAP1(TAUNU,TAUROS,NRHOX,1.,TAUONE(I),1)
      TAUONE(I)=DLOG10(TAUONE(I))
      TAUSUM=TAUSUM+WEIGHT(I)*TAUONE(I)*(1.-RESIDU(I))
   81 WIDTH=WIDTH+WEIGHT(I)*(1.-RESIDU(I))
      TAUBAR=EXP10(TAUSUM/WIDTH)
      WID=WIDTH*SCALE*2.
      IF(IFPROF.EQ.0)RETURN
C     CONVERT PM TO MA
      DO 85 I=1,15
   85 PDELS(I)=DELWAV(I)*10.0
      WRITE(6,87)PDELS,TAUONE,RESIDU
   87 FORMAT(1H0,17X,3HDEL,15F7.2/16X,5HLGTAU,15F7.3/16X,5HRESID,15F7.3)
      RETURN
      END

      subroutine calzam(ijel,elm,tatmas,mola,iza)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)
      character*2 elem
      dimension xcode(8),iza(8)
      DATA XCODE/1.E14,1.E12,1.E10,1.E8,1.E6,1.E4,1.E2,1.E0/
      character*2 elm
      character*1 eq(2)
      c=dfloat(ijel)
      do 11 ii=1,8
      if(c.ge.xcode(ii)) go to 12
   11 continue
      call exit
   12 continue
      ia=0
      am=0.
      do 13 i=ii,8
      id=c/xcode(i)
      am=am+atmass(id)
      ia=ia+1
      iza(ia)=id
      c=c-dfloat(id)*xcode(i)
   13 continue
      mola=ia
      tatmas=am
      if(mola.eq.1) elm=elem(iza(1))
      if(mola.eq.2) then
        do j=1,2
          if(iza(j).gt.0) then
            eq(j)=elem(iza(j))
          else
            eq(j)='-'
          end if
        end do
        elm=eq(1)//eq(2)
        if(eq(1).eq.'H') elm=eq(2)//eq(1)
      end if
      if(mola.eq.3) elm='tt'
      if(mola.eq.4) elm='xx'
      return
      end

      SUBROUTINE LINCEN(ABUND1,VTS,NVT)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)
      character*2 elem
      COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw)
      COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3)
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL
      COMMON /RHOX/RHOX(kw),NRHOX
      COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)
      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,
     1               IFTURB
      COMMON /XABUND/XABUND(99),WTMOLE
C
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,
     2               X2,OTHER1,OTHER2,ELO,GF
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)
      REAL*8 LINE0
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)
      DIMENSION VTS(3)
      DIMENSION TDOP(kw),ADAMP1(kw),LINE(kw),XNFPRC(kw),TXNXN(kw)
      REAL*8 LINE
      DIMENSION XCODE(8)
      DATA XCODE/1.E14,1.E12,1.E10,1.E8,1.E6,1.E4,1.E2,1.E0/
      DATA ITEMP1/0/
      IF(ITEMP.EQ.ITEMP1)GO TO 2
      XNFH2=0.
      DO 1 J=1,NRHOX
C     NUMBER DENSITIES FOR VAN DER WAALS BROADENING
    1 TXNXN(J)=(XNFPH(J,1)*2.+.42*XNFPHE(J,1)*1.+.85*XNFH2)*
     1(T(J)/10000.)**.3
      ITEMP1=ITEMP
      SAVE=0.
    2 IF(CODE.EQ.SAVE)GO TO 18
      AMASS=0.
      ABUND1=1.
      C=CODE
      DO 11 II=1,8
      IF(C.GE.XCODE(II))GO TO 12
   11 CONTINUE
      STOP
   12 DO 13 I=II,8
      ID=C/XCODE(I)
      if(id.eq.0) go to 13
      IF(ID.LT.100)ABUND1=ABUND1*XABUND(ID)
      AMASS=AMASS+ATMASS(ID)
      C=C-FLOAT(ID)*XCODE(I)
   13 continue
      SAVE=CODE
      CALL POPS(CODE,1,XNFPRC)
      TWOMAS=2./AMASS/1.660E-24
      DO 17 J=1,NRHOX
      XNFPRC(J)=XNFPRC(J)*(.026538/1.77245)/ABUND1/RHO(J)
   17 TDOP(J)=TK(J)*TWOMAS
   18 ELOC=ELO*2.997925E10
      DO 5 J=1,NRHOX
      ADAMP1(J)=(GAMMAR+GAMMAS*XNE(J)+GAMMAW*TXNXN(J))/12.5664
    5 LINE(J)=GF*EXP(-ELOC*HKT(J))*STIM(J)*XNFPRC(J)
      FREQC=FREQ/2.997925E10
      WAVENU=1.E10/FREQC/FREQ
      IF(VTS(1).EQ.0..AND.NVT.EQ.1)GO TO 7
      DO 6 IVT=1,NVT
      VT2=VTS(IVT)**2*1.E10
      DO 6 J=1,NRHOX
      DOPNU=SQRT(TDOP(J)+VT2)*FREQC
C     DOPWAV IS DOPLER WIDTH IN PM
      DOPWAV(IVT,J)=DOPNU*WAVENU
C     LINE ABSORPTION COEFFICIENT PER UNIT ABUNDANCE
      LINE0(IVT,J)=LINE(J)/DOPNU
    6 ADAMP(IVT,J)=ADAMP1(J)/DOPNU
      RETURN
    7 DO 8 J=1,NRHOX
      DOPNU=SQRT(TDOP(J)+VTURB(J)**2)*FREQC
      DOPWAV(1,J)=DOPNU*WAVENU
      LINE0(1,J)=LINE(J)/DOPNU
    8 ADAMP(1,J)=ADAMP1(J)/DOPNU
      RETURN
      END
      FUNCTION H(V,A)
C      FUNCTION VOIGT(V,A)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
C     INTERPOLATES FROM TABLES OF HARRIS AP.J. 1948
      DIMENSION H0(41),H1(81),H2(41)
      DATA H0 /
     1 1.0000000, 0.9900500, 0.9607890, 0.9139310, 0.8521440, 0.7788010,
     2 0.6976760, 0.6126260, 0.5272920, 0.4448580, 0.3678790, 0.2981970,
     3 0.2369280, 0.1845200, 0.1408580, 0.1053990, 0.0773050, 0.0555760,
     4 0.0391640, 0.0270520, 0.0183156, 0.0121552, 0.0079071, 0.0050418,
     5 0.0031511, 0.0019305, 0.0011592, 0.0006823, 0.0003937, 0.0002226,
     6 0.0001234, 0.0000671, 0.0000357, 0.0000186, 0.0000095, 0.0000048,
     7 0.0000024, 0.0000011, 0.0000005, 0.0000002, 0.0000001/
      DATA H1/
     1-1.1283800,-1.1059600,-1.0404800,-0.9370300,-0.8034600,-0.6494500,
     2-0.4855200,-0.3219200,-0.1677200,-0.0301200, 0.0859400, 0.1778900,
     3 0.2453700, 0.2898100, 0.3139400, 0.3213000, 0.3157300, 0.3009400,
     4 0.2802700, 0.2564800, 0.2317260, 0.207528 , 0.1848820, 0.1643410,
     5 0.1461280, 0.1302360, 0.1165150, 0.1047390, 0.0946530, 0.0860050,
     6 0.0785650, 0.0721290, 0.0665260, 0.0616150, 0.0572810, 0.0534300,
     7 0.0499880, 0.0468940, 0.0440980, 0.0415610, 0.0392500, 0.0351950,
     8 0.0317620, 0.0288240, 0.0262880, 0.0240810, 0.0221460, 0.0204410,
     9 0.0189290, 0.0175820, 0.0163750, 0.0152910, 0.0143120, 0.0134260,
     A 0.0126200, 0.0118860, 0.0112145, 0.0105990, 0.0100332, 0.0095119,
     B 0.0090306, 0.0085852, 0.0081722, 0.0077885, 0.0074314, 0.0070985,
     C 0.0067875, 0.0064967, 0.0062243, 0.0059688, 0.0057287, 0.0055030,
     D 0.0052903, 0.0050898, 0.0049006, 0.0047217, 0.0045526, 0.0043924,
     E 0.0042405, 0.0040964, 0.0039595/
      DATA H2 /
     1 1.0000000, 0.9702000, 0.8839000, 0.7494000, 0.5795000, 0.3894000,
     2 0.1953000, 0.0123000,-0.1476000,-0.2758000,-0.3679000,-0.4234000,
     3-0.4454000,-0.4392000,-0.4113000,-0.3689000,-0.3185000,-0.2657000,
     4-0.2146000,-0.1683000,-0.1282100,-0.0950500,-0.0686300,-0.0483000,
     5-0.0331500,-0.0222000,-0.0145100,-0.0092700,-0.0057800,-0.0035200,
     6-0.0021000,-0.0012200,-0.0007000,-0.0003900,-0.0002100,-0.0001100,
     7-0.0000600,-0.0000300,-0.0000100,-0.0000100, 0.0000000/
      V0=V*10.
      N=V0
      IF(N.LT.40)GO TO 1
      IF(N.LT.120)GO TO 2
      VOIGT=(.56419+.846/(V**2))/(V**2)*A
      H=VOIGT
      RETURN
    1 V1=N
      N=N+1
      V2=V0-V1
      N1=N+1
      VOIGT=V2*(H0(N1)-H0(N)+A*(H1(N1)-H1(N)+A*(H2(N1)-H2(N))))+
     1H0(N)+A*(H1(N)+A*H2(N))
      H=VOIGT
      RETURN
    2 N=N/2+20
      V1=(N-20)*2
      N=N+1
      V2=(V0-V1)/2.
      N1=N+1
      VOIGT=A*((H1(N1)-H1(N))*V2+H1(N))
      H=VOIGT
      RETURN
      END
      SUBROUTINE AVERAG(MODEAV,IVT,ABLG,TAULG)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,
     2               X2,OTHER1,OTHER2,ELO,GF
      COMMON /OBS/EW,WLOBS,STAR(9)
      COMMON /VTS/VTS(3),NVT
      COMMON ABUNDI(250,3),TAUBAR(250,3)
      DIMENSION KABUND(250,3)
      EQUIVALENCE (KABUND(1,1),ABUNDI(1,1))
      DIMENSION EPOT(250),WDTH(250)
      DIMENSION STAR1(9)
      CHARACTER*8 STAR,STAR1
      DATA NLINES/0/
c      EXP10(X)=EXP(X*2.30258509299405E0)
      IF(MODEAV.EQ.1)RETURN
      IF(MODEAV.EQ.2)GO TO 64
      IF(MODEAV.EQ.3)GO TO 30
      STOP
   64 IF(IVT.EQ.1)NLINES=NLINES+1
      ABUNDI(NLINES,IVT)=ABLG
      TAUBAR(NLINES,IVT)=TAULG
      EPOT(NLINES)=ELO*1.23981E-4
      WDTH(NLINES)=EW
      DO 25 I=1,9
   25 STAR1(I)=STAR(I)
      SAVE=CODE
      RETURN
   30 IF(NLINES.NE.1) GO TO 31
      DEV=0.
      CODE=SAVE
      WRITE(6,33)NLINES,CODE,ABLG,DEV
      GO TO 35
   31 DO 34 IVT=1,NVT
      SUMM=0.
      CSUMXY=0.
      CSUMX=0.
      CSUMXX=0.
      WSUMXY=0.
      WSUMX=0.
      WSUMXX=0.
      DO 6005 I=1,NLINES
      SUMM=SUMM+ABUNDI(I,IVT)
      CSUMXY=CSUMXY+ABUNDI(I,IVT)*EPOT(I)
      CSUMX=CSUMX+EPOT(I)
      CSUMXX=CSUMXX+EPOT(I)**2
      WSUMXY=WSUMXY+ABUNDI(I,IVT)*WDTH(I)
      WSUMX=WSUMX+WDTH(I)
      WSUMXX=WSUMXX+WDTH(I)**2
 6005 CONTINUE
      X=NLINES
      WB=( X*WSUMXY-WSUMX*SUMM)/(X*WSUMXX-WSUMX**2)
      CB=(X*CSUMXY-CSUMX*SUMM)/(X*CSUMXX-CSUMX**2)
      AVABN=SUMM/X
      SUM=0.
      DO 32 I=1,NLINES
   32 SUM=SUM+(AVABN-ABUNDI(I,IVT))**2
      DEV=SQRT(SUM/X)
      DO 26 I=1,6
   26 STAR(I)=STAR1(I)
      CODE=SAVE
      WRITE(6,1111)VTS(IVT),STAR
 1111 FORMAT(6H1VTURB,F6.3,3X,9A8)
      WRITE(6,33)NLINES,CODE,AVABN,DEV
   33 FORMAT(///26H ***** THE ABUNDANCE FROM I3,2X,F11.2,9H LINES IS,
     1 F7.2,3H+/-,F5.2)
      WRITE(6,6006)
 6006 FORMAT(//5X,17HLOG ABUND VS. CHI)
      DO 50 I=1,NLINES
   50 KABUND(I,IVT)=(AVABN-ABUNDI(I,IVT))*50.+51.5
      WRITE(6,6009)CB,NLINES
 6009 FORMAT(5X,7H SLOPE=,E10.3,14H PER EV USING ,I4,6H LINES)
      CALL PLOTIT(AVABN,KABUND(1,IVT),EPOT,NLINES)
      WRITE(6,1111)VTS(IVT),STAR
      WRITE(6,6007)
 6007 FORMAT(//5X,23HLOG ABUND VS. EQ. WIDTH)
      WRITE(6,6008)WB,NLINES
 6008 FORMAT(5X,7H SLOPE=,E10.3,14H PER MA USING ,I4,6H LINES)
      CALL PLOTIT(AVABN,KABUND(1,IVT),WDTH,NLINES)
      WRITE(6,1111)VTS(IVT),STAR
      WRITE(6,1112)
 1112 FORMAT(//5X,24HLOG ABUND VS. LOG HEIGHT)
      CALL PLOTIT(AVABN,KABUND(1,IVT),TAUBAR(1,IVT),NLINES)
   34 CONTINUE
   35 NLINES=0
      MODEAV=1
      WRITE(6,3333)
 3333 FORMAT(1H1)
      RETURN
      END
      SUBROUTINE PLOTIT(AVX,KX,Y,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
      DIMENSION KX(1),Y(1)
      DIMENSION IPLOT(101),AXIS(11)
      DATA IBLANK,IDOT,IMINUS,II,IX,I2/1H ,1H.,1H-,1HI,1HX,1H2/
      DO 6  I=1,11
    6 AXIS(I)=AVX+.2*FLOAT(6-I)
      YMAX=-1.E30
      YMIN=1.E30
      DO 1 I=1,N
      YMIN=DMIN1(YMIN,Y(I))
    1 YMAX=DMAX1(YMAX,Y(I))
      IF(YMIN.GT.0.)YMIN=0.
      SLOPE=50./(YMAX-YMIN)
      DO 3  J=1,51
      ISYMB=IBLANK
      IF(MOD(J,10).EQ.1)ISYMB=IMINUS
      DO 4  K=1,101
    4 IPLOT(K)=ISYMB
      DO 44 K=2,100,2
   44 IPLOT(K)=IBLANK
      DO 40 K=1,101,10
   40 IPLOT(K)=IDOT
      IPLOT(51)=II
      DO 5  I=1,N
      IY=51.5-SLOPE*(Y(I)-YMIN)
      IF(IY.NE.J)GO TO 5
      L=KX(I)
      IF(L.LT.1) GO TO 5
      IF(L.GT.101)  GO TO 5
      IF(IPLOT(L).EQ.IX) GO TO 7
      IPLOT(L)=IX
      GO TO 5
    7 IPLOT(L)=I2
    5 CONTINUE
      YY=FLOAT(51-J)/SLOPE+YMIN
      WRITE(6,10)YY,IPLOT
   10 FORMAT(F12.2,1X,101A1)
    3 CONTINUE
      WRITE(6,20) AXIS
   20 FORMAT(5X,11F10.2)
      RETURN
      END
      FUNCTION VOIGT(V,A)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)
C     FUNCTION H(A,V)
C     FROM ERIC PEYTREMANN
      LOGICAL Q
      VV=V*V
      Q=A.LT.0.2
      IF(Q.AND.V.GT.5.)GOTO 1
      IF(.NOT.Q.AND.(A.GT.1.4.OR.A+V.GT.3.2))GOTO 2
      HO=EXP(-VV)
      H2=(1.-2.*VV)*HO
      IF(V.GT.2.4)GOTO 3
      IF(V.GT.1.3)GOTO 4
      H1=(.42139*VV-2.34358*V+3.28868)*VV-.15517*V-1.1247
    5 IF(Q)GOTO 6
      HH1=H1+HO*1.12838
      HH2=H2+HH1*1.12838-HO
      HH3=(1.-H2)*.37613-HH1*.66667*VV+HH2*1.12838
      HH4=(3.*HH3-HH1)*.37613+HO*.66667*VV*VV
C     H=((((HH4*A+HH3)*A+HH2)*A+HH1)*A+HO)*(((-.122727278*A+.532770573)*
      VOIGT=
     A  ((((HH4*A+HH3)*A+HH2)*A+HH1)*A+HO)*(((-.122727278*A+.532770573)*
     1A-.96284325)*A+.979895032)
      RETURN
    1 VOIGT=((2.12/VV+.8463)/VV+.5642)*A/VV
C   1 H=((2.12/VV+.8463)/VV+.5642)*A/VV
      RETURN
    2 AA=A*A
      U=(AA+VV)*1.4142
      UU=U*U
C     H=((((AA-10.*VV)*AA*3.+15.*VV*VV)/UU+3.*VV-AA)/UU+1.)*A*.79788/U
      VOIGT=
     A  ((((AA-10.*VV)*AA*3.+15.*VV*VV)/UU+3.*VV-AA)/UU+1.)*A*.79788/U
      RETURN
    3 H1=((-.0032783*VV+.0429913*V-.188326)*VV+.278712*V+.55415)/(VV-1.5
     1)
      GOTO 5
    4 H1=(-.220416*VV+1.989196*V-6.61487)*VV+9.39456*V-4.4848
      GOTO 5
    6 VOIGT=(H2*A+H1)*A+HO
C   6 H=(H2*A+H1)*A+HO
      RETURN
      END

      subroutine bisect(xsel,ysel,nsel,  xpeak,nstep,yint,dxl,dxr,dxc)
      parameter (mmax=200,mstep=101)
      implicit real*8 (a-h,o-z)
      dimension xsel(nsel),ysel(nsel)
c
      dimension dxsl(mmax),dxsr(mmax),ysl(mmax),ysr(mmax)
      dimension yint(mstep),dxl(mstep),dxr(mstep),dxc(mstep)
c     finding xpeak
      ymin=+1.e30
      nmin=0
      do n=1,nsel
      	if(ysel(n).lt.ymin) then
      		ymin=ysel(n)
      		nmin=n
      	end if
      end do
      xpeak=xsel(nmin)

      nl=1
      dxsl(1)=0.
      do n=nmin-1,1,-1
      	if(ysel(n).le.ysel(n+1)) exit
      	nl=nl+1
      	dxsl(nl)=xsel(n)-xpeak
      	ysl(nl)=ysel(n)
      	if(nl.ge.mmax) exit
      end do

      nr=1
      dxsr(1)=0.
      do n=nmin+1,nsel
      	if(ysel(n).le.ysel(n-1)) exit
      	nr=nr+1
      	dxsr(nr)=xsel(n)-xpeak
      	ysr(nr)=ysel(n)
      	if(nr.ge.mmax) exit
      end do

      ymax=min(ysl(nl),ysr(nr))
      nstep=mstep
      dely=(ymax-ymin)/(nstep-1)
      do i=1,nstep
      	yint(i)=ymin+dely*(i-1)
      end do
      idum=map1(ysl,dxsl,nl,yint,dxl,nstep)
      idum=map1(ysr,dxsr,nr,yint,dxr,nstep)
      do i=1,nstep
      	dxc(i)=0.5*(dxl(i)+dxr(i))
      end do

      return
      end

      function pp(t)
      implicit real*8 (a-h,o-z)
      real*4 t_real4
      t_real4=t
      pp=1.-erf(t_real4/1.41421356)
      return
      end

      FUNCTION erf(x)
      REAL erf,x
CU    USES gammp
      REAL gammp
      if(x.lt.0.)then
        erf=-gammp(.5,x**2)
      else
        erf=gammp(.5,x**2)
      endif
      return
      END

      FUNCTION gammp(a,x)
      REAL a,gammp,x
CU    USES gcf,gser
      REAL gammcf,gamser,gln
      if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp'
      if(x.lt.a+1.)then
        call gser(gamser,a,x,gln)
        gammp=gamser
      else
        call gcf(gammcf,a,x,gln)
        gammp=1.-gammcf
      endif
      return
      END

      SUBROUTINE gcf(gammcf,a,x,gln)
      INTEGER ITMAX
      REAL a,gammcf,gln,x,EPS,FPMIN
      PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30)
CU    USES gammln
      INTEGER i
      REAL an,b,c,d,del,h,gammln
      gln=gammln(a)
      b=x+1.-a
      c=1./FPMIN
      d=1./b
      h=d
      do 11 i=1,ITMAX
        an=-i*(i-a)
        b=b+2.
        d=an*d+b
        if(abs(d).lt.FPMIN)d=FPMIN
        c=b+an/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gcf'

1     gammcf=exp(-x+a*log(x)-gln)*h
      return
      END

      SUBROUTINE gser(gamser,a,x,gln)
      INTEGER ITMAX
      REAL a,gamser,gln,x,EPS
      PARAMETER (ITMAX=100,EPS=3.e-7)
CU    USES gammln
      INTEGER n
      REAL ap,del,sum,gammln
      gln=gammln(a)
      if(x.le.0.)then
        if(x.lt.0.)pause 'x < 0 in gser'
        gamser=0.
        return
      endif
      ap=a
      sum=1./a
      del=sum
      do 11 n=1,ITMAX
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)

      return
      END

      FUNCTION gammln(xx)
      REAL gammln,xx
      INTEGER j
      DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)

      return
      END

      subroutine vcfind(xbas,ysmap,ythmap,nnj,dlacor,dvkmcor)
      implicit real*8 (a-h,o-z)
      parameter (md=9999,mhd=4999)
      dimension xbas(md),ysmap(md),ythmap(md),sig(-mhd:+mhd)
      dimension xx(100),yy(100),xxx(500),yyy(500)
      if(abs((xbas(2)-xbas(1))/(xbas(nnj)-xbas(nnj-1))-1.)
     & .gt.0.001) then
        write(*,*) 'Linear spacing required in wavelengths!'
        dlacor=0.
        dvkmcor=0.
        return
      end if
      xmid=0.5*(xbas(1)+xbas(nnj))
      dx=xbas(2)-xbas(1)
      ncen=nnj/2
      nnj4=nnj/4
      do 100 j=-nnj4,+nnj4
      sumsq=0.
      nc=0
      do 110 k=ncen-nnj4,ncen+nnj4
      if(k.le.0..or.k.gt.md.or.k-j.le.0.or.k-j.gt.md) then
      sig(j)=1.e30
      go to 100
      end if
      nc=nc+1
      sumsq=sumsq+(ythmap(k)-ysmap(k-j))**2
  110 continue
      sig(j)=sqrt(sumsq/nc)
  100 continue
      smin=+1.e30
      jmin=-nnj4-1
      do 150 j=-nnj4,+nnj4
      if(sig(j).lt.smin) then
      jmin=j
      smin=sig(j)
      end if
c      write(*,'(i4,e13.5)') j,sig(j)
  150 continue
      l=0
      do 190 j=max(jmin-10,-nnj4),min(jmin+10,+nnj4)
      l=l+1
      xx(l)=j*dx
      yy(l)=sig(j)
  190 continue
      nl=l
      delx=0.02
      nnl=int((xx(nl)-xx(1))/delx)+1 
      do 200 m=1,nnl
  200 xxx(m)=xx(1)+(m-1)*delx
      idum=map1(xx,yy,nl,xxx,yyy,nnl)
      yyym=+1.e30
      mmin=0
      do 210 m=1,nnl
      if(yyy(m).lt.yyym) then
      mmin=m
      yyym=yyy(m)
      end if
  210 continue
      dlacor=xxx(mmin)
      dvkmcor=dlacor/xmid*2.997925e5
c      write(*,*) 'dlacor, dvkmcor=',dlacor, dvkmcor
      return
      end



      subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
     *                 diag,mode,factor,nprint,info,nfev,fjac,ldfjac,
     *                 ipvt,qtf,wa1,wa2,wa3,wa4)
      integer m,n,maxfev,mode,nprint,info,nfev,ldfjac
      integer ipvt(n)
      double precision ftol,xtol,gtol,epsfcn,factor
      double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n),
     *                 wa1(n),wa2(n),wa3(n),wa4(m)
      external fcn
c     **********
c
c     subroutine lmdif
c
c     the purpose of lmdif is to minimize the sum of the squares of
c     m nonlinear functions in n variables by a modification of
c     the levenberg-marquardt algorithm. the user must provide a
c     subroutine which calculates the functions. the jacobian is
c     then calculated by a forward-difference approximation.
c
c     the subroutine statement is
c
c       subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
c                        diag,mode,factor,nprint,info,nfev,fjac,
c                        ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         double precision x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of lmdif.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an array of length n. on input x must contain
c         an initial estimate of the solution vector. on output x
c         contains the final estimate of the solution vector.
c
c       fvec is an output array of length m which contains
c         the functions evaluated at the output x.
c
c       ftol is a nonnegative input variable. termination
c         occurs when both the actual and predicted relative
c         reductions in the sum of squares are at most ftol.
c         therefore, ftol measures the relative error desired
c         in the sum of squares.
c
c       xtol is a nonnegative input variable. termination
c         occurs when the relative error between two consecutive
c         iterates is at most xtol. therefore, xtol measures the
c         relative error desired in the approximate solution.
c
c       gtol is a nonnegative input variable. termination
c         occurs when the cosine of the angle between fvec and
c         any column of the jacobian is at most gtol in absolute
c         value. therefore, gtol measures the orthogonality
c         desired between the function vector and the columns
c         of the jacobian.
c
c       maxfev is a positive integer input variable. termination
c         occurs when the number of calls to fcn is at least
c         maxfev by the end of an iteration.
c
c       epsfcn is an input variable used in determining a suitable
c         step length for the forward-difference approximation. this
c         approximation assumes that the relative errors in the
c         functions are of the order of epsfcn. if epsfcn is less
c         than the machine precision, it is assumed that the relative
c         errors in the functions are of the order of the machine
c         precision.
c
c       diag is an array of length n. if mode = 1 (see
c         below), diag is internally set. if mode = 2, diag
c         must contain positive entries that serve as
c         multiplicative scale factors for the variables.
c
c       mode is an integer input variable. if mode = 1, the
c         variables will be scaled internally. if mode = 2,
c         the scaling is specified by the input diag. other
c         values of mode are equivalent to mode = 1.
c
c       factor is a positive input variable used in determining the
c         initial step bound. this bound is set to the product of
c         factor and the euclidean norm of diag*x if nonzero, or else
c         to factor itself. in most cases factor should lie in the
c         interval (.1,100.). 100. is a generally recommended value.
c
c       nprint is an integer input variable that enables controlled
c         printing of iterates if it is positive. in this case,
c         fcn is called with iflag = 0 at the beginning of the first
c         iteration and every nprint iterations thereafter and
c         immediately prior to return, with x and fvec available
c         for printing. if nprint is not positive, no special calls
c         of fcn with iflag = 0 are made.
c
c       info is an integer output variable. if the user has
c         terminated execution, info is set to the (negative)
c         value of iflag. see description of fcn. otherwise,
c         info is set as follows.
c
c         info = 0  improper input parameters.
c
c         info = 1  both actual and predicted relative reductions
c                   in the sum of squares are at most ftol.
c
c         info = 2  relative error between two consecutive iterates
c                   is at most xtol.
c
c         info = 3  conditions for info = 1 and info = 2 both hold.
c
c         info = 4  the cosine of the angle between fvec and any
c                   column of the jacobian is at most gtol in
c                   absolute value.
c
c         info = 5  number of calls to fcn has reached or
c                   exceeded maxfev.
c
c         info = 6  ftol is too small. no further reduction in
c                   the sum of squares is possible.
c
c         info = 7  xtol is too small. no further improvement in
c                   the approximate solution x is possible.
c
c         info = 8  gtol is too small. fvec is orthogonal to the
c                   columns of the jacobian to machine precision.
c
c       nfev is an integer output variable set to the number of
c         calls to fcn.
c
c       fjac is an output m by n array. the upper n by n submatrix
c         of fjac contains an upper triangular matrix r with
c         diagonal elements of nonincreasing magnitude such that
c
c                t     t           t
c               p *(jac *jac)*p = r *r,
c
c         where p is a permutation matrix and jac is the final
c         calculated jacobian. column j of p is column ipvt(j)
c         (see below) of the identity matrix. the lower trapezoidal
c         part of fjac contains information generated during
c         the computation of r.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       ipvt is an integer output array of length n. ipvt
c         defines a permutation matrix p such that jac*p = q*r,
c         where jac is the final calculated jacobian, q is
c         orthogonal (not stored), and r is upper triangular
c         with diagonal elements of nonincreasing magnitude.
c         column j of p is column ipvt(j) of the identity matrix.
c
c       qtf is an output array of length n which contains
c         the first n elements of the vector (q transpose)*fvec.
c
c       wa1, wa2, and wa3 are work arrays of length n.
c
c       wa4 is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac
c
c       fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iflag,iter,j,l
      double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,
     *                 one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio,
     *                 sum,temp,temp1,temp2,xnorm,zero
      double precision dpmpar,enorm
      data one,p1,p5,p25,p75,p0001,zero
     *     /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
      info = 0
      iflag = 0
      nfev = 0
c
c     check the input parameters for errors.
c
      if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m
     *    .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
     *    .or. maxfev .le. 0 .or. factor .le. zero) go to 300
      if (mode .ne. 2) go to 20
      do 10 j = 1, n
         if (diag(j) .le. zero) go to 300
   10    continue
   20 continue
c
c     evaluate the function at the starting point
c     and calculate its norm.
c
      iflag = 1
      call fcn(m,n,x,fvec,iflag)
      nfev = 1
      if (iflag .lt. 0) go to 300
      fnorm = enorm(m,fvec)
c
c     initialize levenberg-marquardt parameter and iteration counter.
c
      par = zero
      iter = 1
c
c     beginning of the outer loop.
c
   30 continue
c
c        calculate the jacobian matrix.
c
         iflag = 2
         call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)
         nfev = nfev + n
         if (iflag .lt. 0) go to 300
c
c        if requested, call fcn to enable printing of iterates.
c
         if (nprint .le. 0) go to 40
         iflag = 0
         if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag)
         if (iflag .lt. 0) go to 300
   40    continue
c
c        compute the qr factorization of the jacobian.
c
         call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
c
c        on the first iteration and if mode is 1, scale according
c        to the norms of the columns of the initial jacobian.
c
         if (iter .ne. 1) go to 80
         if (mode .eq. 2) go to 60
         do 50 j = 1, n
            diag(j) = wa2(j)
            if (wa2(j) .eq. zero) diag(j) = one
   50       continue
   60    continue
c
c        on the first iteration, calculate the norm of the scaled x
c        and initialize the step bound delta.
c
         do 70 j = 1, n
            wa3(j) = diag(j)*x(j)
   70       continue
         xnorm = enorm(n,wa3)
         delta = factor*xnorm
         if (delta .eq. zero) delta = factor
   80    continue
c
c        form (q transpose)*fvec and store the first n components in
c        qtf.
c
         do 90 i = 1, m
            wa4(i) = fvec(i)
   90       continue
         do 130 j = 1, n
            if (fjac(j,j) .eq. zero) go to 120
            sum = zero
            do 100 i = j, m
               sum = sum + fjac(i,j)*wa4(i)
  100          continue
            temp = -sum/fjac(j,j)
            do 110 i = j, m
               wa4(i) = wa4(i) + fjac(i,j)*temp
  110          continue
  120       continue
            fjac(j,j) = wa1(j)
            qtf(j) = wa4(j)
  130       continue
c
c        compute the norm of the scaled gradient.
c
         gnorm = zero
         if (fnorm .eq. zero) go to 170
         do 160 j = 1, n
            l = ipvt(j)
            if (wa2(l) .eq. zero) go to 150
            sum = zero
            do 140 i = 1, j
               sum = sum + fjac(i,j)*(qtf(i)/fnorm)
  140          continue
            gnorm = dmax1(gnorm,dabs(sum/wa2(l)))
  150       continue
  160       continue
  170    continue
c
c        test for convergence of the gradient norm.
c
         if (gnorm .le. gtol) info = 4
         if (info .ne. 0) go to 300
c
c        rescale if necessary.
c
         if (mode .eq. 2) go to 190
         do 180 j = 1, n
            diag(j) = dmax1(diag(j),wa2(j))
  180       continue
  190    continue
c
c        beginning of the inner loop.
c
  200    continue
c
c           determine the levenberg-marquardt parameter.
c
            call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
     *                 wa3,wa4)
c
c           store the direction p and x + p. calculate the norm of p.
c
            do 210 j = 1, n
               wa1(j) = -wa1(j)
               wa2(j) = x(j) + wa1(j)
               wa3(j) = diag(j)*wa1(j)
  210          continue
            pnorm = enorm(n,wa3)
c
c           on the first iteration, adjust the initial step bound.
c
            if (iter .eq. 1) delta = dmin1(delta,pnorm)
c
c           evaluate the function at x + p and calculate its norm.
c
            iflag = 1
            call fcn(m,n,wa2,wa4,iflag)
            nfev = nfev + 1
            if (iflag .lt. 0) go to 300
            fnorm1 = enorm(m,wa4)
c
c           compute the scaled actual reduction.
c
            actred = -one
            if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
c
c           compute the scaled predicted reduction and
c           the scaled directional derivative.
c
            do 230 j = 1, n
               wa3(j) = zero
               l = ipvt(j)
               temp = wa1(l)
               do 220 i = 1, j
                  wa3(i) = wa3(i) + fjac(i,j)*temp
  220             continue
  230          continue
            temp1 = enorm(n,wa3)/fnorm
            temp2 = (dsqrt(par)*pnorm)/fnorm
            prered = temp1**2 + temp2**2/p5
            dirder = -(temp1**2 + temp2**2)
c
c           compute the ratio of the actual to the predicted
c           reduction.
c
            ratio = zero
            if (prered .ne. zero) ratio = actred/prered
c
c           update the step bound.
c
            if (ratio .gt. p25) go to 240
               if (actred .ge. zero) temp = p5
               if (actred .lt. zero)
     *            temp = p5*dirder/(dirder + p5*actred)
               if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
               delta = temp*dmin1(delta,pnorm/p1)
               par = par/temp
               go to 260
  240       continue
               if (par .ne. zero .and. ratio .lt. p75) go to 250
               delta = pnorm/p5
               par = p5*par
  250          continue
  260       continue
c
c           test for successful iteration.
c
            if (ratio .lt. p0001) go to 290
c
c           successful iteration. update x, fvec, and their norms.
c
            do 270 j = 1, n
               x(j) = wa2(j)
               wa2(j) = diag(j)*x(j)
  270          continue
            do 280 i = 1, m
               fvec(i) = wa4(i)
  280          continue
            xnorm = enorm(n,wa2)
            fnorm = fnorm1
            iter = iter + 1
  290       continue
c
c           tests for convergence.
c
            if (dabs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one) info = 1
            if (delta .le. xtol*xnorm) info = 2
            if (dabs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one .and. info .eq. 2) info = 3
            if (info .ne. 0) go to 300
c
c           tests for termination and stringent tolerances.
c
            if (nfev .ge. maxfev) info = 5
            if (dabs(actred) .le. epsmch .and. prered .le. epsmch
     *          .and. p5*ratio .le. one) info = 6
            if (delta .le. epsmch*xnorm) info = 7
            if (gnorm .le. epsmch) info = 8
            if (info .ne. 0) go to 300
c
c           end of the inner loop. repeat if iteration unsuccessful.
c
            if (ratio .lt. p0001) go to 200
c
c        end of the outer loop.
c
         go to 30
  300 continue
c
c     termination, either normal or user imposed.
c
      if (iflag .lt. 0) info = iflag
      iflag = 0
      if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag)
      return
c
c     last card of subroutine lmdif.
c
      end




      double precision function dpmpar(i)
      integer i
c     **********
c
c     Function dpmpar
c
c     This function provides double precision machine parameters
c     when the appropriate set of data statements is activated (by
c     removing the c from column 1) and all other data statements are
c     rendered inactive. Most of the parameter values were obtained
c     from the corresponding Bell Laboratories Port Library function.
c
c     The function statement is
c
c       double precision function dpmpar(i)
c
c     where
c
c       i is an integer input variable set to 1, 2, or 3 which
c         selects the desired machine parameter. If the machine has
c         t base b digits and its smallest and largest exponents are
c         emin and emax, respectively, then these parameters are
c
c         dpmpar(1) = b**(1 - t), the machine precision,
c
c         dpmpar(2) = b**(emin - 1), the smallest magnitude,
c
c         dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
c
c     Argonne National Laboratory. MINPACK Project. November 1996.
c     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More'
c
c     **********
      integer mcheps(4)
      integer minmag(4)
      integer maxmag(4)
      double precision dmach(3)
      equivalence (dmach(1),mcheps(1))
      equivalence (dmach(2),minmag(1))
      equivalence (dmach(3),maxmag(1))
c
c     Machine constants for the IBM 360/370 series,
c     the Amdahl 470/V6, the ICL 2900, the Itel AS/6,
c     the Xerox Sigma 5/7/9 and the Sel systems 85/86.
c
c     data mcheps(1),mcheps(2) / z34100000, z00000000 /
c     data minmag(1),minmag(2) / z00100000, z00000000 /
c     data maxmag(1),maxmag(2) / z7fffffff, zffffffff /
c
c     Machine constants for the Honeywell 600/6000 series.
c
c     data mcheps(1),mcheps(2) / o606400000000, o000000000000 /
c     data minmag(1),minmag(2) / o402400000000, o000000000000 /
c     data maxmag(1),maxmag(2) / o376777777777, o777777777777 /
c
c     Machine constants for the CDC 6000/7000 series.
c
c     data mcheps(1) / 15614000000000000000b /
c     data mcheps(2) / 15010000000000000000b /
c
c     data minmag(1) / 00604000000000000000b /
c     data minmag(2) / 00000000000000000000b /
c
c     data maxmag(1) / 37767777777777777777b /
c     data maxmag(2) / 37167777777777777777b /
c
c     Machine constants for the PDP-10 (KA processor).
c
c     data mcheps(1),mcheps(2) / "114400000000, "000000000000 /
c     data minmag(1),minmag(2) / "033400000000, "000000000000 /
c     data maxmag(1),maxmag(2) / "377777777777, "344777777777 /
c
c     Machine constants for the PDP-10 (KI processor).
c
c     data mcheps(1),mcheps(2) / "104400000000, "000000000000 /
c     data minmag(1),minmag(2) / "000400000000, "000000000000 /
c     data maxmag(1),maxmag(2) / "377777777777, "377777777777 /
c
c     Machine constants for the PDP-11. 
c
c     data mcheps(1),mcheps(2) /   9472,      0 /
c     data mcheps(3),mcheps(4) /      0,      0 /
c
c     data minmag(1),minmag(2) /    128,      0 /
c     data minmag(3),minmag(4) /      0,      0 /
c
c     data maxmag(1),maxmag(2) /  32767,     -1 /
c     data maxmag(3),maxmag(4) /     -1,     -1 /
c
c     Machine constants for the Burroughs 6700/7700 systems.
c
c     data mcheps(1) / o1451000000000000 /
c     data mcheps(2) / o0000000000000000 /
c
c     data minmag(1) / o1771000000000000 /
c     data minmag(2) / o7770000000000000 /
c
c     data maxmag(1) / o0777777777777777 /
c     data maxmag(2) / o7777777777777777 /
c
c     Machine constants for the Burroughs 5700 system.
c
c     data mcheps(1) / o1451000000000000 /
c     data mcheps(2) / o0000000000000000 /
c
c     data minmag(1) / o1771000000000000 /
c     data minmag(2) / o0000000000000000 /
c
c     data maxmag(1) / o0777777777777777 /
c     data maxmag(2) / o0007777777777777 /
c
c     Machine constants for the Burroughs 1700 system.
c
c     data mcheps(1) / zcc6800000 /
c     data mcheps(2) / z000000000 /
c
c     data minmag(1) / zc00800000 /
c     data minmag(2) / z000000000 /
c
c     data maxmag(1) / zdffffffff /
c     data maxmag(2) / zfffffffff /
c
c     Machine constants for the Univac 1100 series.
c
c     data mcheps(1),mcheps(2) / o170640000000, o000000000000 /
c     data minmag(1),minmag(2) / o000040000000, o000000000000 /
c     data maxmag(1),maxmag(2) / o377777777777, o777777777777 /
c
c     Machine constants for the Data General Eclipse S/200.
c
c     Note - it may be appropriate to include the following card -
c     static dmach(3)
c
c     data minmag/20k,3*0/,maxmag/77777k,3*177777k/
c     data mcheps/32020k,3*0/
c
c     Machine constants for the Harris 220.
c
c     data mcheps(1),mcheps(2) / '20000000, '00000334 /
c     data minmag(1),minmag(2) / '20000000, '00000201 /
c     data maxmag(1),maxmag(2) / '37777777, '37777577 /
c
c     Machine constants for the Cray-1.
c
c     data mcheps(1) / 0376424000000000000000b /
c     data mcheps(2) / 0000000000000000000000b /
c
c     data minmag(1) / 0200034000000000000000b /
c     data minmag(2) / 0000000000000000000000b /
c
c     data maxmag(1) / 0577777777777777777777b /
c     data maxmag(2) / 0000007777777777777776b /
c
c     Machine constants for the Prime 400.
c
c     data mcheps(1),mcheps(2) / :10000000000, :00000000123 /
c     data minmag(1),minmag(2) / :10000000000, :00000100000 /
c     data maxmag(1),maxmag(2) / :17777777777, :37777677776 /
c
c     Machine constants for the VAX-11.
c
c     data mcheps(1),mcheps(2) /   9472,  0 /
c     data minmag(1),minmag(2) /    128,  0 /
c     data maxmag(1),maxmag(2) / -32769, -1 /
c
c     Machine constants for IEEE machines.
c
      data dmach(1) /2.22044604926d-16/
      data dmach(2) /2.22507385852d-308/
      data dmach(3) /1.79769313485d+308/
c
      dpmpar = dmach(i)
      return
c
c     Last card of function dpmpar.
c
      end



      double precision function enorm(n,x)
      integer n
      double precision x(n)
c     **********
c
c     function enorm
c
c     given an n-vector x, this function calculates the
c     euclidean norm of x.
c
c     the euclidean norm is computed by accumulating the sum of
c     squares in three different sums. the sums of squares for the
c     small and large components are scaled so that no overflows
c     occur. non-destructive underflows are permitted. underflows
c     and overflows do not occur in the computation of the unscaled
c     sum of squares for the intermediate components.
c     the definitions of small, intermediate and large components
c     depend on two constants, rdwarf and rgiant. the main
c     restrictions on these constants are that rdwarf**2 not
c     underflow and rgiant**2 not overflow. the constants
c     given here are suitable for every known computer.
c
c     the function statement is
c
c       double precision function enorm(n,x)
c
c     where
c
c       n is a positive integer input variable.
c
c       x is an input array of length n.
c
c     subprograms called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i
      double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs,
     *                 x1max,x3max,zero
      data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/
      s1 = zero
      s2 = zero
      s3 = zero
      x1max = zero
      x3max = zero
      floatn = n
      agiant = rgiant/floatn
      do 90 i = 1, n
         xabs = dabs(x(i))
         if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70
            if (xabs .le. rdwarf) go to 30
c
c              sum for large components.
c
               if (xabs .le. x1max) go to 10
                  s1 = one + s1*(x1max/xabs)**2
                  x1max = xabs
                  go to 20
   10          continue
                  s1 = s1 + (xabs/x1max)**2
   20          continue
               go to 60
   30       continue
c
c              sum for small components.
c
               if (xabs .le. x3max) go to 40
                  s3 = one + s3*(x3max/xabs)**2
                  x3max = xabs
                  go to 50
   40          continue
                  if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2
   50          continue
   60       continue
            go to 80
   70    continue
c
c           sum for intermediate components.
c
            s2 = s2 + xabs**2
   80    continue
   90    continue
c
c     calculation of norm.
c
      if (s1 .eq. zero) go to 100
         enorm = x1max*dsqrt(s1+(s2/x1max)/x1max)
         go to 130
  100 continue
         if (s2 .eq. zero) go to 110
            if (s2 .ge. x3max)
     *         enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3)))
            if (s2 .lt. x3max)
     *         enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3)))
            go to 120
  110    continue
            enorm = x3max*dsqrt(s3)
  120    continue
  130 continue
      return
c
c     last card of function enorm.
c
      end





      subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
      integer m,n,ldfjac,iflag
      double precision epsfcn
      double precision x(n),fvec(m),fjac(ldfjac,n),wa(m)
c     **********
c
c     subroutine fdjac2
c
c     this subroutine computes a forward-difference approximation
c     to the m by n jacobian matrix associated with a specified
c     problem of m functions in n variables.
c
c     the subroutine statement is
c
c       subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         double precision x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of fdjac2.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an input array of length n.
c
c       fvec is an input array of length m which must contain the
c         functions evaluated at x.
c
c       fjac is an output m by n array which contains the
c         approximation to the jacobian matrix evaluated at x.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       iflag is an integer variable which can be used to terminate
c         the execution of fdjac2. see description of fcn.
c
c       epsfcn is an input variable used in determining a suitable
c         step length for the forward-difference approximation. this
c         approximation assumes that the relative errors in the
c         functions are of the order of epsfcn. if epsfcn is less
c         than the machine precision, it is assumed that the relative
c         errors in the functions are of the order of the machine
c         precision.
c
c       wa is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... dpmpar
c
c       fortran-supplied ... dabs,dmax1,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j
      double precision eps,epsmch,h,temp,zero
      double precision dpmpar
      data zero /0.0d0/
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
      eps = dsqrt(dmax1(epsfcn,epsmch))
      do 20 j = 1, n
         temp = x(j)
         h = eps*dabs(temp)
         if (h .eq. zero) h = eps
         x(j) = temp + h
         call fcn(m,n,x,wa,iflag)
         if (iflag .lt. 0) go to 30
         x(j) = temp
         do 10 i = 1, m
            fjac(i,j) = (wa(i) - fvec(i))/h
   10       continue
   20    continue
   30 continue
      return
c
c     last card of subroutine fdjac2.
c
      end




      subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1,
     *                 wa2)
      integer n,ldr
      integer ipvt(n)
      double precision delta,par
      double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n),
     *                 wa2(n)
c     **********
c
c     subroutine lmpar
c
c     given an m by n matrix a, an n by n nonsingular diagonal
c     matrix d, an m-vector b, and a positive number delta,
c     the problem is to determine a value for the parameter
c     par such that if x solves the system
c
c           a*x = b ,     sqrt(par)*d*x = 0 ,
c
c     in the least squares sense, and dxnorm is the euclidean
c     norm of d*x, then either par is zero and
c
c           (dxnorm-delta) .le. 0.1*delta ,
c
c     or par is positive and
c
c           abs(dxnorm-delta) .le. 0.1*delta .
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then lmpar expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. on output
c     lmpar also provides an upper triangular matrix s such that
c
c            t   t                   t
c           p *(a *a + par*d*d)*p = s *s .
c
c     s is employed within lmpar and may be of separate interest.
c
c     only a few iterations are generally needed for convergence
c     of the algorithm. if, however, the limit of 10 iterations
c     is reached, then the output par will contain the best
c     value obtained so far.
c
c     the subroutine statement is
c
c       subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
c                        wa1,wa2)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       delta is a positive input variable which specifies an upper
c         bound on the euclidean norm of d*x.
c
c       par is a nonnegative variable. on input par contains an
c         initial estimate of the levenberg-marquardt parameter.
c         on output par contains the final estimate.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, sqrt(par)*d*x = 0,
c         for the output par.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa1 and wa2 are work arrays of length n.
c
c     subprograms called
c
c       minpack-supplied ... dpmpar,enorm,qrsolv
c
c       fortran-supplied ... dabs,dmax1,dmin1,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iter,j,jm1,jp1,k,l,nsing
      double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,
     *                 sum,temp,zero
      double precision dpmpar,enorm
      data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/
c
c     dwarf is the smallest positive magnitude.
c
      dwarf = dpmpar(2)
c
c     compute and store in x the gauss-newton direction. if the
c     jacobian is rank-deficient, obtain a least squares solution.
c
      nsing = n
      do 10 j = 1, n
         wa1(j) = qtb(j)
         if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa1(j) = zero
   10    continue
      if (nsing .lt. 1) go to 50
      do 40 k = 1, nsing
         j = nsing - k + 1
         wa1(j) = wa1(j)/r(j,j)
         temp = wa1(j)
         jm1 = j - 1
         if (jm1 .lt. 1) go to 30
         do 20 i = 1, jm1
            wa1(i) = wa1(i) - r(i,j)*temp
   20       continue
   30    continue
   40    continue
   50 continue
      do 60 j = 1, n
         l = ipvt(j)
         x(l) = wa1(j)
   60    continue
c
c     initialize the iteration counter.
c     evaluate the function at the origin, and test
c     for acceptance of the gauss-newton direction.
c
      iter = 0
      do 70 j = 1, n
         wa2(j) = diag(j)*x(j)
   70    continue
      dxnorm = enorm(n,wa2)
      fp = dxnorm - delta
      if (fp .le. p1*delta) go to 220
c
c     if the jacobian is not rank deficient, the newton
c     step provides a lower bound, parl, for the zero of
c     the function. otherwise set this bound to zero.
c
      parl = zero
      if (nsing .lt. n) go to 120
      do 80 j = 1, n
         l = ipvt(j)
         wa1(j) = diag(l)*(wa2(l)/dxnorm)
   80    continue
      do 110 j = 1, n
         sum = zero
         jm1 = j - 1
         if (jm1 .lt. 1) go to 100
         do 90 i = 1, jm1
            sum = sum + r(i,j)*wa1(i)
   90       continue
  100    continue
         wa1(j) = (wa1(j) - sum)/r(j,j)
  110    continue
      temp = enorm(n,wa1)
      parl = ((fp/delta)/temp)/temp
  120 continue
c
c     calculate an upper bound, paru, for the zero of the function.
c
      do 140 j = 1, n
         sum = zero
         do 130 i = 1, j
            sum = sum + r(i,j)*qtb(i)
  130       continue
         l = ipvt(j)
         wa1(j) = sum/diag(l)
  140    continue
      gnorm = enorm(n,wa1)
      paru = gnorm/delta
      if (paru .eq. zero) paru = dwarf/dmin1(delta,p1)
c
c     if the input par lies outside of the interval (parl,paru),
c     set par to the closer endpoint.
c
      par = dmax1(par,parl)
      par = dmin1(par,paru)
      if (par .eq. zero) par = gnorm/dxnorm
c
c     beginning of an iteration.
c
  150 continue
         iter = iter + 1
c
c        evaluate the function at the current value of par.
c
         if (par .eq. zero) par = dmax1(dwarf,p001*paru)
         temp = dsqrt(par)
         do 160 j = 1, n
            wa1(j) = temp*diag(j)
  160       continue
         call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2)
         do 170 j = 1, n
            wa2(j) = diag(j)*x(j)
  170       continue
         dxnorm = enorm(n,wa2)
         temp = fp
         fp = dxnorm - delta
c
c        if the function is small enough, accept the current value
c        of par. also test for the exceptional cases where parl
c        is zero or the number of iterations has reached 10.
c
         if (dabs(fp) .le. p1*delta
     *       .or. parl .eq. zero .and. fp .le. temp
     *            .and. temp .lt. zero .or. iter .eq. 10) go to 220
c
c        compute the newton correction.
c
         do 180 j = 1, n
            l = ipvt(j)
            wa1(j) = diag(l)*(wa2(l)/dxnorm)
  180       continue
         do 210 j = 1, n
            wa1(j) = wa1(j)/sdiag(j)
            temp = wa1(j)
            jp1 = j + 1
            if (n .lt. jp1) go to 200
            do 190 i = jp1, n
               wa1(i) = wa1(i) - r(i,j)*temp
  190          continue
  200       continue
  210       continue
         temp = enorm(n,wa1)
         parc = ((fp/delta)/temp)/temp
c
c        depending on the sign of the function, update parl or paru.
c
         if (fp .gt. zero) parl = dmax1(parl,par)
         if (fp .lt. zero) paru = dmin1(paru,par)
c
c        compute an improved estimate for par.
c
         par = dmax1(parl,par+parc)
c
c        end of an iteration.
c
         go to 150
  220 continue
c
c     termination.
c
      if (iter .eq. 0) par = zero
      return
c
c     last card of subroutine lmpar.
c
      end




      subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
      integer m,n,lda,lipvt
      integer ipvt(lipvt)
      logical pivot
      double precision a(lda,n),rdiag(n),acnorm(n),wa(n)
c     **********
c
c     subroutine qrfac
c
c     this subroutine uses householder transformations with column
c     pivoting (optional) to compute a qr factorization of the
c     m by n matrix a. that is, qrfac determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r. the householder transformation for
c     column k, k = 1,2,...,min(m,n), is of the form
c
c                           t
c           i - (1/u(k))*u*u
c
c     where u has zeros in the first k-1 positions. the form of
c     this transformation and the method of pivoting first
c     appeared in the corresponding linpack subroutine.
c
c     the subroutine statement is
c
c       subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
c
c     where
c
c       m is a positive integer input variable set to the number
c         of rows of a.
c
c       n is a positive integer input variable set to the number
c         of columns of a.
c
c       a is an m by n array. on input a contains the matrix for
c         which the qr factorization is to be computed. on output
c         the strict upper trapezoidal part of a contains the strict
c         upper trapezoidal part of r, and the lower trapezoidal
c         part of a contains a factored form of q (the non-trivial
c         elements of the u vectors described above).
c
c       lda is a positive integer input variable not less than m
c         which specifies the leading dimension of the array a.
c
c       pivot is a logical input variable. if pivot is set true,
c         then column pivoting is enforced. if pivot is set false,
c         then no column pivoting is done.
c
c       ipvt is an integer output array of length lipvt. ipvt
c         defines the permutation matrix p such that a*p = q*r.
c         column j of p is column ipvt(j) of the identity matrix.
c         if pivot is false, ipvt is not referenced.
c
c       lipvt is a positive integer input variable. if pivot is false,
c         then lipvt may be as small as 1. if pivot is true, then
c         lipvt must be at least n.
c
c       rdiag is an output array of length n which contains the
c         diagonal elements of r.
c
c       acnorm is an output array of length n which contains the
c         norms of the corresponding columns of the input matrix a.
c         if this information is not needed, then acnorm can coincide
c         with rdiag.
c
c       wa is a work array of length n. if pivot is false, then wa
c         can coincide with rdiag.
c
c     subprograms called
c
c       minpack-supplied ... dpmpar,enorm
c
c       fortran-supplied ... dmax1,dsqrt,min0
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kmax,minmn
      double precision ajnorm,epsmch,one,p05,sum,temp,zero
      double precision dpmpar,enorm
      data one,p05,zero /1.0d0,5.0d-2,0.0d0/
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
c     compute the initial column norms and initialize several arrays.
c
      do 10 j = 1, n
         acnorm(j) = enorm(m,a(1,j))
         rdiag(j) = acnorm(j)
         wa(j) = rdiag(j)
         if (pivot) ipvt(j) = j
   10    continue
c
c     reduce a to r with householder transformations.
c
      minmn = min0(m,n)
      do 110 j = 1, minmn
         if (.not.pivot) go to 40
c
c        bring the column of largest norm into the pivot position.
c
         kmax = j
         do 20 k = j, n
            if (rdiag(k) .gt. rdiag(kmax)) kmax = k
   20       continue
         if (kmax .eq. j) go to 40
         do 30 i = 1, m
            temp = a(i,j)
            a(i,j) = a(i,kmax)
            a(i,kmax) = temp
   30       continue
         rdiag(kmax) = rdiag(j)
         wa(kmax) = wa(j)
         k = ipvt(j)
         ipvt(j) = ipvt(kmax)
         ipvt(kmax) = k
   40    continue
c
c        compute the householder transformation to reduce the
c        j-th column of a to a multiple of the j-th unit vector.
c
         ajnorm = enorm(m-j+1,a(j,j))
         if (ajnorm .eq. zero) go to 100
         if (a(j,j) .lt. zero) ajnorm = -ajnorm
         do 50 i = j, m
            a(i,j) = a(i,j)/ajnorm
   50       continue
         a(j,j) = a(j,j) + one
c
c        apply the transformation to the remaining columns
c        and update the norms.
c
         jp1 = j + 1
         if (n .lt. jp1) go to 100
         do 90 k = jp1, n
            sum = zero
            do 60 i = j, m
               sum = sum + a(i,j)*a(i,k)
   60          continue
            temp = sum/a(j,j)
            do 70 i = j, m
               a(i,k) = a(i,k) - temp*a(i,j)
   70          continue
            if (.not.pivot .or. rdiag(k) .eq. zero) go to 80
            temp = a(j,k)/rdiag(k)
            rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2))
            if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80
            rdiag(k) = enorm(m-j,a(jp1,k))
            wa(k) = rdiag(k)
   80       continue
   90       continue
  100    continue
         rdiag(j) = -ajnorm
  110    continue
      return
c
c     last card of subroutine qrfac.
c
      end



      subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
      integer n,ldr
      integer ipvt(n)
      double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
c     **********
c
c     subroutine qrsolv
c
c     given an m by n matrix a, an n by n diagonal matrix d,
c     and an m-vector b, the problem is to determine an x which
c     solves the system
c
c           a*x = b ,     d*x = 0 ,
c
c     in the least squares sense.
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then qrsolv expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. the system
c     a*x = b, d*x = 0, is then equivalent to
c
c                  t       t
c           r*z = q *b ,  p *d*p*z = 0 ,
c
c     where x = p*z. if this system does not have full rank,
c     then a least squares solution is obtained. on output qrsolv
c     also provides an upper triangular matrix s such that
c
c            t   t               t
c           p *(a *a + d*d)*p = s *s .
c
c     s is computed within qrsolv and may be of separate interest.
c
c     the subroutine statement is
c
c       subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, d*x = 0.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kp1,l,nsing
      double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
      data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/
c
c     copy r and (q transpose)*b to preserve input and initialize s.
c     in particular, save the diagonal elements of r in x.
c
      do 20 j = 1, n
         do 10 i = j, n
            r(i,j) = r(j,i)
   10       continue
         x(j) = r(j,j)
         wa(j) = qtb(j)
   20    continue
c
c     eliminate the diagonal matrix d using a givens rotation.
c
      do 100 j = 1, n
c
c        prepare the row of d to be eliminated, locating the
c        diagonal element using p from the qr factorization.
c
         l = ipvt(j)
         if (diag(l) .eq. zero) go to 90
         do 30 k = j, n
            sdiag(k) = zero
   30       continue
         sdiag(j) = diag(l)
c
c        the transformations to eliminate the row of d
c        modify only a single element of (q transpose)*b
c        beyond the first n, which is initially zero.
c
         qtbpj = zero
         do 80 k = j, n
c
c           determine a givens rotation which eliminates the
c           appropriate element in the current row of d.
c
            if (sdiag(k) .eq. zero) go to 70
            if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40
               cotan = r(k,k)/sdiag(k)
               sin = p5/dsqrt(p25+p25*cotan**2)
               cos = sin*cotan
               go to 50
   40       continue
               tan = sdiag(k)/r(k,k)
               cos = p5/dsqrt(p25+p25*tan**2)
               sin = cos*tan
   50       continue
c
c           compute the modified diagonal element of r and
c           the modified element of ((q transpose)*b,0).
c
            r(k,k) = cos*r(k,k) + sin*sdiag(k)
            temp = cos*wa(k) + sin*qtbpj
            qtbpj = -sin*wa(k) + cos*qtbpj
            wa(k) = temp
c
c           accumulate the tranformation in the row of s.
c
            kp1 = k + 1
            if (n .lt. kp1) go to 70
            do 60 i = kp1, n
               temp = cos*r(i,k) + sin*sdiag(i)
               sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
               r(i,k) = temp
   60          continue
   70       continue
   80       continue
   90    continue
c
c        store the diagonal element of s and restore
c        the corresponding diagonal element of r.
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
  100    continue
c
c     solve the triangular system for z. if the system is
c     singular, then obtain a least squares solution.
c
      nsing = n
      do 110 j = 1, n
         if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa(j) = zero
  110    continue
      if (nsing .lt. 1) go to 150
      do 140 k = 1, nsing
         j = nsing - k + 1
         sum = zero
         jp1 = j + 1
         if (nsing .lt. jp1) go to 130
         do 120 i = jp1, nsing
            sum = sum + r(i,j)*wa(i)
  120       continue
  130    continue
         wa(j) = (wa(j) - sum)/sdiag(j)
  140    continue
  150 continue
c
c     permute the components of z back to components of x.
c
      do 160 j = 1, n
         l = ipvt(j)
         x(l) = wa(j)
  160    continue
      return
c
c     last card of subroutine qrsolv.
c
      end

