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. 15.VIII.2021                         ----- 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
c 15.08.2021: exclusions option 4 and file listing rejected lines
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      implicit real*8 (a-h,o-z)
      parameter (fgrid=0.1d0,maxlin=20000)
c
      character line*150,filnam*50,descr*17,filstr*8
      character lines(maxlin)*92,suffix*20
      integer ifit(maxlin),iup(6),jlow(6)
c
C
      eunf=0.0D0
      isigma=1
      isuffix=0
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 15.08.2021',
     * T64,'Zbigniew KISIEL'/)
c
5     write(*,6)
6     format(1x//'   Name of results file in the .RES standard:  ',$)
      read(*,'(a)',err=5)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)'satisfying the quantum number filtering criteria',
     *            filnam(1:len_trim(filnam))
      write(4,100)'rejected by the specified filtering option',
     *            filnam(1:len_trim(filnam))
100   format('!'/
     * '!  Echo of all lines ',a,' read from:'/'!  ',a/'!'/'!'/
     * '!                                        obs',
     *  '           obs-calc     (o-c)/error       error'/'!')
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C...Main loop for reading transitions, which are processed and placed into
C   the CHARACTER array LINES
C
      nl=0
      ivset=0
      nfilt=-1
      nlrej=0
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     write(3,'(a)')line(1:len_trim(line))
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
        write(line(50:63),'(f14.4)')df
        write(line(64:77),'(f14.4)')dfs
        write(line(78:91),'(f14.4)')er
c       if(line(82:82).eq.'/')line(82:82)='!'
        lines(nl)=line(1:len_trim(line))
        ifit(nl)=ift
        write(3,'(a)')line(1:len_trim(line))
        goto 2
      endif
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
        ift=1
        if(line(65:71).eq.'UNFITTD')then
          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
          endif
          write(line(64:71),'(f8.3)')eunf
          ift=0
        endif
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...establish the number of quantum numbers per energy level
c
        if(line(51:51).ne.'.')goto 2                                    fobs
        if(line(60:60).ne.'.')goto 2                                    fobs-calc
        if(line(68:68).ne.'.')then
          if(line(68:68).eq.'*')then                                    df
            line(65:71)=' 1.E+10'
          else
            goto 200
          endif
        endif
c
        if(nfilt.lt.0)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
122       write(*,121) nquant,nquant
121       format(1x/3x,i1,' quantum numbers 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)'
     *    //40x,'.... ',$)
          read(*,'(i5)',err=122)nfilt
          if(nfilt.lt.0)then
            isuffix=1
            nfilt=-nfilt
          endif
          if(nfilt.lt.0.or.nfilt.gt.nquant)goto 122
        endif
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
     *       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...Specify filtering if not yet done so
c
        if(ivset.eq.0.and.nfilt.gt.0)then
32        write(*,31)
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)'//40x,'.... ',$)
          read(*,*,err=32)ifilt,jfilt
          write(filstr,'(2i4)')ifilt,jfilt
c
          nfstr=len_trim(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
          if(isuffix.eq.1)then
          	write(*,103)
103         format(1x/' Alphanumeric suffix to bin file names:  ',$)
            read(*,'(a)')suffix
          endif
c
          ivset=1
        endif
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))
        write(3,'(a)')line(1:len_trim(line))
        ifit(nl)=ift
        goto 2
      endif
C
200   nlrej=nlrej+1
      goto 2
c
3     close(2)
      close(3)
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c
c   Write lines out in reverse order
c
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
c
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
c
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=9)i3excl
      if(i3excl.lt.1.or.i3excl.gt.4)i3excl=0
c
c
      if(isigma.eq.1)then
        descr=' (obs-calc)/error'
      else
        write(descr,'(f8.4)')fgrid
      endif
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the tables for R-types, if specified by IRQSEL=1
c                                     or all lines if IRQSEL=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
      if(isuffix.eq.1)filstr=filstr(1:len_trim(filstr))//
     *                  '_'//suffix(1:len_trim(suffix))
c
      nfstr=lentrm(filstr)
      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)),'(0 to 1) *',descr
      write(12,15)filnam(1:len_trim(filnam)),'(1 to 2) *',descr
      write(13,15)filnam(1:len_trim(filnam)),'(2 to 3) *',descr
      write(14,15)filnam(1:len_trim(filnam)),'(3 to 4) *',descr
      write(15,15)filnam(1:len_trim(filnam)),'(4 to 5) *',descr
      write(16,15)filnam(1:len_trim(filnam)),'(5 to 6) *',descr
      write(17,15)filnam(1:len_trim(filnam)),'(6 to 7) *',descr
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 77
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the tables 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)),'(0 to 1) *',descr
      write(12,15)filnam(1:len_trim(filnam)),'(1 to 2) *',descr
      write(13,15)filnam(1:len_trim(filnam)),'(2 to 3) *',descr
      write(14,15)filnam(1:len_trim(filnam)),'(3 to 4) *',descr
      write(15,15)filnam(1:len_trim(filnam)),'(4 to 5) *',descr
      write(16,15)filnam(1:len_trim(filnam)),'(5 to 6) *',descr
      write(17,15)filnam(1:len_trim(filnam)),'(6 to 7) *',descr
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
c
c
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c...write out the tables 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)),'(0 to 1) *',descr
      write(12,15)filnam(1:len_trim(filnam)),'(1 to 2) *',descr
      write(13,15)filnam(1:len_trim(filnam)),'(2 to 3) *',descr
      write(14,15)filnam(1:len_trim(filnam)),'(3 to 4) *',descr
      write(15,15)filnam(1:len_trim(filnam)),'(4 to 5) *',descr
      write(16,15)filnam(1:len_trim(filnam)),'(5 to 6) *',descr
      write(17,15)filnam(1:len_trim(filnam)),'(6 to 7) *',descr
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(*,'(1x//i10,'' lines written to output files '',
!     *  ''AC_1.OUT ... AC_10.out''///)')nl
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_____________________________________________________________________________