C-----------------------------------------------------------------------------
C
C    AC - Auto Conversion of a .RES data file from ASFIT, PIFORM, VIFORM or
C         ERHRES into a data file plottable with gle
C
C-----------------------------------------------------------------------------
C
C    This program generates data files for the GLE program,
C    which can contain:
c
c    1/ either all transitions from the results file
c
c    2/ or subsets of transitions sorted along the criteria specified
c       in the dialogue with the program (typical task is to fish out
c       all transitions for a given vibrational state in a multistate fit)
C
C    The GLE file for plotting these data files is at the moment external
C    to this program - recommended one is PQR.GLE
C
C
C    SORTING OPTIONS:
C
C    - Absolute line sorting: splits data into seven bins of width FGRID in o-c,
C      o-c>7*FGRID is truncated to 7*FGRID
C      (standard setting of FGRID is 0.1)
C
C    - o-c/sigma: splits data into seven bins of width 1 in (o-c).sigma,
C      values of (o-c)/sigma greater than 7 are truncated to 7
C
C
C    ver. 20.VI.2023                           ----- Zbigniew KISIEL    -----
C
C                          __________________________________________________
C                         | Institute of Physics, Polish Academy of Sciences |
C                         | Al.Lotnikow 32/46, Warszawa, POLAND              |
C                         |                             kisiel@ifpan.edu.pl  |
C                         |     http://info.ifpan.edu.pl/~kisiel/prospe.htm  |
C_________________________/--------------------------------------------------
C
C  Modification history:
C
C  8.03.2005: stable version
C 16.01.2006: correction for omitted worst deviations
C 30.10.2006: ERHRES compatibility
C 24.11.2006: automatic detection of the number of SPFIT quantum numbers
C 30.03.2007: more general filtering
C 21.10.2010: misc. improvements
C  7.06.2016: improved line and blend counting
C 27.02.2018: debugging the use of len_trim and of reading PIFORM output
c 20.04.2018: obs-calc and error in the .OUT files, and modified binning
c 25.10.2019: handling very large declared uncertainties
c  5.02.2020: optional suffix in bin file names (later deleted)
c 15.08.2021: exclusions option 4 and file listing rejected lines
c 26.06.2022: catching up with ACN
c 27.12.2022: recovering sensible operation for ASFIT output
c 19.01.2023: restitution of (hopefully debugged) additional file name suffixing
c 20.06.2023: screen echo of specified parameters tracing pipeline operation
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      implicit real*8 (a-h,o-z)
      parameter (binw=0.05d0,maxlin=20000)
c
c    filstr - collects quantum number + optional text suffix in bin names
c    suffix - just the optional text suffix in bin names
c
      character line*150,filnam*50,descr*17,filstr*30
      character lines(maxlin)*92,multeq,suffix*20
      integer ifit(maxlin),iup(6),jlow(6)
c
      fgrid=binw
C
      eunf=0.0D0
      irqsel=-1             ! P,Q,R separation
      isigma=-1             ! 
      i3excl=-1             ! exclusions: 0,1,2,3,4
      nl=0
      nfilt=-10             ! quantum number in bin names (set later)
      nlrej=0               !
      isuffix=0             ! additional text suffix (set to 1 when specified)
      isuffset=0            ! whether combined suffix has been specified (set to 1 when done)
      nfstr=0               ! set to length of quantum number + optional text suffix in bin names
      descr='                 '
      multeq=' '
c
c
      WRITE(*,3344)
3344  FORMAT(1X//'  ',76(1H_)/' |',T79,'|'/
     * ' |       A C  -  Auto Conversion of a results file from ASFIT,',
     * ' PIFORM,',
     * T79,'|'/
     * ' |               VIFORM or ERHRES to a data file plottable ',
     * 'with gle',T79,'|'/
     * ' |',76(1H_),'|'/'  version 20.06.2023',
     * T64,'Zbigniew KISIEL'/)
c
      write(*,'(1x/3x,a,f10.3/)')'Compiled bin size: ',fgrid
