      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=98000)
      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*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*80 sptooldir
      logical mstatus
      common/ewprm/dwsp_n,dwsp,ngeta
      common/grparams/ek,adamp,area
      common/fluxmode/ifabs
      common/synfincheck/ifsame,ifsynfin
c_bbb
      common/auto/ifauto,iapdum,ifn
      open (unit=6,status='scratch')
      ifauto=0
      iapdum=0
c_fff
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
      call getarg(narg1,buf)
      listf=1
      read(buf,'(a)') flistnm

      dopcor=0.
      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
      read(charw(39),*) epsld
      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(norder.ge.0) then
              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 fitsread(8,fnobspec,ifbl,norder,nd,xs,ys)
          else
               if(lolimit) then
                 inquire(file=fnobspec(1:jbl-1),exist=loexobs)
               else
                 inquire(file=fnobspec,exist=loexobs)
               end if
               if(loexobs) call sread(8,fnobspec, nd, xs, ys)
          end if
        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.-500.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='',i2,3x,''loexlin='',i2,3x,''loexobs='',i2)')
     & 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='',i2,3x,''loexlin='',i2,3x,''loexobs='',i2)')
     & 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
c     check if observed spectrum is normalized
      sum=0.
      tx1=1.e30
      tx2=-1.e30
      ty1=1.e30
      ty2=-1.e30
      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
      yaver=sum/nd
      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=98000)
      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)
      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
      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
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)
        if(ifabs.eq.1) then
          ymaxkeep=ymax
          yminkeep=ymin
          fluxmax=-1.e30
          do k=1,npoint
            if(absf(k).gt.fluxmax) fluxmax=absf(k)
          end do
          ymax=fluxmax*1.1
          ymin=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
        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.) 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 (%):')
          if(lolimit) then
            iv1=1
            iv2=novtot
          else
            do iv=1,novtot
              if(nofoc.eq.novis(iv)) then
                iv1=iv
                iv2=iv
                exit
              end if
            end do
          end if
         ivcnt=0
        do iv=iv1,iv2
          jj=novis(iv)
          if(jj.eq.nofoc) then
            status = SETCOLORRGB(spobcolor)
          else
            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)
          if(nd.gt.0) then
          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
            write(dout3,3003) vw,threseta
 3003       format('vw:',f6.1,' eta:',f7.4)
            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):'',i8)') int(rp+0.5)
            else
              write(dout4,'(''R(ip):infinity'')')
            end if
            status= SETCOLORRGB(spthcolor)
            xcur = xmin+15*font.avgwidth*4*dx
            ycur = ymin - font.pixheight*dy*4.0
            call moveto_w(xcur,ycur,xy)
            call outgtext(dout4)
            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)
        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

      if((numord.gt.1).and.lolimit) then
c     For multispec with wavelength range specified,
c     we here plot observed spectra of unfocused orders within the range
      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(lab80,527)isvlast,idb,ndb,fndb(1:30)
  527   format('(lastsave No.:',i3,')  line No.',i3,' from ',i3,
     &  ' lines in ',(a30))
      	call lablen(lab80,80,ns,ne)
      	call outgtext (lab80(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
        	residft(n)=1.
        end do
        do n=1+kvwhext,npoint-kvwhext
        	sum=0.
        	do m=n-kvwhext,n+kvwhext
        		sum=sum+fwtt(m-n)*residf(m)
        	end do
        	residft(n)=sum
        end do
        do n=npoint-kvwhext+1,npoint
        	residft(n)=1.
        end do
 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
          ep=epsld
          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
      call solve(nlamo,xguess,x,icode,itype)
      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
        write(*,'(''(fitted prof. center at '',f8.2,'')'')') x(2)
          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')
      if(idb.gt.0.and.abs(x(2)-wlamdb(idb)).lt.dwcrt) 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)
       write(12,'(''obspec:'',a60)') labobs
       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
        if(idb.gt.0.and.abs(x(2)-wlamdb(idb)).lt.dwcrt) 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.3)') (xtmp(n),n=ne1_t,ne2_t)
      write(12,'(''rd:'',10f7.3)') (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)
      dimension knum(9999)
      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     modifies ewcal.log
      inquire (file='ewcal.log',exist=loexist)
      if(loexist) then
      open (unit=12,file='ewcal.log')
      rewind 12
