C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C   SORTAS  - SORTing of ASfit data files                                                      
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C   Transitions can be sorted according to frequency, J, type of transition,
C   and several other ways, including a 'standard' sort which carries out the
C   following sequence of operations:
C      -sort according to transition type (with subsort in J within each
C       type)
C      -subsort of aR-type and bR-type transitions within each J
C       according to K-1
C      -sort of Q-type transitions according to K-1, then subsort of 
C       transitions for each K-1 according to J (or K+1)
C
C
c   !!!!!! WARNING:  Blended lines will not stay together
c
c
C       ver. 20.I.2004                         ----- Zbigniew KISIEL    -----
C                                              ----- Lech PSZCZOLKOWSKI -----
C                          __________________________________________________
C                         | Institute of Physics, Polish Academy of Sciences |
C                         | Al.Lotnikow 32/46, Warszawa, POLAND              |
C                         |                             kisiel@ifpan.edu.pl  |
C                         |                               lbee@ifpan.edu.pl  |
C                         |     http://info.ifpan.edu.pl/~kisiel/prospe.htm  |
C_________________________/--------------------------------------------------
C
C  Modification history:
C
c  23.03.96:  recognition of c-type transitions
c  16.10.97:  recognition of alphanumeric descriptor on lines
c  13.08.03:  compatibility with current ASFIT
c  20.01.04:  modified sorts
c
C_____________________________________________________________________________
C
C ITRANS - number of transitions
C     FR - frequencies of transitions 
C     JK - quantum numbers for transitions where
C       (i,1), (i,2), (i,3) are J, K-1, K+1 for upper level resp.
C       (i,4), (i,5), (i,6) are J, K-1, K+1 for lower level resp.
C    nar - no of aR-type transitions
C    nbr - no of bR-type transitions
C     nq - no of  Q-type transitions
C     np - no of  P-type transitions
C           The program recognises at the moment only these four types of
C           transitions and on sorting according to transitions type uses
C           the order aR,bR,Q, and P, respectively.
C
C_____________________________________________________________________________
C
C
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (maxlin=5000)
c
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /ALDESC/descr
      COMMON /bee/Wjk
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION FR(maxlin),JK(maxlin,6),ERROR(maxlin), 
     * LINFIT(maxlin),Wjk(maxlin),lnum(maxlin),blewt(maxlin)
      CHARACTER FLNAM1*30,FLNAM2*30,descr(maxlin)*8
c
      NLINES=0
      FOLD=0.D0
      FMIN=1.D30
      FMAX=0.D0
C
      WRITE(*,3344)
3344  FORMAT(1X//'  ',76(1H_)/' |',T79,'|'/
     * ' |    SORTAS  -  SORTing and subsorting of ASfit data files ',
     * 'according to ',
     * T79,'|'/
     * ' |               frequency or selected quantum number',
     * T79,'|'/
     * ' |',76(1H_),'|'/'  version 20.I.2004',T64,'Zbigniew KISIEL'/
     * T61,'Lech Pszczolkowski'/)
C
C
C...Read ASFIT data file
c
c
1001  WRITE(*,1002)
1002  FORMAT(/' NAME OF DATA FILE :  ',$)
      READ(*,'(A)',ERR=1001)FLNAM1
      OPEN(2,FILE=FLNAM1,status='old',ERR=1001)
c
1000  WRITE(*,1003)
1003  FORMAT(/' NAME TO BE USED FOR THE OUTPUT FILE :  ',$)
      READ(*,'(A)',ERR=1000)FLNAM2
      OPEN(3,FILE=FLNAM2,STATUS='UNKNOWN',ERR=1000)
c
      CALL DATin
      close(2)
C
C...statistics
C
      do 5 nlines=1,itrans
        FOLD=FR(NLINES)
        IF(FR(NLINES).LT.FMIN)FMIN=FR(NLINES)
        IF(FR(NLINES).GT.FMAX)FMAX=FR(NLINES)