c
c
5     write(*,6)
6     format(1x//
     *      '       Name of results file in the .RES standard:  ',$)
      read(*,'(a)',err=5)filnam
      write(*,'('' _____ Specified input results file:  '',a)')
     * filnam(1:len_trim(filnam))
c
      open(2,file=filnam,status='old',err=5)
      open(3,file='ac.out',status='unknown')
      open(4,file='ac_rejected.out',status='unknown')
      write(3,100)filnam(1:len_trim(filnam))
100   format('!'/
     * '!  Echo of all lines satisfying the quantum number filtering ',
     * 'criteria read from:'/'!    ',a)
      write(4,111)'rejected by the specified filtering option',
     * filnam(1:len_trim(filnam))
111   format('!'/
     * '!  Echo of all lines satisfying the quantum number filtering ',
     * 'criteria read from:'/'!    ',a)
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C   Top of input loop for all modes
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C...Main loop for reading transitions, which are processed and placed into
C   the CHARACTER array LINES
C
2     read(2,'(a)',end=3,err=1)line
c
      if(len_trim(line).lt.71)goto 2
      if(line(1:1).eq.'!')goto 2
      if(line(1:1).eq.'-')goto 2
c
      if(line(5:5).eq.'.'.or.line(5:5).eq.':'.or.line(5:5).eq.'/'.or.
     *   line(5:5).eq.' '.or.line(5:5).eq.'*'.or.line(5:5).eq.'B')then
      else
        goto 2
      endif
c
      if(line(5:5).eq.'.'.and.len_trim(line).lt.71)goto 2
      if(line(5:5).eq.':'.and.len_trim(line).lt.71)goto 2
      if(line(5:5).eq.'/'.and.len_trim(line).lt.71)goto 2
      if(line(5:5).eq.' '.and.len_trim(line).lt.71)goto 2
      if(line(5:5).eq.'*'.and.len_trim(line).lt.71)goto 2
      if(line(5:5).eq.'B'.and.len_trim(line).lt.71)goto 2
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C   ASFIT, ERHAM (ERHRES) input
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c...Results file from ASFIT and from ERHAM-->ERHRES which are identified by
c   the character '.' in the fifth column of each legal line
c
C501.    31   6  25    30   5  26     309834.7061        0.2601   0.2601
C452.    33   5  28    32   4  29     286317.5690        0.2348   0.2348
c
c  ASFIT blend
c
c312.B    7   5   2     7   4   3     142014.2322 B      0.0063   0.1000         1.0000   142014.2247
c313.B    7   5   3     7   4   4     142014.2322 B      0.0063   0.1000         1.0000   142014.2271
c
c  ERHAM blend
c
c039.    46   6  40    46   5  41     211627.2351       -0.0329   0.0500   10      5.0E-01        0.1542
c040.    46   7  40    46   6  41     211627.2351       -0.0329   0.0500   10  12 -5.0E-01       -0.2200
c
      if(line(5:5).eq.'.')then
        if(line(45:45).ne.'.')goto 2
        if(line(59:59).ne.'.')goto 2
        if(line(68:68).ne.'.')goto 2
c
        ift=1
        if(line(6:6).eq.'E'.and.line(73:78).eq.'--excl')then
          line(6:6)=' '
          line(73:78)='      '
          ift=0
        endif
c
        if(line(51:51).eq.'B')then
          line(6:6)=' '
          line(51:51)=' '
          line=line(1:79)
        endif
c
        if(line(73:79).eq.' >3*Err')then
          line(6:6)=' '
          line(73:79)='       '
        endif
c
        if(line(81:81).eq.'/')then
          line(81:len_trim(line))='               '
        endif
c
        if(line(74:74).eq.'/')then
          line(74:len_trim(line))='               '
        endif
c
        read(line,*,err=2)r,i,ii,iii,j,jj,jjj,f,df,er
c
        if(f.eq.0.d0)goto 2
        if(er.eq.0.d0)goto 2
        dfs=df/er
