SUBROUTINE SRTFRQ
C     =================
C
C     Sort the frequency sets, and assign to each frequency
C     a list of contributing transitions
C     Select final frequency set.
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'ATOMIC.FOR'
      INCLUDE 'MODELQ.FOR'
      PARAMETER (SIXTH=UN/6.,FTH=4./3.,V0X=4.D-4,VCX=10.*V0X)
      DIMENSION SX(500)
C     DIMENSION SGZ(MTRANS)
C
      if(ioptab.lt.0) return
      if(ispodf.ge.1) return
C
C     Sort frequencies and assign primary line
C
      CALL INDEXX(NFREQ,FREQ,NLINES)
      DO IJ=1,NFREQ
         KIJ(NLINES(IJ))=NFREQ-IJ+1
      END DO
      DO IT=1,NTRANS
         IF(.NOT.LINEXP(IT)) THEN
            KFR0(IT)=KIJ(IFR0(IT))
            KFR1(IT)=KIJ(IFR1(IT))
            DO IJ=IFR0(IT),IFR1(IT)
               IJLIN(IJ)=IT
            END DO
         END IF
      END DO
      DO IJ=1,NFREQ
         JIK(KIJ(IJ))=IJ
      END DO
      JK1=JIK(1)
      IF(IJLIN(JK1).NE.0)
     *  CALL QUIT(' Largest freq. is a line freq. - (SRTFRQ)',
     *             JK1,IJLIN(JK1))
      JK1=JIK(NFREQ)
      IF(IJLIN(JK1).NE.0)
     *  CALL QUIT(' Smallest freq. is a line freq. - (SRTFRQ)',
     *             JK1,IJLIN(JK1))
C
C     lines or ODFs associated with each frequency
C
      NLIMAX=0
      DO IJ=1,NFREQ
         NLINES(IJ)=0
         DO 50 IT=1,NTRANS
            IF(LINEXP(IT)) GO TO 50
            IF(KIJ(IJ).LT.KFR0(IT)) GO TO 50
            IF(KIJ(IJ).GT.KFR1(IT)) GO TO 50
            IF(IJLIN(IJ).EQ.IT) GOTO 50
            NLINES(IJ)=NLINES(IJ)+1
            IF(NLINES(IJ).GT.MITJ)
     *      CALL QUIT('Too many overlappins-nlines(ij).gt.mitj',
     *      nlines(ij),mitj)
            ITRLIN(NLINES(IJ),IJ)=int2(IT)
c           write(6,653) ij,it,nlines(ij)
c 653       format('nlines',3i7)
   50    CONTINUE
         IF(NLINES(IJ).GT.NLIMAX) NLIMAX=NLINES(IJ)
      END DO
      WRITE(6,611) NLIMAX
  611 FORMAT(/' MAXIMUM NUMBER OF OVERLAPPING TRANSITIONS:  ',I3/)
C
C     Select final set of frequencies:
C        IJX = 1 : included frequency
C        IJX =-1 : rejected frequency
C        IJX = 0 : used for rates, but no contribution of primary
C                   transition to opacity
C
      NPPX=NFREQ-NFREQC
      DO 310 IT=1,NTRANS
         IF(LINEXP(IT)) GO TO 310
         IF(ABS(INDEXP(IT)).NE.3) GO TO 310
         IF(PROF(IFR0(IT)+1).GT.PROF(IFR1(IT)-1)) THEN
           DO IJ=IFR0(IT)+5,IFR1(IT)-1
              IJX(IJ)=-1
              NPPX=NPPX-1
           END DO
         ELSE
           DO IJ=IFR0(IT)+1,IFR1(IT)-5
              IJX(IJ)=-1
              NPPX=NPPX-1
           END DO
         END IF
  310 CONTINUE
      ISX=0
      DO 320 IJ=1,NFREQ
        ISX=ISX-1
        IF(ISX.GT.0) GO TO 320
        IJP=JIK(IJ)
        DX0=0.
        IF(IJX(IJP).EQ.1) GO TO 320
        IF(PROF(IJP).EQ.0.) GO TO 320
        DX0=V0X*FREQ(IJP)
        DNUX=ABS(FREQ(JIK(IJ-1))-FREQ(IJP))
        IF(DNUX.GT.DX0) THEN
            IJX(IJP)=1
            NPPX=NPPX+1
         ELSE
          NPX=0
          DO WHILE (DNUX.LT.DX0 .AND. IJX(JIK(IJ+NPX)).EQ.-1)
            ITRX=IJLIN(JIK(IJ+NPX))
            PSX0=PROF(IFR0(ITRX+1))
            IF(PSX0.GT.0.) THEN
              SX0=PROF(JIK(IJ+NPX))/PSX0
              SX(NPX+1)=PROF(JIK(IJ+NPX))/PROF(IJP)*SX0
            ELSE
              SX(NPX+1)=0.
            ENDIF
            NPX=NPX+1
            DNUX=ABS(FREQ(JIK(IJ-1))-FREQ(JIK(IJ+NPX)))
          END DO
          IF(NPX.EQ.1) THEN
            IJX(IJP)=1
            NPPX=NPPX+1
           ELSE
            SXX=-1.
            DO IPX=1,NPX
              IF(SX(IPX).GT.SXX) THEN
                SXX=SX(IPX)
                ISX=IPX
              END IF
            END DO
            IJX(JIK(IJ+ISX))=1
            NPPX=NPPX+1
          END IF
        END IF
  320 CONTINUE
      DO 330 IJ=1,NFREQ         
        IJP=JIK(IJ)
        IF(IJP.GT.NFREQC) GOTO 330
        IF(IJX(IJP).EQ.1) THEN
          NPPX=NPPX+1
          GOTO 330
        ENDIF
        DX0=VCX*FREQ(IJP)
        NIXA=0
        DO WHILE (IJX(JIK(IJ-NIXA)).NE.1)
           NIXA=NIXA+1    
        ENDDO
        NIXB=0
        DO WHILE (IJX(JIK(IJ+NIXB)).NE.1)
           NIXB=NIXB+1
        ENDDO
        DNUXA=ABS(FREQ(JIK(IJ-NIXA))-FREQ(IJP))
        DNUXB=ABS(FREQ(JIK(IJ+NIXB))-FREQ(IJP))
        IF(DNUXA.GT.DX0 .AND. DNUXB.GT.DX0) THEN
          IJX(IJP)=1
          NPPX=NPPX+1
        ELSE
          IJX(IJP)=-1
        ENDIF
  330 CONTINUE