c     temporary file is allocated to unit 91
      open (unit=91,form='formatted',disp='delete')
      rewind 91
      n=0
      k=0
      ifnext=0
      do i=1,9999
        read(12,'(a)',end=199) line
        if(ifnext.eq.1) then
          charline=line(1:15)
          ifnext=0
        end if
        write(91,'(a)') line
        k=k+1
        if(line(6:10).eq.'.....') then
          n=n+1
          knum(n)=k
        end if
      if(line(1:22).eq.'<<<< WIDTH FORMAT >>>>') ifnext=1
      end do
  199 continue
      rewind 91
      rewind 12
      if(knum(n).le.1) then
        read(91,'(a)') line
        read(91,'(a)') line
c       as a result, we have to delete all contents of ewcal.log
        close (12)
        close (91)
        result=systemqq('del ewcal.log')
        open (unit=12,file='ewcal.log',form='formatted')
        close (12)
      else
        do i=1,knum(n)-1
        read(91,'(a)') line
        call lablen(line,120,mbgn,mend)
        write(12,'(a)') line(1:mend)
        end do
        read(91,'(a)') line
        read(91,'(a)') line
        close (12)
        close (91)
      end if
      call lablen(line,120,mbgn,mend)
      write(*,*)
      write(*,'(a)') 'The most recent data for '//
     & charline//' recorded on '//
     & line(1:mend)//' has been removed...'