c       if(df.gt.cutlim)df=cutlim
c       if(dfs.gt.cutlis)df=cutlis
c
        nl=nl+1
c
        if(nl.eq.1)then
          irqsel=1
          write(*,78)
78        format(1x/1x,38('- ')/         
     *      ' NOTE: operation for ASFIT output is limited and more'/
     *      '       features are available for converted SPFIT output:'/
     *      '       1/ use SPFIT output option in ASFIT'/
     *      '       2/ run SPFIT -> PIFORM'/
     *      '       3/ run AC'/1x,38('- ')/)
c
c...exclusions?
         if(i3excl.lt.0)then
79         write(*,41)
           read(*,'(i5)',err=79)i3excl
           if(i3excl.lt.1.or.i3excl.gt.4)i3excl=0
         endif
c
c... o-c (=0) or o-c/sigma (=1) sorting?
         if(isigma.lt.0)then
119         write(*,108)
            read(*,'(i5)',err=119)isigma
            if(isigma.ne.1)isigma=0
         endif
c     
        endif
c
        write(line(50:63),'(f14.4)')df
        write(line(64:77),'(f14.4)')dfs
        write(line(78:91),'(f14.4)')er
        lines(nl)=line(1:len_trim(line))
        ifit(nl)=ift
        write(3,'(a)')line(1:len_trim(line))
        goto 2                                                          ! to top of input loop
      endif
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C   SPFIT (PIFORM) / RAM36 (VIFORM) input
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c...Results file from SPFIT->PIFORM and V6->VIFORM
c
c   The first encountered legal line is used to establish the number of quantum numbers
c   being in use and whether filtering according to a value of a given quantum number
C   is to be applied (NFILT is changed from -1 to 0 or higher)
c
c161: 59 19 41   59 17 42                   161786.9415  -0.0036  0.050   0.0008 0.50
c162: 59 18 41   59 18 42                   161786.9415   0.0051  0.050   0.0008 0.50
c
c 22: 31  3 29  0   30  3 28  0             199384.8015   0.1859  0.050   0.0531 0.50
c 23: 31  2 29  0   30  2 28  0             199384.8015  -0.0797  0.050   0.0531 0.50
c
c 26: 33  1 33  1 33   32  1 32  1 32       150724.6687   0.0585  0.100  -0.0198 0.50
c 27: 33  0 33  1 33   32  0 32  1 32       150724.6687  -0.0980  0.100  -0.0198 0.50
c
c 16:  1  0  0  2  1  2    0  0  0  2  1  2   6617.9736   0.0000  0.003  -0.0001 0.61
c 17:  1  0  0  2  1  2    0  0  0  2  1  3   6617.9736   0.0000  0.003  -0.0001 0.39
c
c123: 17  8 10  0   16  7  9  0             193265.1898  -0.1191900.050
c
c
c  Special characters allowed in column 5:
c
c     :  = normal line
c     /  = o-c>3sigma
c     B  = blend component
c        = space character for UNFITTD
c     *  = UNFITTD on the basis of an additional rule
c
      if(line(5:5).eq.':'.or.line(5:5).eq.'/'.or.line(5:5).eq.'B'.or.
     *   line(5:5).eq.'*'.or.line(5:5).eq.' ')then
c
        if(line(15:15).eq.','.and.line(75:75).eq.','
     *                       .and.line(50:50).eq.'|')goto 2
c         
        ift=1
        if(line(65:71).eq.'UNFITTD')then
          write(line(64:71),'(f8.3)')eunf
          ift=0  
        endif
c
c...establish the number of quantum numbers per energy level
c   (if inital NFILT=-10)
c
        if(line(51:51).ne.'.'.or.line(68:68).ne.'.')goto 2
c
        if(nfilt.eq.-10)then
          nquant=2
          if(line(15:17).eq.'   ')nquant=3
          if(line(18:20).eq.'   ')nquant=4
          if(line(21:23).eq.'   ')nquant=5
          if(line(24:26).eq.'   ')nquant=6
