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