5     continue
c 
4     WRITE(*,7)itrans,FLNAM1,FMIN,FMAX
7     FORMAT(1X/' ****',I5,' lines read from file: ',A//
     * '                  lowest frequency: ',F10.2,' MHz'/
     * '                 highest frequency: ',F10.2,' MHz'/)
c
C
C. . .O p t i o n s . . . . . 
C
      nqsp=0
100   WRITE(*,101)
101   FORMAT(1X//
     * 10X,'= 0  LIST  lines                                 '/
     * 10X,'= 1  SORT  frequencies                    (all lines)'/
     * 10X,'= 2  SORT  selected quantum number        (all lines)'/
     * 10X,'= 3  SORT  K-1                            (only aR-type)'/
     * 10x,'= 4  SORT  K+1                            (bR- & Q-type)'/
     * 10X,'= 5  SORT  trans. type and subsort in J   (all lines) '/
     * 10X,'= 6  STANDARD SORT                        (all lines) '/
     * 10X,'= 7  SORT K-1 + subsort J                 (only aR-type)'/
     * 10X,'= 8  SORT K-1 + subsort J                 (only bR-type)'/
     * 10X,'= 9  SORT K-1 + subsort J                 (all lines)'/
     * 10X,'=10  SAVE & EXIT SORTAS'/41x,'......... ',$)
      READ(*,105,ERR=100)IFLAG 
105   FORMAT(I5)
c
      IF(IFLAG.LT.0.OR.IFLAG.GT.10)GOTO 100
      IF(IFLAG.EQ.0) goto 60
      IF(IFLAG.EQ.1) call s_F(1,itrans)
      IF(IFLAG.EQ.2)then
        iqn=0
        call s_qn(1,itrans,iqn)
        nqsp=iqn
      endif       
c
      IF(IFLAG.EQ.3) then
        call s_dip(1,itrans)
        call s_km1(1,nar)
        nqsp=5
      endif
c
      IF(IFLAG.EQ.4) then
        call s_dip(1,itrans)
        call s_kp1(nar+1,nar+nbr+nq)
        nqsp=6
      endif
c
      IF(IFLAG.EQ.5) call s_dip(1,itrans)
      IF(IFLAG.EQ.6) call s_std
c
      IF(IFLAG.EQ.7) then
        call s_dip(1,itrans)
        call ss_jka
        nqsp=5
      endif
c
      IF(IFLAG.EQ.8)then
        call s_dip(1,itrans)
        call ss_jkb
        nqsp=5
      endif
c
      IF(IFLAG.EQ.9)then
        call s_dip(1,itrans)
        call ss_jkal
        nqsp=5
      endif
c
      IF(IFLAG.EQ.10) goto 90
      goto 100
c
c...listing
c
60    do 65 i=1,itrans
        if(blewt(i).ne.0.0d0)then
          write(*,66)i,(JK(i,M),M=1,6),FR(i),ERROR(i),LINFIT(i),
     *               blewt(i),descr(i)       
        else
          write(*,67)i,(JK(i,M),M=1,6),FR(i),ERROR(i),LINFIT(i),
     *                        descr(i)       
        endif
65    continue
66    FORMAT(i5,'.',3x,6I4,F15.4,F10.4,I5,f8.3,a)
67    FORMAT(i5,'.',3x,6I4,F15.4,F10.4,I5,8x,a)
      goto 100
c 
C...exit with save   
c
90    CALL DATout(nqsp)
      close(3)
c
c
99    STOP
      END
C
c____________________________________________________________________________
c
      SUBROUTINE s_std
C
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (maxlin=5000)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
      nstart=1
      nend=Itrans
      call s_dip(1,itrans)
c
C...sort J, then subsort K-1 within J (aR-type only)
c
      if(Nar.eq.0) goto 70
      NSTART=1
      Nend=nar 
      call s_J(nstart,nend)
40    WRITE(*,41)
41    FORMAT(' **** K-1  SORTING after J   IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')
      DO 45 I=Nstart,Nend
        LNUM(I)=I