c
c     correction
c
      if(icompt.eq.0) then
      do ij=1,nfreqc
         ijx(ij)=1
      end do
      do ije=1,nfreqe
         ijx(ijfr(ije))=1
      end do
      end if
C
C     weights
C
      DO 100 IJ=1,NFREQ
         W(IJ)=0.
         KJ0=KIJ(IJ)
         IF(IJX(JIK(KJ0)).EQ.-1) GO TO 100
         IF(KJ0.GE.2 .AND. KJ0.LT.NFREQ) THEN
           IK1=KJ0-1
           DO WHILE (IJX(JIK(IK1)).EQ.-1)
             IK1=IK1-1
           END DO
           IK2=KJ0+1
           DO WHILE (IJX(JIK(IK2)).EQ.-1)
             IK2=IK2+1
           END DO
           W(IJ)=HALF*ABS(FREQ(JIK(IK1))-FREQ(JIK(IK2)))
          ELSE IF(KJ0.EQ.1) THEN
           W(IJ)=HALF*ABS(FREQ(JIK(KJ0))-FREQ(JIK(KJ0+1)))
          ELSE IF(KJ0.EQ.NFREQ) THEN
           W(IJ)=HALF*ABS(FREQ(JIK(KJ0-1))-FREQ(JIK(KJ0)))
         END IF
  100 CONTINUE
C
C     Correction for Simpson weights
C
      JK1=JIK(1)
      DO IJ=2,NFREQ,2
         JK2=JIK(IJ)
         JK3=JIK(IJ+1)
         IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GO TO 130
         IF(WCH(JK2).NE.0.) GO TO 130
         W(JK1)=W(JK1)-SIXTH*W(JK2)
         W(JK3)=W(JK3)-SIXTH*W(JK2)
         W(JK2)=W(JK2)*FTH
         JK1=JK3
      END DO
  130 JK1=JIK(NFREQ)
      DO IJ=NFREQ-1,3,-2
         JK2=JIK(IJ)
         JK3=JIK(IJ-1)
         IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GOTO 150
         IF(WCH(JK2).NE.0.) GOTO 150
         W(JK1)=W(JK1)-SIXTH*W(JK2)
         W(JK3)=W(JK3)-SIXTH*W(JK2)
         W(JK2)=W(JK2)*FTH
         JK1=JK3
      END DO
  150 CONTINUE
C
C     check accuracy of weights for integration
C
c 190 Z0=0.
      Z0=0.
      Z1=0.
      Z2=0.
      ZH=0.
      T1=TEFF
      T2=TWO*TEFF
      T3=HALF*TEFF
      X1=HK/T1
      X2=HK/T2
      X3=HK/T3
      DO IJ=1,NFREQ
         Z0=Z0+W(IJ)
         X15=FREQ(IJ)*1.D-15
         BNZ=BN*X15*X15*X15
         FX1=FREQ(IJ)*X1
         IF(FX1.LE.100.) THEN
            Z1=Z1+W(IJ)*BNZ/(EXP(FREQ(IJ)*X1)-1)
            Z2=Z2+W(IJ)*BNZ/(EXP(FREQ(IJ)*X2)-1)
            ZH=ZH+W(IJ)*BNZ/(EXP(FREQ(IJ)*X3)-1)
         END IF
      END DO
      T1S=SQRT(SQRT(0.25*Z1/SIG4P))
      T1ER=T1S/T1-UN
      T2S=SQRT(SQRT(0.25*Z2/SIG4P))
      T2ER=T2S/T2-UN
      T3S=SQRT(SQRT(0.25*ZH/SIG4P))
      T3ER=T3S/T3-UN
      JK1=JIK(1)
      JK2=JIK(NFREQ)
      Z00=FREQ(JK1)-FREQ(JK2)
      WRITE(6,601) FREQ(JK1),FREQ(JK2),Z00,Z0,T3,T3ER,T1,T1ER,T2,T2ER
  601 FORMAT(/' ACCURACY OF INTEGRATIONS:',/,
     * ' Interval:',1p4e16.8,/,
     * 15x,' Planck functions:',9x,0pf12.0,4x,1pe12.4,/,
     * 42x,0pf12.0,4x,1pe12.4,/,42x,0pf12.0,4x,1pe12.4,/)
      WRITE(6,602) NFREQ,NPPX
  602 FORMAT(' TOTAL NUMBER OF FREQUENCIES:',I8,/,
     *       ' SELECTED FREQUENCIES:       ',I8)
C
      RETURN
      END