c      write(*,'(''Press any key to proceed...'')')
c      ch=getcharqq()
      end if

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 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

      call range(xs*dcfac-dshft,nd,xv-dwsp_n,xv+dwsp_n,nw1_n,nw2_n)
      call range(xs*dcfac-dshft,nd,xv-dwsp,xv+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
      call solve(nlamo,xguess,x,icode,itype)

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
  600 continue

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
      if(ewgau(k1,k2).le.0..or.ewdir(k1,k2).le.0.) go to 700
      pf=sigfit(k1,k2)*(ewgau(k1,k2)/ewdir(k1,k2))
      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
      call solve(nlamo,xguess,x,icode,itype)
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

      subroutine solve(nlamo,xguess,x,icode,itype)
      use numerical_libraries
      implicit real*8 (a-h,o-z)
      parameter  (mdq=1000,ldfjac=mdq,ndq=3)
      integer*4 iparam(7)
      dimension fjac(ldfjac,ndq), fscale(mdq)
      dimension rparam(7), x(ndq), xguess(ndq), xlb(ndq)
      dimension xs(ndq), xub(ndq)
      common/spassq/ycont,wlamo(mdq),speco(mdq),fvec(mdq)
      external fcn
      m=nlamo
      n=ndq

      do i=1,m
        fscale(i)=1.
      end do

      do j=1,n
        xs(j)=1.
        xlb(j)=0.
        xub(j)=1.e30
      end do
C                                 All the variables are positive
      itp = 1
C                                 Default parameters are used
      iparam(1) = 0
C
      call erset(3,0,0)
      call erset(4,0,0)
      call erset(5,0,0)
      call dbclsf (fcn, m, n, xguess, itp, xlb, xub, xs,
     &            fscale, iparam, rparam, x, fvec, fjac, ldfjac)
      icode=iercd()
      itype=n1rty(1)
      return
      end

      subroutine fcn (m, n, x, f)
      implicit real*8 (a-h,o-z)
      parameter (mdq=1000)
      integer m, n
      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
c
c     norder is returned
c     norder=-999  this is not a fits-formatted file (treated as text file)
c     norder=0     single-spectrum fits-formatted file
c     norder>0     multi-spectra fits-formatted file --> 'norder' selected
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      ifpfit =scan(fnobspec,'.fit')
      call lablen(fnobspec,60,ns,ne)
      do i=ns,ne-3
      if(fnobspec(i:i+3).eq.'.fit') go to 76
      end do
      ifpfit=0
      go to 77
   76 ifpfit=i
   77 continue

      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
c#
c
      if(ifpfit.eq.0) then
      norder=-999
      ifbl=0
      return
      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 fitsread(nn,fnamet,ifbl,norder,nptsel,wlasel,specsel)
      use dflib
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
c#
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      dimension wlasel(md),specsel(md)
      real*8,dimension(:),allocatable :: wla,spec
      real*4,dimension(:),allocatable :: buffer
      character*60 fnamet,fname
c#
      integer status,unit,readwrite,blocksize,naxes(2),nfound
      integer group,firstpix,nbuffer,npixels,i
      integer npoint,npt,norder
      real*4 nullval
      logical anynull,loexist
      character filename*80
      character comment*80,ctype1*8
      real*4 crval1,cdelt1
      character word8*8,fmt*80,waxmap*80,segment(999)*80,string*255
      dimension ns(999),ne(999)
      character linetemp*80
c
      logical LOREFR
      character*60 fnrefspec,labref
      common/reflab/LOREFR,fnrefspec,labref
c
c
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/dummyorder/npx,nmar
c
      IF(.NOT.LOREFR) numord=1
      if(ifbl.eq.0) then
      fname=fnamet
      else
      fname=fnamet(1:iabs(ifbl)-1)
      end if
      inquire(file=fname,exist=loexist)
      if(.not.loexist) then
      write(*,*) 'specified spectrum file does not exist!'
      stop
      end if
c      write(*,'(a)') fname
      naxes(1)=0
      naxes(2)=0
c 1    status=0
c
cC     Get an unused Logical Unit Number to use to open the FITS file
c 2    call ftgiou(unit,status)
c
C     open the FITS file
      unit=nn
      readwrite=0
 3    call ftopen(unit,fname,readwrite,blocksize,status)

C     determine the size of the image
c      if(norder.eq.0) ndim=1
c      if(norder.gt.0) ndim=2
c 4    call ftgknj(unit,'NAXIS',1,ndim,naxes,nfound,status)
 4    call ftgknj(unit,'NAXIS',1,2,naxes,nfound,status)
c      write(*,*) 'naxes(1)=',naxes(1)
c      write(*,*) 'naxes(2)=',naxes(2)
c      write(*,*) 'nfound  =',nfound

C     check that it found NAXIS1 keyword
c 5    if (norder.eq.0.and.nfound .ne. 1)then
c          print *,'failed! Why not one dimension for norder=0?'
c          stop
c       end if
c      if (norder.gt.0.and.nfound .ne. 2)then
c          print *,'failed! Why not two dimension for norder>0?'
c          stop
c       end if
      ndim=nfound
      call ftgkys(unit,'CTYPE1  ',ctype1,comment,status)

ccc   LINEAR
c>>
c>>      if(ctype1.ne.'LINEAR  '.and.ctype1.ne.'LAMBDA  '
c>>     & .and.ctype1.ne.'WAVELENG'.and.ctype1.ne.'        ') go to 1001
      if(ctype1.eq.'MULTISPE') go to 1001
c>>
c      write(*,'(''CTYPE1:'',a8)') ctype1
c      write(*,*) 'ctype1 match! OK!'
      call ftgkye(unit,'CRVAL1  ',crval1,comment,status)
c      write(*,'(''CRVAL1:'',f8.2)') crval1
      call ftgkye(unit,'CDELT1  ',cdelt1,comment,status)
c      write(*,'(''CDELT1:'',f8.5)') cdelt1
      w0=crval1
      dw=cdelt1
      npoint=naxes(1)
      allocate(wla(npoint))
      allocate(spec(npoint))
      do k=1,npoint
      wla(k)=w0+(k-1)*dw
      end do
      npt=npoint
      go to 1003
 1001 continue

ccc   MULTISPE
      if (ctype1.ne.'MULTISPE') go to 1002
c      if(norder.eq.0) then
c        call ftgkys(unit,'WAXMAP01',waxmap,comment,status)
c        read(waxmap,*) idum,idum,idum,iposm
c        ipos=iposm+1
c      else
c        ipos=norder
c      end if
      do 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
        call ftgkys(unit,word8,segment(i),comment,status)
        if(status.ne.0) exit
        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
      end do
      numstr=i-1
      if(.NOT.LOREFR) then
      	nost=1
      	noen=99
      else
      	if(norder.le.0) then
      	  write(*,*) 'reference read mode! specify order No.!'
      	  write(*,*) 'norder=1 is assumed'
      	  norder=1
      	end if
      	nost=norder
      	noen=norder
      end if
      do 800 j=nost,noen
      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.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.eq.3) then
      iim=ii1+1
      string=segment(ii1)(n1:ne(ii1))//
     & segment(iim)(ns(iim):ne(iim))//
     & segment(ii2)(ns(ii2):n2)
      end if
      call lablen(string,255,nt1,nt2)
      read(string(nt1+1:nt2-1),*) iord,iduma,idumb,crval1,cdelt1,
     & npdum,voc,apb1,apb2