45      WJK(I)=JK(I,5)
50    DO 51 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,4) .NE. JK(K,4) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2i6\)')NSTART,j
             NSTART=K
             GOTO 51
        ELSE
             IF( K.EQ.Nend )  THEN
                CALL SORTc(NSTART,Nend)
                WRITE(*,'(1x/a,2I6)')' last',NSTART,nend
                NSTART=K
                GOTO 70           
             ENDIF
        ENDIF
51      CONTINUE
c
C...sort J, then subsort K-1 within J, (bR-type only)
C
70    if(Nbr.eq.0) goto 89
      Nstart=nar+1
      Nend=nar+nbr
      call s_J(nstart,nend)
      WRITE(*,71)
71    FORMAT(' **** K-1 SORTING after J  IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')
      DO 75 I=Nstart,Nend
        LNUM(I)=I
        WJK(I)=JK(I,5)
75    CONTINUE
80    DO 81 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,4) .NE. JK(K,4) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2I6\)') NSTART,j
             NSTART=K
             GOTO 81
        ELSE
             IF( K.EQ.Nend )  THEN
               CALL SORTc(NSTART,Nend)
               WRITE(*,'(1x/a,2I6)')' last',NSTART,nend
               GOTO 89           
             ENDIF
        ENDIF
81      CONTINUE
c
C...sort  k+1 after k-1,  (Q-type only)
C
89    if(Nq.eq.0) goto 99
      Nstart=nar+nbr+1
      Nend=nar+nbr+nq
      call s_km1(nstart,nend)
90    WRITE(*,91)
91    FORMAT(' **** K+1  SORTING after K-1  IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')    
      DO 95 I=Nstart,Nend
        LNUM(I)=I
95      WJK(I)=JK(I,6)
96    DO 97 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,5) .NE. JK(K,5) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2I6\)') NSTART,j
             NSTART=K
             GOTO 97
        ELSE
             IF( K.EQ.Nend )  THEN
               CALL SORTc(NSTART,Nend)
               WRITE(*,'(a,2I6)')' last',NSTART,nend
               GOTO 99           
             ENDIF
        ENDIF
97      CONTINUE

99    call reorder(1,itrans)
      RETURN
      END
c
C___________________________________________________________________________
c
      SUBROUTINE ss_jkb
c
C...sort K-1, then subsort J within k-1 for bR-type lines
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
70    if(Nbr.eq.0) goto 89
      Nstart=nar+1
      Nend=nar+nbr
      call s_km1(nstart,nend)
      WRITE(*,71)
71    FORMAT(' **** J  SORTING after K-1  IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')
c
      DO 75 I=Nstart,Nend
        LNUM(I)=I
        WJK(I)=JK(I,4)
75    CONTINUE
c
80    DO 81 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,5) .NE. JK(K,5) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2I6\)') NSTART,j
             NSTART=K
             GOTO 81
        ELSE
             IF( K.EQ.Nend )  THEN
               CALL SORTc(NSTART,Nend)
               WRITE(*,'(1x/a,2I6)')' last',NSTART,nend
               GOTO 89           
             ENDIF
        ENDIF
81      CONTINUE
c
89    call reorder(1,itrans)
      RETURN
      END
C
C___________________________________________________________________________
C
      SUBROUTINE ss_jka
c
C...sort K-1, then subsort J within k-1 for aR-type lines
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
70    if(Nar.eq.0) goto 89
      Nstart=1
      Nend=nar
      call s_km1(nstart,nend)
      WRITE(*,71)
71    FORMAT(' **** J  SORTING after K-1  IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')
c
      DO 75 I=Nstart,Nend
        LNUM(I)=I
        WJK(I)=JK(I,4)
75    CONTINUE
c
80    DO 81 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,5) .NE. JK(K,5) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2I6\)') NSTART,j
             NSTART=K
             GOTO 81
        ELSE
             IF( K.EQ.Nend )  THEN
               CALL SORTc(NSTART,Nend)
               WRITE(*,'(1x/a,2I6)')' last',NSTART,nend
               GOTO 89           
             ENDIF
        ENDIF