c         write(*,'(1x,a)')line(1:len_trim(line))                       ! DEBUG
c
122       write(*,121) nquant,nquant
121       format(1x//3x,i1,
     * ' quantum numbers identified per energy level'//
     *     '        Type a number from 1 to ',i1,' if you want ',
     *     'to filter according to'/
     *     '        the corresponding quantum number '/
     *     '        (zero or ENTER for no filtering, '/
     *     '        -ve value for additional bin name suffix) .... ',$)
          read(*,'(i5)',err=122)nfilt
          if(nfilt.lt.0)then
            isuffix=1
            nfilt=-nfilt
          endif
          if(nfilt.lt.0.or.nfilt.gt.nquant)then
            nfilt=0
            goto 122
          endif
          write(*,'('' ______ Specified filtering quantum number ='',
     *      i3)')nfilt
        endif
c
c...Specify q.n. values for filtering if not yet done so (NFILT)
c
        if(nfilt.gt.0.and.isuffset.eq.0)then
32        write(*,31)                                                    ! qn values
31        format(1x/'        Specify comma separated (upper,lower) ',
     *      'values of the selected'/
     *      '        quantum number to filter out a subset of lines '/
     *      '        (or -1,, for no filtering)                .... ',$)
          read(*,*,err=32)ifilt,jfilt
          write(filstr,'(2i4)')ifilt,jfilt
          write(*,'('' ______ Specified filtering values: '',2i3)')
     *      ifilt,jfilt
c
          nfstr=len_trim(filstr)                                         ! eliminate spaces from filstr
          do 101 i=nfstr-1,1,-1
            if(filstr(i:i).eq.' ')then
              do 102 ii=i,nfstr-1
                 filstr(ii:ii)=filstr(ii+1:ii+1)
102           continue
              filstr(nfstr:nfstr)=' '
            endif
101       continue
c
c...specify additional SUFFIX (if desired) and combine it with FILSTR
c
          if(isuffix.eq.1)then
            write(*,103)
103         format(1x/
     *      '        Alphanumeric suffix to bin file names: ',$)
            read(*,'(a)')suffix
            filstr=filstr(1:len_trim(filstr))//
     *                  '_'//suffix(1:len_trim(suffix))
            write(*,'('' ______ Specified alphanumeric suffix:  '',a)')
     *      suffix(1:len_trim(suffix))
          endif
          nfstr=lentrm(filstr)
c
          isuffset=1
c
        endif
c
c...Error for possible UNFITTD lines
c
        if(eunf.eq.0.0d0)then
115       write(*,116)
116       format(1x/'        Error for UNFITTD lines =  ',$)
          read(*,'(f20.10)',err=115)eunf
          if(eunf.le.0.d0)goto 115
          if(eunf.ge.1000.d0)goto 115
          write(*,'('' ______ Specified UNFITTD error ='',f12.5)')
     *     eunf   
        endif
c
c...What line subsets to use
c
        if(irqsel.lt.0)then
9         write(*,8)
8         format(1x//
     *      '        Should P,Q,R lines be separated (1/0) ?   .... ',$)
          read(*,'(i5)',err=9)irqsel
          if(irqsel.ne.1)irqsel=0
          write(*,'('' ______ Specified P,Q,R separation ='',i3)')irqsel
        endif
c
c...Absolute obs-calc or scaled (obs-calc)/error ?
c    
        if(isigma.lt.0)then
109       write(*,108)
108       format(1x/ 
     *     '        Absolute o-c (=0) or o-c/sigma (=1) sorting ?  ',$)
          read(*,'(i5)',err=109)isigma
          if(isigma.ne.1)isigma=0
          write(*,'('' ______ Specified sorting scheme ='',i3)')isigma
        endif
c
c...Exclusions
c
        if(i3excl.lt.0)then