c
c     special treatment for HDS header with dash
      if(iord.eq.iduma) then
        if(j.eq.1) iordabs1=iord
        iord=iord-iordabs1+1
      end if
c
        if(iord.ne.ipos) then
          if(.NOT.LOREFR) then
            go to 801
          else
            write(*,*) 'REFR mode: iord=',iord,'  ipos=',ipos
            stop
          end if
        end if
c      write(*,'(''CRVAL1:'',f8.2)') crval1
c      write(*,'(''CDELT1:'',f8.5)') cdelt1
      w0=crval1
      dw=cdelt1
c      if(ifbl.gt.0) then
c      write(*,*) 'ifbl should be <0'
c      write(*,*) 'transpose row/column as [wavelength-points,order]'
c      stop
c      end if
      IF(.NOT.LOREFR) THEN
      nump(j)=naxes(1)
      do k=1,nump(j)
      	wlmul(k,j)=(w0+(k-1)*dw)*(1.-voc)
      end do
      END IF
  800 continue
  801 IF(.NOT.LOREFR) numord=ipos-1
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
      IF(.NOT.LOREFR) nofoc=norder
c
      npoint=naxes(1)
c      write(*,*) 'npoint=',npoint
      allocate(wla(npoint))
      allocate(spec(npoint))
      IF(.NOT.LOREFR) THEN
      do k=1,npoint
      wla(k)=wlmul(k,norder)
      end do
      ELSE
      do k=1,npoint
      wla(k)=(w0+(k-1)*dw)*(1.-voc)
      end do
      END IF
      npt=npoint
      go to 1003
 1002 continue
ccc   OTHERS
      write(*,'(''CTYPE1:'',a8)') ctype1
      write(*,*) 'ctype1 unmatch! I cannot read this fits file!'
      stop
      return
 1003 continue

C     initialize variables
      if(norder.lt.0) npixels=naxes(1)
      if(norder.eq.0) npixels=naxes(1)
      if(norder.gt.0) npixels=naxes(1)*naxes(2)
      allocate(buffer(npixels))

      group=1
      firstpix=1
      nullval=-999
      ncount=0

c      write(*,*) 'npixels=',npixels
      do while (npixels .gt. 0)
C         read all pixels at a time
           nbuffer=npixels
c 6        call ftgpve(unit,group,firstpix,nbuffer,nullval,
c     &            buffer,anynull,status)
  6        call ftgpfe(unit,group,firstpix,nbuffer,
     &            buffer,flagvals,anynull,status)