81      CONTINUE
c
89    call reorder(1,itrans)
      RETURN
      END
C
C___________________________________________________________________________
C
      SUBROUTINE ss_jkal
c
C...sort K-1, then subsort J within k-1 for all lines
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
      Nstart=1
      Nend=itrans
      call s_km1(nstart,nend)
      WRITE(*,71)
71    FORMAT(' **** J  SORTING after K-1  IN  PROGRESS,'
     & ' CURRENTLY WORKING ON LINE =')
c
      DO 75 I=Nstart,Nend
        LNUM(I)=I
        WJK(I)=JK(I,4)
75    CONTINUE
c
80    DO 81 K=NSTART+1,Nend
        NLINES=K-NSTART
        IF( JK(NSTART,5) .NE. JK(K,5) ) THEN            
             J=K-1
             CALL SORTc(NSTART,J) 
             WRITE(*,'(5x,2I6\)') NSTART,j
             NSTART=K
             GOTO 81
        ELSE
             IF( K.EQ.Nend )  THEN
               CALL SORTc(NSTART,Nend)
               WRITE(*,'(1x/a,2I6)')' last',NSTART,nend
               GOTO 89           
             ENDIF
        ENDIF
81      CONTINUE
c
89    call reorder(1,itrans)
      RETURN
      END
C
C___________________________________________________________________________
C
      SUBROUTINE  s_qn(ns,ne,iqn) 
C
C...To sort the whole dataset according to a selected quantum number
C
C   iqn - quantum number for sorting, if set to zero on input then
C         it is asked for
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      character namq(6)*5
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
      data namq/5H   J',5H K-1',5H K+1',5H  J'',5HK-1'',5HK+1''/
c
      if(iqn.ge.1.and.iqn.le.6)goto 23