40        write(*,41)
41        format(1x/ '        Exclusions ?'/
     *               '                 = 0 None'/
     *               '                 = 1 >3*sigma lines'/
     *               '                 = 2 unfitted lines'/
     *               '                 = 3 >3*sigma and unfitted'/
     *               '                 = 4 unfitted and >900 errors'\\
     *               '     .... ',$)
          read(*,'(i5)',err=40)i3excl
          if(i3excl.lt.1.or.i3excl.gt.4)i3excl=0
          write(*,'('' ______ Specified exclusion scheme ='',i3)')
     *      i3excl
        endif
c
c
c...Read line content
c
        read(line(65:71),'(f7.3)',err=117)bigerr
        if(bigerr.ge.900.)ift=-1
        if(bigerr.le.-9.)ift=-1
117     continue
c
c
c...Read line content
c
        line(5:5)='.'
        read(line(1:5),*)r
        lstart=6
        lfin=lstart+3*nquant-1
        read(line(lstart:lfin),'(6i3)',err=2),(iup(i),i=1,nquant)
        lstart=lfin+3
        lfin=lstart+3*nquant-1
        read(line(lstart:lfin),'(6i3)',err=2)(jlow(j),j=1,nquant)
c
        lstart=lfin+1
        if(line(65:65).ne.' ')then
          line=line(1:64)//' '//line(65:)
        endif
        read(line(lstart:),*,err=200)f,df,er
c
c...reject line if zero frequency or zero error
c
        if(line(76:76).eq.'.'.and.line(83:83).eq.'.')                   ! blend component
     *       read(line(72:80),'(F9.4)',err=2)df
        if(f.eq.0.d0)goto 2
        if(er.eq.0.d0)goto 2
c
c...if o-c greater than preset limit then set it to the limit
c
        dfs=df/er
c       if(df.gt.cutlim)df=cutlim
c       if(dfs.gt.cutlis)df=cutlis
c
c...carry out filtering
c
        if(nfilt.gt.0)then
          if(iup(nfilt).ne.ifilt)goto 2
          if(jlow(nfilt).ne.jfilt)goto 2
        endif
c
c...Store acceptable transitions in LINES + IFT and echo to AC.OUT
c
        nl=nl+1
c
        write(line,33)nint(r),(iup(i),i=1,3),(jlow(j),j=1,3),f,df,dfs,er
33      format(i4,'.',i6,2i4,i6,2i4,f16.4,3f14.4)
        if(line(78:78).eq.'*')line(78:91)='  10000000000.'              ! very large error
        lines(nl)=line(1:len_trim(line))

c
c...complete the AC.OUT header on first line
c
        if(nl.eq.1)then
          if(isigma.eq.1)then
            descr='(obs-calc)/error '
          else
            write(descr,'(f8.4)')fgrid
          endif   
c          
          if(isigma.eq.0)then
            multeq='*'
          else
            multeq='='
          endif
c
          write(3,155)'!  Bin sizing:  '//descr
155       format('!'/a/'!'/
     *         '!                                        obs',
     *          '           obs-calc     (o-c)/error'/'!')
        endif
c
        write(3,'(a)')line(1:len_trim(line))                            ! Echo an accepted line 
        ifit(nl)=ift
        goto 2                                                          ! to top of input loop
      endif
C
200   nlrej=nlrej+1
      goto 2
c
c...Joint exit for all input types
c
3     close(2)
      close(3)