C         increment pointers and loop back to read the next group of pixels
          npixels=npixels-nbuffer
          firstpix=firstpix+nbuffer
      end do
      if(norder.le.0) then
c     for one-D spec
        do k=1,npt
          spec(k)=buffer(k)
        end do
      else
c     for two-D spec
c
c      first keep all the order data
      IF(.NOT.LOREFR) THEN
      do j=1,numord
        nskip=(j-1)*npt
        do k=1,npt
          spmul(k,j)=buffer(nskip+k)
        end do
      end do
      END IF
c      now set the spectrum for the specified "norder"
        nskip=(norder-1)*npt
        do k=1,npt
          spec(k)=buffer(nskip+k)
        end do
      end if

c_dummyorder
      IF(.NOT.LOREFR.and.norder.le.0) THEN
c     setting nordummy and nump
c ......................................................................
c      npx is length of dummy order and nmar is margin correction 
c      Note that npx <= md  and  0 =< nmar <npx should be fulfilled
c      The default value is npx=md(=9999) and nmar=0
c 
c      first order    usual order     last order
c       (npx-nmar) + nblock * npx + mod(npt-(npx-nmar),npx) = npt
c      where nblock = int((npt-(npx-nmar))/npx)
c......................................................................
c
      if(npt.le.npx) then
        nordummy=1
        nump(1)=npt
      else
        nblock=int((npt-(npx-nmar))/npx)
        nordummy=1+nblock+1
        nump(1)=npx-nmar
        do j=2,nordummy
          nump(j)=npx
          if(j.eq.nordummy) nump(j)=mod(npt-(npx-nmar),npx)
        end do
      end if
      nc=0
      do j=1,nordummy
      do k=1,nump(j)
      nc=nc+1
      wlmul(k,j)=wla(nc)
      spmul(k,j)=spec(nc)
      end do
      end do
      numord=nordummy
      if(numord.eq.1) norder=1
      if((.not.lolimit).and.(norder.lt.1.or.norder.gt.numord)) then
  542 write(*,'(''Dummy multispe file with '',i2,'' orders'')') numord
      write(*,'(''You can specify the spectrum range to display:'')')
      write(*,5980)(j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
 5980 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
      	wmne=min(wlmul(1,1),wlmul(1,numord))
      	wmxe=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
      	lolimit=.true.
      	go to 5652
      end if
      read(linetemp,*,err=542) norder
      if(norder.lt.100) then
      	if(norder.lt.1.or.norder.gt.numord) go to 542
      else
      	read(linetemp,*,err=542) 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 542
      	lolimit=.true.
      	norder=0
      end if
 5652 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
      END IF
c_dummyorder

C     select out spectrum data
c
      nct=0
      do k=1,npt
      if((.NOT.LOREFR).AND.(wla(k).lt.wmne)) cycle
      if((.NOT.LOREFR).AND.(wla(k).gt.wmxe)) exit
      nct=nct+1
          if(nct.gt.md) then
            if(LOREFR) then
              nct=md
              go to 79
            end if
c
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
c
C     close the file and free the unit number
 7    call ftclos(unit, status)
      call ftfiou(unit, status)
c     Now deallocating wla,spec,buffer
      deallocate(wla)
      deallocate(spec)
      deallocate(buffer)
      return
      end

      subroutine sread(nn,fnamet,nptsel,wlasel,specsel)
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
c
      logical LOREFR
      character*60 fnrefspec,labref
      common/reflab/LOREFR,fnrefspec,labref
      common/orderinfo/numord,nump(99),wlmul(md,99),spmul(md,99),
     & nofoc,nobest,novtot,novis(99),xfrac(99)
      common/dummyorder/npx,nmar
c
      dimension wlasel(md),specsel(md)
      character*80 line,linetemp
      character*60 fname,fnamet
      character*1 ch
      logical lofmt,loexist
      character*60 fmt
      real*8,dimension(:),allocatable :: wla,spec
c
c     first initialize numord and norder
      numord=0
      norder=0
c
      fname=fnamet
      if(lolimit) fname=fnamet(1:jbl-1)
      inquire(file=fname,exist=loexist)
      if(.not.loexist) then
      write(*,*) 'specified spectrum file does not exist!'
      stop
      end if
      open (unit=nn,file=fname)
c     line counting
      nline=0
      do j=1,9999999
      read(nn,'(a)',end=1999) line
      nline=nline+1
      end do
 1999 continue
      allocate(wla(nline))
      allocate(spec(nline))

c     check if fmt exists at thre 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
      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) wla(n),spec(n)
          else
            read(line,*) wla(n),spec(n)
          end if
        end if
   49 continue
      end do
   33 continue
      close (nn)
      if(n.eq.0) then
        write(6,*) 'Check the spectrum file!'
        stop
      end if
      npt=n
