786 lines
27 KiB
Fortran
786 lines
27 KiB
Fortran
SUBROUTINE ALIST2
|
|
C =================
|
|
C
|
|
C Evaluation of all nexcessary ALI parameters + radiative rates
|
|
C (the routine is analogous to RATES1)
|
|
C a variant for derivatives of the rate matrix w.r.t. populations
|
|
C
|
|
C
|
|
INCLUDE 'IMPLIC.FOR'
|
|
INCLUDE 'BASICS.FOR'
|
|
INCLUDE 'ATOMIC.FOR'
|
|
INCLUDE 'MODELQ.FOR'
|
|
INCLUDE 'ODFPAR.FOR'
|
|
INCLUDE 'ALIPAR.FOR'
|
|
INCLUDE 'ARRAY1.FOR'
|
|
INCLUDE 'ITERAT.FOR'
|
|
DIMENSION EXX(MDEPTH),RBNU(MDEPTH),RBNUF(MDEPTH)
|
|
C DIMENSION EHKL(MFREQL),EHKLF(MFREQL)
|
|
C
|
|
C zero the rates and other quantities
|
|
C
|
|
DO ID=1,ND
|
|
REIT(ID)=0.
|
|
REIN(ID)=0.
|
|
REIX(ID)=0.
|
|
AREIT(ID)=0.
|
|
AREIN(ID)=0.
|
|
CREIT(ID)=0.
|
|
CREIN(ID)=0.
|
|
CREIX(ID)=0.
|
|
REDT(ID)=0.
|
|
REDTM(ID)=0.
|
|
REDTP(ID)=0.
|
|
REDN(ID)=0.
|
|
REDNM(ID)=0.
|
|
REDNP(ID)=0.
|
|
REDX(ID)=0.
|
|
REDXM(ID)=0.
|
|
REDXP(ID)=0.
|
|
HEIT(ID)=0.
|
|
HEITM(ID)=0.
|
|
HEITP(ID)=0.
|
|
HEIN(ID)=0.
|
|
HEINM(ID)=0.
|
|
HEINP(ID)=0.
|
|
EHET(ID)=0.
|
|
EHEN(ID)=0.
|
|
ERET(ID)=0.
|
|
EREN(ID)=0.
|
|
FCOOLI(ID)=0.
|
|
FLFIX(ID)=0.
|
|
FLEXP(ID)=0.
|
|
FLRD(ID)=0.
|
|
FPRD(ID)=0.
|
|
PRADT(ID)=0.
|
|
PRADA(ID)=0.
|
|
DO II=1,NLVEXP
|
|
HEIP(II,ID)=0.
|
|
REIP(II,ID)=0.
|
|
AREIP(II,ID)=0.
|
|
CREIP(II,ID)=0.
|
|
REDP(II,ID)=0.
|
|
REDPM(II,ID)=0.
|
|
HEIPM(II,ID)=0.
|
|
REDPP(II,ID)=0.
|
|
HEIPP(II,ID)=0.
|
|
APT(II,ID)=0.
|
|
APN(II,ID)=0.
|
|
DO JJ=1,NLVEXP
|
|
APP(JJ,II,ID)=0.
|
|
END DO
|
|
END DO
|
|
DO ITR=1,NTRANS
|
|
RRU(ITR,ID)=0.
|
|
RRD(ITR,ID)=0.
|
|
DRDT(ITR,ID)=0.
|
|
END DO
|
|
END DO
|
|
PRD0=0.
|
|
C
|
|
dedm1=dm(1)/dens(1)
|
|
IF (IRDER.EQ.3) THEN
|
|
C
|
|
LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN
|
|
IF(HMIX0.GT.0.) LROSS=.TRUE.
|
|
IF(LROSS) THEN
|
|
DO ID=1,ND
|
|
ABROSD(ID)=0.
|
|
SUMDPL(ID)=0.
|
|
END DO
|
|
END IF
|
|
C
|
|
DO 100 IJ=1,NFREQ
|
|
IF(IJX(IJ).EQ.-1) GO TO 100
|
|
FR=FREQ(IJ)
|
|
W0=W0E(IJ)
|
|
LRDER=IJALI(IJ).GT.0
|
|
CALL OPACFD(IJ)
|
|
CALL RTEFR1(IJ)
|
|
CALL ALIFR1(IJ)
|
|
IF(LROSS) CALL ROSSTD(IJ)
|
|
if(ioptab.lt.0) go to 100
|
|
C
|
|
C ---------------------
|
|
C Continuum transitions
|
|
C ---------------------
|
|
C
|
|
DO ID=1,ND
|
|
EXX(ID)=EXP(-HKT1(ID)*FR)
|
|
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
|
|
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
|
|
DO 10 IBFT=1,NTRANC
|
|
ITR=ITRBF(IBFT)
|
|
SG=CROSS(IBFT,IJ)
|
|
IF(SG.LE.0.) GO TO 10
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10
|
|
JC=ITRA(JJ,II)
|
|
IF(IFWOP(II).GE.0) THEN
|
|
ICDW=MCDW(ITR)
|
|
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
|
|
ELSE
|
|
IMER=IMRG(II)
|
|
SG=SGMG(IMER,ID)
|
|
ENDIF
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
IE=IABS(IIEXP(II))
|
|
JJ=IUP(ITR)
|
|
JE=IABS(IIEXP(JJ))
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
10 CONTINUE
|
|
END DO
|
|
C
|
|
C ----------------
|
|
C Line transitions
|
|
C ----------------
|
|
C
|
|
IF(ISPODF.EQ.0) THEN
|
|
IF(IJLIN(IJ).GT.0) THEN
|
|
C
|
|
C the "primary" line at the given frequency
|
|
C
|
|
ITR=IJLIN(IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
DO 50 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50
|
|
SGW0=PRFLIN(ID,IJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
50 CONTINUE
|
|
c 55 CONTINUE
|
|
ENDIF
|
|
IF(NLINES(IJ).LE.0) GO TO 100
|
|
C
|
|
C the "overlapping" lines at the given frequency
|
|
C
|
|
DO 90 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
if(linexp(itr)) goto 90
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
IJ0=IFR0(ITR)
|
|
DO IJT=IJ0,IFR1(ITR)
|
|
IF(FREQ(IJT).LE.FR) THEN
|
|
IJ0=IJT
|
|
GO TO 70
|
|
END IF
|
|
END DO
|
|
70 IJ1=IJ0-1
|
|
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
|
|
A2=W0-A1
|
|
DO 80 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80
|
|
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
C
|
|
C Opacity sampling option
|
|
C
|
|
ELSE
|
|
IF(NLINES(IJ).LE.0) GO TO 100
|
|
DO 95 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
KJ=IJ-IFR0(ITR)+KFR0(ITR)
|
|
INDXPA=IABS(INDEXP(ITR))
|
|
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
|
|
DO 510 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 510
|
|
SGW0=PRFLIN(ID,KJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
510 CONTINUE
|
|
ELSE
|
|
DO 520 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 520
|
|
KJD=JIDI(ID)
|
|
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
|
|
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
520 CONTINUE
|
|
END IF
|
|
95 CONTINUE
|
|
END IF
|
|
100 CONTINUE
|
|
C
|
|
ELSE IF (IRDER.EQ.1) THEN
|
|
C
|
|
DO 200 IJ=1,NFREQ
|
|
IF(IJX(IJ).EQ.-1) GO TO 200
|
|
FR=FREQ(IJ)
|
|
W0=W0E(IJ)
|
|
LRDER=IJALI(IJ).GT.0
|
|
CALL OPACFD(IJ)
|
|
CALL RTEFR1(IJ)
|
|
CALL ALIFR1(IJ)
|
|
C
|
|
C ---------------------
|
|
C Continuum transitions
|
|
C ---------------------
|
|
C
|
|
DO 120 ID=1,ND
|
|
EXX(ID)=EXP(-HKT1(ID)*FR)
|
|
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
|
|
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
|
|
DO 110 IBFT=1,NTRANC
|
|
ITR=ITRBF(IBFT)
|
|
SG=CROSS(IBFT,IJ)
|
|
IF(SG.LE.0.) GO TO 110
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 110
|
|
JC=ITRA(JJ,II)
|
|
ICDW=MCDW(ITR)
|
|
IMER=IMRG(II)
|
|
IF(IFWOP(II).GE.0) THEN
|
|
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
|
|
ELSE
|
|
SG=SGMG(IMER,ID)
|
|
ENDIF
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
IE=IABS(IIEXP(II))
|
|
JJ=IUP(ITR)
|
|
JE=IABS(IIEXP(JJ))
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
END IF
|
|
END IF
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
C
|
|
C ----------------
|
|
C Line transitions
|
|
C ----------------
|
|
C
|
|
IF(ISPODF.EQ.0) THEN
|
|
IF(IJLIN(IJ).GT.0) THEN
|
|
C
|
|
C the "primary" line at the given frequency
|
|
C
|
|
ITR=IJLIN(IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
DO 150 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150
|
|
SGW0=PRFLIN(ID,IJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
END IF
|
|
END IF
|
|
150 CONTINUE
|
|
c 155 CONTINUE
|
|
ENDIF
|
|
IF(NLINES(IJ).LE.0) GO TO 200
|
|
C
|
|
C the "overlapping" lines at the given frequency
|
|
C
|
|
DO 190 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
if(linexp(itr)) goto 190
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
IJ0=IFR0(ITR)
|
|
DO 160 IJT=IJ0,IFR1(ITR)
|
|
IF(FREQ(IJT).LE.FR) THEN
|
|
IJ0=IJT
|
|
GO TO 170
|
|
END IF
|
|
160 CONTINUE
|
|
170 IJ1=IJ0-1
|
|
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
|
|
A2=W0-A1
|
|
DO 180 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 180
|
|
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
END IF
|
|
END IF
|
|
180 CONTINUE
|
|
190 CONTINUE
|
|
C
|
|
C Opacity sampling option
|
|
C
|
|
ELSE
|
|
IF(NLINES(IJ).LE.0) GO TO 200
|
|
DO 195 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
KJ=IJ-IFR0(ITR)+KFR0(ITR)
|
|
INDXPA=IABS(INDEXP(ITR))
|
|
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
|
|
DO 610 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 610
|
|
SGW0=PRFLIN(ID,KJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
END IF
|
|
END IF
|
|
610 CONTINUE
|
|
ELSE
|
|
DO 620 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 620
|
|
KJD=JIDI(ID)
|
|
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
|
|
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
|
|
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
|
|
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
|
|
END IF
|
|
END IF
|
|
620 CONTINUE
|
|
END IF
|
|
195 CONTINUE
|
|
END IF
|
|
200 CONTINUE
|
|
C
|
|
ELSE IF (IRDER.EQ.2) THEN
|
|
C
|
|
DO 300 IJ=1,NFREQ
|
|
IF(IJX(IJ).EQ.-1) GO TO 300
|
|
FR=FREQ(IJ)
|
|
W0=W0E(IJ)
|
|
LRDER=IJALI(IJ).GT.0
|
|
CALL OPACFD(IJ)
|
|
CALL RTEFR1(IJ)
|
|
CALL ALIFR1(IJ)
|
|
C
|
|
C ---------------------
|
|
C Continuum transitions
|
|
C ---------------------
|
|
C
|
|
DO ID=1,ND
|
|
EXX(ID)=EXP(-HKT1(ID)*FR)
|
|
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
|
|
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
|
|
DO 210 IBFT=1,NTRANC
|
|
ITR=ITRBF(IBFT)
|
|
SG=CROSS(IBFT,IJ)
|
|
IF(SG.LE.0.) GO TO 210
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 210
|
|
JC=ITRA(JJ,II)
|
|
ICDW=MCDW(ITR)
|
|
IMER=IMRG(II)
|
|
IF(IFWOP(II).GE.0) THEN
|
|
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
|
|
ELSE
|
|
SG=SGMG(IMER,ID)
|
|
ENDIF
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
IE=IABS(IIEXP(II))
|
|
JJ=IUP(ITR)
|
|
JE=IABS(IIEXP(JJ))
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
210 CONTINUE
|
|
END DO
|
|
C
|
|
C ----------------
|
|
C Line transitions
|
|
C ----------------
|
|
C
|
|
IF(ISPODF.EQ.0) THEN
|
|
IF(IJLIN(IJ).GT.0) THEN
|
|
C
|
|
C the "primary" line at the given frequency
|
|
C
|
|
ITR=IJLIN(IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
DO 250 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 250
|
|
SGW0=PRFLIN(ID,IJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
250 CONTINUE
|
|
ENDIF
|
|
IF(NLINES(IJ).LE.0) GO TO 300
|
|
C
|
|
C the "overlapping" lines at the given frequency
|
|
C
|
|
DO 290 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
if(linexp(itr)) goto 290
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
IJ0=IFR0(ITR)
|
|
DO IJT=IJ0,IFR1(ITR)
|
|
IF(FREQ(IJT).LE.FR) THEN
|
|
IJ0=IJT
|
|
GO TO 270
|
|
END IF
|
|
END DO
|
|
270 IJ1=IJ0-1
|
|
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
|
|
A2=W0-A1
|
|
DO 280 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 280
|
|
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
|
|
* AND.IABS(IMODL(II)).NE.4) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
280 CONTINUE
|
|
290 CONTINUE
|
|
C
|
|
C Opacity sampling option
|
|
C
|
|
ELSE
|
|
IF(NLINES(IJ).LE.0) GO TO 300
|
|
DO 295 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(ITR)
|
|
IE=IABS(IIEXP(II))
|
|
JE=IABS(IIEXP(JJ))
|
|
KJ=IJ-IFR0(ITR)+KFR0(ITR)
|
|
INDXPA=IABS(INDEXP(ITR))
|
|
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
|
|
DO 710 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 710
|
|
SGW0=PRFLIN(ID,KJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
710 CONTINUE
|
|
ELSE
|
|
DO 720 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 720
|
|
KJD=JIDI(ID)
|
|
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
|
|
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
|
|
SGW0=SG*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
|
|
IF(LRDER) THEN
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
|
|
NREFI=NREFS(IATM(II),ID)
|
|
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
|
|
* .AND.IABS(IMODL(II)).NE.4) THEN
|
|
DO KK=1,NLVEXP
|
|
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
|
|
END DO
|
|
END IF
|
|
END IF
|
|
720 CONTINUE
|
|
END IF
|
|
295 CONTINUE
|
|
END IF
|
|
300 CONTINUE
|
|
C
|
|
ELSE
|
|
CALL QUIT(' Invalid IRDER - ALIST2',irder,irder)
|
|
END IF
|
|
C
|
|
C multiply some quantities by frequency-independent constants
|
|
C
|
|
DO ID=1,ND
|
|
REDX(ID)=REDX(ID)*WMM(ID)*DENS1(ID)*DENS1(ID)
|
|
IF(ID.GT.1) REDXM(ID)=REDXM(ID)*WMM(ID)*
|
|
* DENS1(ID-1)*DENS1(ID-1)
|
|
FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID)
|
|
IF(CRSW(ID).NE.UN) THEN
|
|
DO ITR=1,NTRANS
|
|
RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID)
|
|
DRDT(ITR,ID)=DRDT(ITR,ID)*CRSW(ID)
|
|
END DO
|
|
C IF(LRDER) THEN
|
|
IF(IRDER.GT.0) THEN
|
|
DO II=1,NLVEXP
|
|
APT(II,ID)=APT(II,ID)*CRSW(ID)
|
|
APN(II,ID)=APN(II,ID)*CRSW(ID)
|
|
DO JJ=1,NLVEXP
|
|
APP(JJ,II,ID)=APP(JJ,II,ID)*CRSW(ID)
|
|
END DO
|
|
END DO
|
|
END IF
|
|
END IF
|
|
END DO
|
|
C
|
|
C radiation pressure
|
|
C
|
|
PRDX=1.
|
|
DO ID=1,ND
|
|
PRADT(ID)=PRADT(ID)*PCK
|
|
PRADA(ID)=PRADA(ID)*PCK
|
|
if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID)
|
|
IF(PRDR.LT.PRDX) PRDX=PRDR
|
|
END DO
|
|
PRD0=PRD0/DENS1(1)*DM(1)*PCK
|
|
IF(LFIN) WRITE(10,1100) PRDX,ITER
|
|
1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4)
|
|
C
|
|
C Rosseland mean opacity
|
|
C
|
|
IF(LROSS) THEN
|
|
DO ID=1,ND
|
|
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
|
|
END DO
|
|
if(ioptab.lt.0.and.ifryb.gt.0) then
|
|
do id=1,nd
|
|
abrosd(id)=abrosd(id)*dens(id)
|
|
end do
|
|
end if
|
|
call rosstd(0)
|
|
END IF
|
|
c
|
|
|
|
RETURN
|
|
END
|