264 lines
7.0 KiB
Fortran
264 lines
7.0 KiB
Fortran
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
|