2     write(*,1)
1     format(1x/' Select the quantum number for sorting '//
     * 20x,'1,2,3 = upper J,K-1,K+1'/
     * 20x,'4,5,6 = lower J,K-1,K+1'//20x,'.....   ',$)      
      read(*,*,err=2)iqn
      if(iqn.lt.1.or.iqn.gt.6)goto 2
c
23    WRITE(*,22)namq(iqn)
22    FORMAT(' **** SORTING according to ',a)
      if( ne.le.ns) return
      NSTART=ns
      Nend=ne
      do 21 k=nstart,nend
        LNUM(k)=k
        WJK(k)=jk(k,iqn)
21    CONTINUE
      CALL SORTc(NSTART,Nend)
      call reorder(NSTART,Nend)
C
      RETURN
      END
C
C___________________________________________________________________________
C
      SUBROUTINE  s_J(ns,ne) 
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
      WRITE(*,22)
22    FORMAT(' **** J   SORTING ')
      if( ne.le.ns) return
      NSTART=ns
      Nend=ne
      do 21 k=nstart,nend
        LNUM(k)=k
        WJK(k)=jk(k,4)
21    CONTINUE
      CALL SORTc(NSTART,Nend)
      call reorder(NSTART,Nend)
C
      RETURN
      END
C
C_____________________________________________________________________________
C
      SUBROUTINE s_km1(ns,ne)
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
30    WRITE(*,31)
31    FORMAT(/' **** K-1  SORTING ')
      if( ne.le.ns) return
      Nstart=ns
      Nend=ne
      DO 32 I=Nstart,Nend
        LNUM(I)=I
        WJK(I)=JK(I,5)
32    continue
c
      CALL SORTc(Nstart,Nend)
      call reorder(NSTART,Nend)
c
      RETURN
      END
C
C_____________________________________________________________________________

      SUBROUTINE s_kp1(ns,ne)
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
C
35    WRITE(*,36)
36    FORMAT(/' **** K+1  SORTING ')
      if( nbr+nq.le.1) return
      Nstart=ns
      Nend=ne
      DO 37 I=nstart,nend
        LNUM(I)=I
        WJK(I)=JK(I,6)
37    continue
C
      CALL SORTc(Nstart,Nend)
      call reorder(NSTART,Nend)
C
      RETURN
      END
C
C_____________________________________________________________________________

      SUBROUTINE s_f(ns,ne)
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
c
      WRITE(*,17)
17    FORMAT(1X/' **** FREQUENCY SORTING ')
      NSTART=ns
      Nend=ne
15    DO 16 k=nstart,nend
        LNUM(k)=k
        WJK(k)=FR(k)
16    CONTINUE
c
      CALL SORTc(NSTART,Nend)
      call reorder(NSTART,Nend)
c
      RETURN
      END
C
C_____________________________________________________________________________
C
      SUBROUTINE s_dip(ns,ne)
C
C  Sort transitions according to transition type, then subsort each type in J
C  - ns,ne define the range of lines in data set for the operation
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /ALDESC/descr
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /dip/nar,nbr,ncr,nq,np
      character*8 descr(maxlin)
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
      INTEGER*2 itest(maxlin)
C
      nstart=ns
      nend=ne
      n=0
C
C...aR-type
      NaR=0
      DO 10 k=nstart,nend 
        itest(k)=0
        If(JK(K,1)-JK(K,4).eq.1)then
          kdm=iabs(jk(k,2)-jk(k,5))
          kdp=iabs(jk(k,3)-jk(k,6))
          if( ((kdm/2)*2.eq.kdm) .and. ((kdp/2)*2.ne.kdp) )then
            NAR=NAR+1
            n=n+1
            lnum(n)=k
            itest(k)=1
          endif
        ENDIF
10    CONTINUE
C
C...bR-type 
      NbR=0
      DO 11 k=nstart,nend         
        if(JK(K,1)-JK(K,4).eq.1)then
          kdm=iabs(jk(k,2)-jk(k,5))
          kdp=iabs(jk(k,3)-jk(k,6))
          if( ((kdm/2)*2.ne.kdm) .and. ((kdp/2)*2.ne.kdp) )then
            NBR=NBR+1
            n=n+1
            LNUM(n)=k
            itest(k)=1
          endif
        ENDIF
11    CONTINUE
C
C...cR-type 
      NcR=0
      DO 15 k=nstart,nend         
        if(JK(K,1)-JK(K,4).eq.1)then
          kdm=iabs(jk(k,2)-jk(k,5))
          kdp=iabs(jk(k,3)-jk(k,6))
          if( ((kdm/2)*2.ne.kdm) .and. ((kdp/2)*2.eq.kdp) )then
            NcR=NcR+1
            n=n+1
            LNUM(n)=k
            itest(k)=1
          ENDIF
        endif
15    CONTINUE
C
C...Q-type 
      NQ=0
      DO 12 k=nstart,nend         
        if(JK(K,1)-JK(K,4).eq.0)THEN
          NQ=NQ+1
          n=n+1
          LNUM(n)=k
          itest(k)=1
        ENDIF
12    CONTINUE
C
C...P-type 
      NP=0
      DO 13 k=nstart,nend         
        if(JK(K,1)-JK(K,4).eq.-1)THEN
          NP=NP+1
          n=n+1
          LNUM(n)=k
          itest(k)=1
        ENDIF
13    CONTINUE
c
      if(n.ne.nend-nstart+1)then
        write(*,67)
        do 51 k=nstart,nend
          if(itest(k).eq.0)write(*,66)k,(JK(k,M),M=1,6),FR(k),
     *                     ERROR(k),LINFIT(k),blewt(k),descr(k)       
67        FORMAT(1x//' PLEASE CORRECT FOLLOWING LINES WITH FISHY ',
     *     'QUANTUM NUMBERS:'/)
66        FORMAT(i5,'.',3x,6I4,F15.4,F10.4,I5,f8.3,a)
51      continue
        stop
      endif
C
      WRITE(*,101)NAR,NBR,ncr,NQ,NP
101   FORMAT(' TRANSITION STATISTICS >>>  aR:',i3,5x,'bR:',i3,
     & 5x,'cR:',i3,5x,'Q:',i3,5x,'P:',i3)
      call reorder(NSTART,Nend)
c
c...sort in J within each transition type
c      
      IF(NAR.GE.1)THEN
        nstart=1
        nend=nar
        call s_J(nstart,nend)
      ENDIF
      IF(NBR.GE.1)THEN
        nstart=nar+1
        nend=nar+nbr
        call s_J(nstart,nend)
      ENDIF
      IF(NcR.GE.1)THEN
        nstart=nar+Nbr+1
        nend=nar+nbr+ncr
        call s_J(nstart,nend)
      ENDIF
      IF(NQ.GE.1)THEN
        nstart=nar+nbr+ncr+1
        nend=nar+nbr+ncr+nq
        call s_J(nstart,nend)
      ENDIF
      IF(NP.GE.1)THEN
        nstart=nar+nbr+ncr+nq+1
        nend=nar+nbr+ncr+nq+np
        call s_J(nstart,nend)
      ENDIF
c
      RETURN
      END
C
c
C-----------------------------------------------------------
C
      SUBROUTINE DATin
c
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /ALDESC/descr
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),blewt(maxlin)
      character line*88,descr(maxlin)*8