c_dummyorder
      IF(.NOT.LOREFR) THEN
c     setting nordummy and nump
c ......................................................................
c      npx is length of dummy order and nmar is margin correction 
c      Note that npx <= md  and  0 =< nmar <npx should be fulfilled
c      The default value is npx=md(=9999) and nmar=0
c 
c      first order    usual order     last order
c       (npx-nmar) + nblock * npx + mod(npt-(npx-nmar),npx) = npt
c      where nblock = int((npt-(npx-nmar))/npx)
c ......................................................................
c
      if(npt.le.npx) then
        nordummy=1
        nump(1)=npt
      else
        nblock=int((npt-(npx-nmar))/npx)
        nordummy=1+nblock+1
        nump(1)=npx-nmar
        do j=2,nordummy
          nump(j)=npx
          if(j.eq.nordummy) nump(j)=mod(npt-(npx-nmar),npx)
        end do
      end if
      nc=0
      do j=1,nordummy
      do k=1,nump(j)
      nc=nc+1
      wlmul(k,j)=wla(nc)
      spmul(k,j)=spec(nc)
      end do
      end do
      numord=nordummy
      if(numord.eq.1) norder=1
      if((.not.lolimit).and.(norder.lt.1.or.norder.gt.numord)) then
  542 write(*,'(''Dummy multispe file with '',i2,'' orders'')') numord
      write(*,'(''You can specify the spectrum range to display:'')')
      write(*,5980)(j,int(wlmul(1,j)),int(wlmul(nump(j),j)),j=1,numord)
 5980 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
      	wmne=min(wlmul(1,1),wlmul(1,numord))
      	wmxe=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
      	lolimit=.true.
      	go to 5652
      end if
      read(linetemp,*,err=542) norder
      if(norder.lt.100) then
      	if(norder.lt.1.or.norder.gt.numord) go to 542
      else
      	read(linetemp,*,err=542) 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 542
      	lolimit=.true.
      	norder=0
      end if
 5652 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
      END IF
c_dummyorder


C     select out spectrum data
c
      nct=0
      do k=1,npt
      if((.NOT.LOREFR).AND.(wla(k).lt.wmne)) cycle
      if((.NOT.LOREFR).AND.(wla(k).gt.wmxe)) exit
      nct=nct+1
          if(nct.gt.md) then
            if(LOREFR) then
              nct=md
              go to 79
            end if
c
c     too large obspec points  1st 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
c
c     Now deallocating wla and spec
      deallocate(wla)
      deallocate(spec)

      return
      end

      subroutine sunspset
      use dfport
      implicit real*8 (a-h,o-z)
      parameter (md=9999)
      parameter (MREF=98000)
      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'/
      data dw/0.02/
      common/xymm/ymaxstd,xmin,xmax,ymin,ymax,dshft,vw,threseta,rp
      common/wrange/wmne,wmxe,jbl,jbr,lolimit
      logical lolimit
      
