189 lines
5.1 KiB
Fortran
189 lines
5.1 KiB
Fortran
SUBROUTINE RATES1(IMOR)
|
|
C ======================
|
|
C
|
|
C Evaluation of radiative rates
|
|
C
|
|
C Output (transferred by COMMON blocks):
|
|
C RRU(IT,ID) - upward radiative rate in transition IT and
|
|
C depth ID
|
|
C RRD(IT,ID) - analogously the downward rate; more precisely
|
|
C the exact downward rate is given by:
|
|
C lines : RRD * stat.weight(lower)/stat.weight(upper)
|
|
C continua: RRD * n(elec) * Saha-Boltzmann factor
|
|
C
|
|
INCLUDE 'IMPLIC.FOR'
|
|
INCLUDE 'BASICS.FOR'
|
|
INCLUDE 'ATOMIC.FOR'
|
|
INCLUDE 'MODELQ.FOR'
|
|
INCLUDE 'ODFPAR.FOR'
|
|
INCLUDE 'ALIPAR.FOR'
|
|
INCLUDE 'ITERAT.FOR'
|
|
DIMENSION RBNE(MDEPTH)
|
|
C DIMENSION EHKL(MFREQL)
|
|
C
|
|
C zero the rates
|
|
C
|
|
DO ID=1,ND
|
|
PRADT(ID)=0.
|
|
PRADA(ID)=0.
|
|
FLRD(ID)=0.
|
|
DO ITR=1,NTRANS
|
|
RRU(ITR,ID)=0.
|
|
RRD(ITR,ID)=0.
|
|
END DO
|
|
DO ITRP=1,NTRPRD
|
|
PJBAR(ITRP,ID)=0.
|
|
END DO
|
|
END DO
|
|
PRD0=0.
|
|
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) GOTO 100
|
|
FR=FREQ(IJ)
|
|
W0=W0E(IJ)
|
|
WW=W(IJ)
|
|
CALL OPACF1(IJ)
|
|
IF(IMOR.EQ.0) THEN
|
|
CALL RTEFR1(IJ)
|
|
ELSE
|
|
RAD1(ID)=RAD(IJ,ID)
|
|
END IF
|
|
IF(LROSS) CALL ROSSTD(IJ)
|
|
FLRD(1)=FLRD(1)+WW*FH(IJ)*RAD1(1)-WW*HEXTRD(IJ)
|
|
DO ID=2,ND
|
|
DT=UN/(ABSOT(ID)+ABSOT(ID-1))/DELDMZ(ID-1)
|
|
FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT
|
|
FLRD(ID)=FLRD(ID)+WW*FL
|
|
END DO
|
|
if(ioptab.lt.0) go to 100
|
|
C
|
|
C ---------------------
|
|
C Continuum transitions
|
|
C ---------------------
|
|
C
|
|
DO ID=1,ND
|
|
RBNE(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR)
|
|
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*RBNE(ID)
|
|
10 CONTINUE
|
|
END DO
|
|
C
|
|
C ----------------
|
|
C Line transitions
|
|
C ----------------
|
|
C
|
|
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)
|
|
DO 50 ID=1,ND
|
|
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50
|
|
SGW=PRFLIN(ID,IJ)*W0
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW*RBNE(ID)
|
|
50 CONTINUE
|
|
c
|
|
itrprd=iprd(itr)
|
|
if(itrprd.gt.0) then
|
|
s=un/(0.02654*osc0(itr))
|
|
do id=1,nd
|
|
sg=prflin(id,ij)*s
|
|
pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id)
|
|
end do
|
|
end if
|
|
c
|
|
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
|
|
IJ0=IFR0(ITR)
|
|
II=ILOW(ITR)
|
|
JJ=IUP(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
|
|
SGW=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
|
|
RRU(ITR,ID)=RRU(ITR,ID)+SGW*RAD1(ID)
|
|
RRD(ITR,ID)=RRD(ITR,ID)+SGW*RBNE(ID)
|
|
80 CONTINUE
|
|
c
|
|
itrprd=iprd(itr)
|
|
if(itrprd.gt.0) then
|
|
s=un/(0.02654*osc0(itr))
|
|
do id=1,nd
|
|
SG=(A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0))*s
|
|
pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id)
|
|
end do
|
|
end if
|
|
c
|
|
90 CONTINUE
|
|
100 CONTINUE
|
|
C
|
|
DO ID=1,ND
|
|
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)
|
|
END DO
|
|
END IF
|
|
END DO
|
|
C
|
|
C radiation pressure
|
|
C
|
|
DO ID=1,ND
|
|
PRADT(ID)=PRADT(ID)*PCK
|
|
PRADA(ID)=PRADA(ID)*PCK
|
|
END DO
|
|
PRD0=PRD0/DENS1(1)*DM(1)*PCK
|
|
C
|
|
C Rosseland mean opacity
|
|
C
|
|
IF(LROSS) THEN
|
|
DO ID=1,ND
|
|
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
|
|
END DO
|
|
END IF
|
|
c
|
|
RETURN
|
|
END
|