C
C...input from a .ASL or .ASF file, all header lines are transferred
C   straightaway to the output file, only lines recognised as transition
C   lines are read in and counted.  This allows processing also of just
C   a section of a data file.
C
      itrans=0
1     read(2,'(a)',err=1,end=3)line
      if(itrans.le.10)write(*,'(1x,a)')line(1:78)
c
      if(line(1:1).eq.' '.and.line(44:44).eq.'.'.and.
     *                        line(59:59).eq.'.')then
        itrans=itrans+1
        READ(line,140,err=4)(JK(itrans,M),M=1,6),FR(itrans),
     *    ERROR(itrans),LINFIT(itrans),blewt(itrans),descr(itrans)
140     FORMAT(6I5,F20.6,F15.6,I5,f10.5,a8)
      else
        if(itrans.eq.0)write(3,'(a)')line
      endif
      goto 1
c
4     itrans=itrans-1
      write(*,'('' ******* ERROR in transition input'',a)')char(7)       
c
c
3     RETURN
      END
C
C_____________________________________________________________________________
c
      SUBROUTINE reorder(ns,ne)
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /ALDESC/descr
      character*8 descr(maxlin),dscold(maxlin)
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)
      dimension jkold(maxlin,6),frold(maxlin),errold(maxlin),
     * linold(maxlin),blold(maxlin)
c
      do 11 ij=ns,ne
        do 12 m=1,6
          jkold(ij,m)=jk(ij,m)
12      continue
        frold(ij)=fr(ij)
        linold(ij)=linfit(ij)
        errold(ij)=error(ij)
        blold(ij)=blewt(ij)
        dscold(ij)=descr(ij)
11    continue
c
      do 14 ij=ns,ne
        ijk=lnum(ij)
        lnum(ij)=ij
        do 15 m=1,6
          jk(ij,m)=jkold(ijk,m)
15      continue
        fr(ij)=frold(ijk)
        linfit(ij)=linold(ijk)
        error(ij)=errold(ijk)
        blewt(ij)=blold(ijk)
        descr(ij)=dscold(ijk)
14    continue
c
      RETURN
      END
c
C_____________________________________________________________________________
C
      SUBROUTINE DATout(nqsp)