c        wmin=min(wlmul(1,1),wlmul(1,numord))
c        wmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
c
      wmin=xmin
      wmax=xmax
c
      wmin=max(3000.,wmin)
      wmax=min(13000.,wmax)
      nguess=int((wman-wmin)/dw)+1
      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)
      nc=0
      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
      nc=nc+1
      xr(nc)=wdum
      yr(nc)=fdum
      if(nc.ge.MREF) then
        close (81)
        go to 999
      end if
  150 continue
   99 continue
      close (81)
  100 continue
  999 continue
      nr=nc
      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
c      wmin=min(wlmul(1,1),wlmul(1,numord))
c      wmax=max(wlmul(nump(1),1),wlmul(nump(numord),numord))
      wmin=xmin
      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=98000)
      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*16 idlabel
      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)

      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

      common/dopcorrect/dopcor,dopref,dcfac,drfac
      character*60 fnobspec_org
      common/fnorgpass/fnobspec_org
      common/xyvpass/xv,yv
      common/ewprm/dwsp_n,dwsp,ngeta
c_bbb
      common/auto/ifauto,iapdum,ifn
      data initau/0/
c_fff
      common/grparams/ek,adamp,area
      common/crit_eta/etacrt
      common/idfile/fnlineid
      character*60 fnlineid
      common/fluxmode/ifabs
      character*60 fnback1,fnback2
      character*3 labreg
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) 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
            xmin=wlamdb(idb)-0.5*spandb
            xmax=wlamdb(idb)+0.5*spandb
            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
          xmin=wlamdb(idb)-0.5*spandb
          xmax=wlamdb(idb)+0.5*spandb
          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))-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
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
          xmin=wlamdb(idb)-0.5*spandb
          xmax=wlamdb(idb)+0.5*spandb
          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))-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) 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) 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) 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) 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(*,'(''x-width of display range --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9) twid
          xcen=0.5*(xmin+xmax)
          xmin=xcen-twid/2.
          xmax=xcen+twid/2.
          call bestsel(xmin,xmax)
          spandb=twid
        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('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) 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) 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) vw
        case (ichar('R'))
          if(ifthex.eq.0) return
          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) 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) 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     &    '('' Sorry, this does not work in the m-option mode'')')
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) 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) 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
            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)
          if(dopcor.ne.0.) then
            dcfac=1.+dopcor/2.997925e5
          else
            dcfac=1.
          end if
 1927   continue

          call checkfit(fnobspec,ifbl,norder)
          if(norder.ge.0) then
             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 fitsread(8,fnobspec, ifbl, norder, nd, xs, ys)
          else
             if(lolimit) then
             inquire(file=fnobspec(1:jbl-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 sread(8,fnobspec, nd, xs, ys)
          end if

          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
            xmin=wlamdb(idb)-0.5*spandb
            xmax=wlamdb(idb)+0.5*spandb
            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
            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)mode, 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 
ccc          nr=0
          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)
          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
                if(xrtemp.ge.xmin.and.xrtemp.le.xmax) 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) 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) 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) 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('_'))
          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)
          ymin=ymin0
          ymax=ymax0
          dshft=dshft0
          vw=vw0
          threseta=threseta0
          rp=rp0
          imk=0
          yshift=0.
          fz=1.

        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)
            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,'(a)') lnident(n)
                  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) 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) 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


        case (ichar('#'))
          write(*,'(a)') ch
          write(*,'(''inc. vertical shift (obs. spectrum) --> '',$)')
          call readline(linetmp,ifok,nsvv,nevv)
          if(ifok.eq.0) return
          read(linetmp,*,err=9) delys
          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('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 disp. spectra to a file     q: Quit SPSHOW         '
         write(*,*)
     %   't : set obspec mulTiplier     T: reset obspec mulTiplier to 1'
         write(*,*)
     %   '/ : spectrum tilt correction  _: reset (remove) sp tilt corr.'
         write(*,*)
     %   'm: show/unregister Mask region  #: Vertical offseting obspec '
         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(*,*)
     %   '-------------------------------------------------------------'
         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 ? (<=8 chars)'')')
          read(*,'(a)',err=9) idlabel
          call lablen(idlabel,8,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('@'))
          write(*,'(a)') ch
          write(*,'(''Main atomic elements in mask-free region:'')')
          do lz=-68,99
          lznum(lz)=lz
          etama(lz)=-1.e30
          end do
          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) nvarmp
          if(nvarmp.eq.0) go to 1
          if(nvarmp.ge.1.and.nvarmp.le.10) go to 102
          if(nvarmp.gt.100.and.nvarmp.lt.999) then
            write(labreg,'(i3.3)') nvarmp
            write(*,*) 'parameter setup with the file reg'//labreg
            call retenv("DAT_DIR",datdir)
            call lablen(datdir,80,ndsdir,ndedir)
            inquire(file=datdir(ndsdir:ndedir)//'\reg'//labreg//'.dat',
     &      exist=loexist)
            if(.not.loexist) then
              write(*,*) 'reg'//labreg//'.dat not exist at miscdata!'
              cycle
            else
              open (unit=56,
     &        file=datdir(ndsdir:ndedir)//'\reg'//labreg//'.dat')
              read(56,*)
              read(56,*) xmin,xmax
              read(56,*) nvarmp
              read(56,*) (iz(k),k=1,nvarmp)
              close (56)
              xiadopt=xi
              resolu=resolu
              if(vw.lt.0.) epsld=epsld  
              kfits=index(fnobspec,'.fits')
              if(kfits.le.0) then
                write(*,*) 'Invalid fnobspec! -->'//fnobspec
                stop
              end if
              idlabel=fnobspec(kfits-16:kfits-16+7)
              call lablen(idlabel,16,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) (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) tresol
                resolu=tresol
          end if
          if(vw.lt.0.) then
          write(*,
     &    '(''limb-darkening coefficient ? ['',f4.2,'']'')') epsld
          epspre=epsld
          read(*,'(a)',err=9) linetmp
          call lablen(linetmp,60,ns,ne)
                if(ns.gt.ne) then
                        epsld=epspre
                else
                        read(linetmp,*,err=9) tepsld
                        epsld=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) tmpxi
                        xiadopt=tmpxi
                end if


  109     write(*,'(''session name for this job? (<=16 chars)'')')
          read(*,'(a)',err=9) idlabel
          call lablen(idlabel,16,ns,ne)
          if(ns.gt.ne) then
          write(*,'(''session name can not be omitted !'')')
          go to 109
          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
          if(ns_c.gt.ne_c) then
          comment=fnobspec(ns_o:ne_o)//'|'//fnmodel(ns_m:ne_m)
          else
          comment=com40(ns_c:ne_c)//'|'//
     &    ' '//fnobspec(ns_o:ne_o)//' | '//fnmodel(ns_m:ne_m)
          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)-1
          iw2=int(xmax+0.5)+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')
          do n=1,nd
          	write(59,'(0pf10.3,1pe12.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)') epsld
          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,16
          if(idlabel(l:l).ne.' ') go to 601
          end do
  601     l1=l
          do l=16,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)') 'u 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

      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
c        write(lnident(ide),'(a2,i1,f9.3,f8.3,f10.2,2f7.3,3f6.2)')
c     &  elm,iion,wl*10.,min(9999.999,eta0(jref)),code,expot,gflog,
c     &  glogr,glogs,glogw
        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
        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      LCT=LCONT
c      IF(LCT.EQ.NCON) LCT=NCON-1
      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))
      idum=map1(wvcon,ahsave(1,j),ncon,wlth(k),dum,1)
      ALINE(J)=ALINE(J)+DUM
cc      SABCO(J,K)=SABCO(J,K)+DUM
  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
      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