c
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c   Write lines out in reverse order into output bins
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the bin files for R-types, if specified by IRQSEL=1
c                                        or all lines if IRQSEL=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
      if(nfstr.ge.2)then
        open(11,file='ac_1_'//filstr(1:nfstr)//'.out',status='unknown')
        open(12,file='ac_2_'//filstr(1:nfstr)//'.out',status='unknown')
        open(13,file='ac_3_'//filstr(1:nfstr)//'.out',status='unknown')
        open(14,file='ac_4_'//filstr(1:nfstr)//'.out',status='unknown')
        open(15,file='ac_5_'//filstr(1:nfstr)//'.out',status='unknown')
        open(16,file='ac_6_'//filstr(1:nfstr)//'.out',status='unknown')
        open(17,file='ac_7_'//filstr(1:nfstr)//'.out',status='unknown')
      else
        open(11,file='ac_1.out',status='unknown')
        open(12,file='ac_2.out',status='unknown')
        open(13,file='ac_3.out',status='unknown')
        open(14,file='ac_4.out',status='unknown')
        open(15,file='ac_5.out',status='unknown')
        open(16,file='ac_6.out',status='unknown')
        open(17,file='ac_7.out',status='unknown')
      endif
      write(11,15)filnam(1:len_trim(filnam)),descr,multeq//' (0 to 1)'
      write(12,15)filnam(1:len_trim(filnam)),descr,multeq//' (1 to 2)'
      write(13,15)filnam(1:len_trim(filnam)),descr,multeq//' (2 to 3)'
      write(14,15)filnam(1:len_trim(filnam)),descr,multeq//' (3 to 4)'
      write(15,15)filnam(1:len_trim(filnam)),descr,multeq//' (4 to 5)'
      write(16,15)filnam(1:len_trim(filnam)),descr,multeq//' (5 to 6)'
      write(17,15)filnam(1:len_trim(filnam)),descr,multeq//' (6 to 7)'
c
15    format('!               Lines from file:  ',a/
     *       '!  satisfying the bin condition:  ',2a,/'!'/'!'/
     * '!                                        obs',
     *  '           obs-calc     (o-c)/error       error'/'!'/
     * '   *      *   *   *     *   *   *          *',
     * '             *             *             *      ')
c
      flast=0.0d0
      noutr=0
      nblendr=0
      do 10 n=nl,1,-1
        line=lines(n)
        read(line,*,err=10)r,i,ii,iii,j,jj,jjj,f,df,dfs,er
        if(irqsel.eq.1.and.(i.le.j))goto 10
c
        if(isigma.eq.1)then                                             (o-c)/er sorting
          binno=dabs(dfs)
        else
          binno=dabs(df)/fgrid                                          absolute sorting
        endif
c
c...exclusions
c
        if((i3excl.eq.1.or.i3excl.eq.3).and.dfs.gt.3.d0)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 10                              
        endif
        if(i3excl.ge.2.and.ifit(n).eq.0)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 10
        endif
        if(i3excl.eq.4.and.ifit(n).eq.-1)then
          write(4,'(a)')line(1:len_trim(line))        
          goto 10
        endif          
c
        if(binno.le.1.d0)then
          IF(f.ne.flast)then
            write(11,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        if(binno.le.2.d0)then
          IF(f.ne.flast)then
            write(12,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        if(binno.le.3.d0)then
          IF(f.ne.flast)then
            write(13,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        if(binno.le.4.d0)then
          IF(f.ne.flast)then
            write(14,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        if(binno.le.5.d0)then
          IF(f.ne.flast)then
            write(15,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        if(binno.le.6.d0.and.f.ne.flast)then
          IF(f.ne.flast)then
            write(16,'(a)')line(1:92)
            noutr=noutr+1
            flast=f
          else
            nblendr=nblendr+1
          endif
          goto 10
        endif
c
        IF(binno.gt.6.d0)then
          write(17,'(a)')line(1:92)
          noutr=noutr+1
          flast=f
          else
            nblendr=nblendr+1
          endif
c
10    continue
c
      close(11)
      close(12)
      close(13)
      close(14)
      close(15)
      close(16)
      close(17)
      if(irqsel.eq.0)goto 7                                             ! exit to summary output
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the bin files for Q-types, if specified by IRQSEL=1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
      flast=0.0d0
      noutq=0
      nblendq=0
      if(nfstr.ge.2)then
        open(11,file='ac_1q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(12,file='ac_2q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(13,file='ac_3q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(14,file='ac_4q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(15,file='ac_5q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(16,file='ac_6q_'//filstr(1:nfstr)//'.out',status='unknown')
        open(17,file='ac_7q_'//filstr(1:nfstr)//'.out',status='unknown')
      else
        open(11,file='ac_1q.out',status='unknown')
        open(12,file='ac_2q.out',status='unknown')
        open(13,file='ac_3q.out',status='unknown')
        open(14,file='ac_4q.out',status='unknown')
        open(15,file='ac_5q.out',status='unknown')
        open(16,file='ac_6q.out',status='unknown')
        open(17,file='ac_7q.out',status='unknown')
      endif
      write(11,15)filnam(1:len_trim(filnam)),descr,multeq//' (0 to 1)'
      write(12,15)filnam(1:len_trim(filnam)),descr,multeq//' (1 to 2)'
      write(13,15)filnam(1:len_trim(filnam)),descr,multeq//' (2 to 3)'
      write(14,15)filnam(1:len_trim(filnam)),descr,multeq//' (3 to 4)'
      write(15,15)filnam(1:len_trim(filnam)),descr,multeq//' (4 to 5)'
      write(16,15)filnam(1:len_trim(filnam)),descr,multeq//' (5 to 6)'
      write(17,15)filnam(1:len_trim(filnam)),descr,multeq//' (6 to 7)'
c
      do 20 n=nl,1,-1

        line=lines(n)
        read(line,*,err=20)r,i,ii,iii,j,jj,jjj,f,df,dfs
        if(irqsel.eq.1.and.(i.ne.j))goto 20
c
        if(isigma.eq.1)then                                             (o-c)/er sorting
          binno=dabs(dfs)
        else
          binno=dabs(df)/fgrid                                          absolute sorting
        endif
c
c...exclusions
c
        if((i3excl.eq.1.or.i3excl.eq.3).and.dfs.gt.3.d0)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 20
        endif
        if(i3excl.ge.2.and.ifit(n).eq.0)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 20
        endif
        if(i3excl.eq.4.and.ifit(n).eq.-1)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 20
        endif
c
        if(binno.le.1.0d0)then
          IF(f.ne.flast)then
            write(11,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        if(binno.le.2.0d0)then
          IF(f.ne.flast)then
            write(12,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        if(binno.le.3.0d0)then
          IF(f.ne.flast)then
            write(13,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        if(binno.le.4.0d0)then
          IF(f.ne.flast)then
            write(14,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        if(binno.le.5.0d0)then
          IF(f.ne.flast)then
            write(15,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        if(binno.le.6.0d0)then
          IF(f.ne.flast)then
            write(16,'(a)')line(1:92)
            noutq=noutq+1
            flast=f
          else
            nblendq=nblendq+1
          endif
          goto 20
        endif
c
        IF(binno.gt.6.d0.and.f.ne.flast)then
          write(17,'(a)')line(1:92)
          noutq=noutq+1
          flast=f
        else
          nblendq=nblendq+1
        endif
c
20    continue
c
      close(11)
      close(12)
      close(13)
      close(14)
      close(15)
      close(16)
      close(17)
77    if(irqsel.eq.0)goto 7                                             ! exit to summary of output
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the bin files for P-types, if specified by IRQSEL=1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
      if(nfstr.ge.2)then
        open(11,file='ac_1p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(12,file='ac_2p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(13,file='ac_3p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(14,file='ac_4p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(15,file='ac_5p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(16,file='ac_6p_'//filstr(1:nfstr)//'.out',status='unknown')
        open(17,file='ac_7p_'//filstr(1:nfstr)//'.out',status='unknown')
      else
        open(11,file='ac_1p.out',status='unknown')
        open(12,file='ac_2p.out',status='unknown')
        open(13,file='ac_3p.out',status='unknown')
        open(14,file='ac_4p.out',status='unknown')
        open(15,file='ac_5p.out',status='unknown')
        open(16,file='ac_6p.out',status='unknown')
        open(17,file='ac_7p.out',status='unknown')
      endif
      write(11,15)filnam(1:len_trim(filnam)),descr,multeq//' (0 to 1)'
      write(12,15)filnam(1:len_trim(filnam)),descr,multeq//' (1 to 2)'
      write(13,15)filnam(1:len_trim(filnam)),descr,multeq//' (2 to 3)'
      write(14,15)filnam(1:len_trim(filnam)),descr,multeq//' (3 to 4)'
      write(15,15)filnam(1:len_trim(filnam)),descr,multeq//' (4 to 5)'
      write(16,15)filnam(1:len_trim(filnam)),descr,multeq//' (5 to 6)'
      write(17,15)filnam(1:len_trim(filnam)),descr,multeq//' (6 to 7)'
c
      if(irqsel.eq.0)then
        close(11)
        close(12)
        close(13)
        close(14)
        close(15)
        close(16)
        close(17)
        goto 7
      endif
c
      flast=0.d0
      noutp=0
      nblendp=0
      do 30 n=nl,1,-1

        line=lines(n)
        read(line,*,err=30)r,i,ii,iii,j,jj,jjj,f,df,dfs
        if(irqsel.eq.1.and.(i.ge.j))goto 30
C
        if(isigma.eq.1)then                                             (o-c)/er sorting
          binno=dabs(dfs)
        else
          binno=dabs(df)/fgrid                                          absolute sorting
        endif
c
c...exclusions
c
        if((i3excl.eq.1.or.i3excl.eq.3).and.dfs.gt.3.d0)then
          write(4,'(a)')line(1:len_trim(line))
          goto 30
        endif
        if(i3excl.ge.2.and.ifit(n).eq.0)then
          write(4,'(a)')line(1:len_trim(line))
          goto 30
        endif
        if(i3excl.eq.4.and.ifit(n).eq.-1)then
          write(4,'(a)')line(1:len_trim(line))
                              goto 30
        endif
c
        if(binno.le.1.0d0)then
          IF(f.ne.flast)then
            write(11,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        if(binno.le.2.0d0)then
          IF(f.ne.flast)then
            write(12,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        if(binno.le.3.0d0)then
          IF(f.ne.flast)then
            write(13,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        if(binno.le.4.0d0)then
          IF(f.ne.flast)then
            write(14,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        if(binno.le.5.0d0)then
          IF(f.ne.flast)then
            write(15,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        if(binno.le.6.0d0)then
          IF(f.ne.flast)then
            write(16,'(a)')line(1:92)
            noutp=noutp+1
            flast=f
          else
            nblendp=nblendp+1
          endif
          goto 30
        endif
c
        IF(binno.gt.6.d0.and.f.ne.flast)then
          write(17,'(a)')line(1:92)
          noutp=noutp+1
          flast=f
        else
          nblendp=nblendp+1
        endif
c
30    continue
c
      close(11)
      close(12)
      close(13)
      close(14)
      close(15)
      close(16)
      close(17)
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
7     write(*,17)nl,nlrej,noutr+noutp+noutq,noutr,nblendr,
     *              noutq,nblendq,noutp,nblendp
17    format(1x//i10,' lines read'/i10,' lines rejected'/
     *   i10,' distinct frequency lines saved to AC_n.OUT files'/
     *   10x,' (additional blend components not saved)'//
     *   i10,' +',i6,'  saved R-types or R+P+Q + unsaved blend ',
     *                                               'components '/
     *   i10,' +',i6,'  saved Q-types + unsaved blend components'/
     *   i10,' +',i6,'  saved P-types + unsaved blend components'//)
c
1     stop
      end
c
c_____________________________________________________________________________
C
C  Actual length of a string (equivalent to LEN_TRIM)
C
      integer function lentrm(carg)
      character carg*(*)
      integer nn,n
c
      nn=len(carg)
      do 1 n=nn,1,-1
       if(carg(n:n).gt.' ')goto 2
1     continue
2     lentrm=n
      if(lentrm.lt.1)lentrm=1
c
      return
      end
C
C____________________________________________________________________________
C_____________________________________________________________________________