C
C    NQSP defines the quantum number for separators: when it changes then
C         separators are put into the output
C
      PARAMETER (maxlin=5000)
      IMPLICIT REAL*8(A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /BLK1/JK,FR,ERROR,blewt,LINFIT,ITRANS
      COMMON /bee/WJK
      COMMON /LNUMS/LNUM
      COMMON /ALDESC/descr
      character*8 descr(maxlin)
      DIMENSION JK(maxlin,6),FR(maxlin),ERROR(maxlin),
     * LINFIT(maxlin),lnum(maxlin),WJK(maxlin),blewt(maxlin)      
c
      DO 10 k=1,ITRANS         
        if(k.eq.1)then
          isep=jk(k,nqsp)
        else
          if(jk(k,nqsp).ne.isep)then
             isep=jk(k,nqsp)
             write(3,'(''!'')')
          endif
        endif
c          
        if(blewt(k).ne.0.d0)then
          WRITE(3,140)(JK(K,M),M=1,6),FR(K),ERROR(K),LINFit(k),
     *                blewt(k),descr(k)
        else
          WRITE(3,141)(JK(K,M),M=1,6),FR(K),ERROR(K),LINFit(k),
     *                         descr(k)
        endif
10    continue
      write(3,'(88(1h-))')
      write(3,'(88(1h-))')
      CLOSE(3)
c      
      WRITE(*,7)itrans
7     FORMAT(1X/' ****',I5,' lines written to the output file'//)    
c
140   FORMAT(6I5,F20.6,F15.6,I5,f10.5,a)
141   FORMAT(6I5,F20.6,F15.6,I5, 10x ,a)
c
      RETURN
      END
C
C_____________________________________________________________________________
C
      SUBROUTINE SORTH(NSTART,N)
c
c   This routine is based on the SORT2 'heapsort' routine from Numerical
c   Recipes and sorts the quantities in vector WK from WK(NSTART) to WK(N)
C   in ascending order of magnitude and also accordingly rearranges vector
C   IPT of pointers to original positions of sorted quantities.
c
      PARAMETER (maxlin=5000)
      COMMON /bee/WK
      COMMON /LNUMS/IPT
      INTEGER*4 IPT(maxlin),IIPT,L,N,NSTART,I,J,IR
      REAL*8 wk(maxlin),wwk
C
      if( N.le.Nstart) return
      L=(N-Nstart)/2+1
      IR=N
10    CONTINUE
        IF(L.GT.NSTART)THEN
          L=L-1
          WWK=WK(L)
          IIPT=IPT(L)
        ELSE
          WWK=WK(IR)
          IIPT=IPT(IR)
          WK(IR)=WK(1)
          IPT(IR)=IPT(1)
          IR=IR-1
          IF(IR.EQ.NSTART)THEN
            WK(1)=WWK
            IPT(1)=IIPT
            RETURN
          ENDIF
        ENDIF
        I=L
        J=L+L
20      IF(J.LE.IR)THEN
          IF(J.LT.IR)THEN
            IF(WK(J).LT.WK(J+1))J=J+1
          ENDIF
          IF(WWK.LT.WK(J))THEN
            WK(I)=WK(J)
            IPT(I)=IPT(J)
            I=J
            J=J+J
          ELSE
            J=IR+1
          ENDIF
        GO TO 20
        ENDIF
        WK(I)=WWK
        IPT(I)=IIPT
      GO TO 10
c
      RETURN
      END
C
C_____________________________________________________________________________
c
      SUBROUTINE SORTC(N,M)
      IMPLICIT INTEGER (I-N)
      PARAMETER (maxlin=5000)
      COMMON /bee/WK
      COMMON /LNUMS/IPT
      INTEGER*4 IPT(maxlin)
      REAL*8 WK(maxlin),EE
C
C ... This routine sorts the quantities part of vector WK from N to M in
C     ascending order of magnitude and also accordingly rearranges vector
C     IPT of pointers to original positions of sorted quantities
C
      if(M.le.N) return
      DO 101 I=N,M-1
        J=I
106     J=J+1
        IF(WK(J)-WK(I))103,104,104
103     EE=WK(I)
        WK(I)=WK(J)
        WK(J)=EE
        K=IPT(I)
        IPT(I)=IPT(J)
        IPT(J)=K
104     IF(J.EQ.M)GOTO 101
        GOTO 106
101   CONTINUE
C
      RETURN
      END
C
c_____________________________________________________________________________
c_____________________________________________________________________________