git push -u origin main
This commit is contained in:
@@ -0,0 +1,223 @@
|
||||
SUBROUTINE OPAC(ID,CROSS,ABSO,EMIS,SCAT)
|
||||
C ========================================
|
||||
C
|
||||
C Absorption, emission, and scattering coefficients
|
||||
C at depth ID and for several frequencies (some or all)
|
||||
C
|
||||
C Input: ID - depth index
|
||||
C CROSS - two dimensional array of photoionization
|
||||
C cross-sections
|
||||
C Output: ABSO - array of absorption coefficient
|
||||
C EMIS - array of emission coefficient
|
||||
C SCAT - array of scattering coefficient (all scattering
|
||||
C mechanisms except electron scattering)
|
||||
C
|
||||
C
|
||||
INCLUDE 'PARAMS.FOR'
|
||||
INCLUDE 'MODELP.FOR'
|
||||
INCLUDE 'LINDAT.FOR'
|
||||
INCLUDE 'SYNTHP.FOR'
|
||||
DIMENSION CROSS(MCROSS,MFRQ)
|
||||
DIMENSION ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ),
|
||||
* ABLIN(MFREQ),EMLIN(MFREQ)
|
||||
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
|
||||
common/dissol/fropc(mlevel),indexp(mlevel)
|
||||
PARAMETER (UN=1.,TEN15=1.E-15,CSB=2.0706E-16,CFF=3.694E8)
|
||||
C
|
||||
IF(IMODE.EQ.-1.AND.ID.NE.IDSTD) RETURN
|
||||
T=TEMP(ID)
|
||||
ANE=ELEC(ID)
|
||||
T1=UN/T
|
||||
HKT=HK*T1
|
||||
TK=HKT/H
|
||||
SRT=UN/SQRT(T)
|
||||
SGFF=CFF*SRT
|
||||
CON=CSB*T1*SRT
|
||||
conts=1.e-36/con
|
||||
ABLY=0.
|
||||
EMLY=0.
|
||||
SCLY=0.
|
||||
sce=ane*sige
|
||||
IJ0=2
|
||||
IF(NFREQ.EQ.1) IJ0=1
|
||||
IF(IMODE.EQ.2) IJ0=NFREQ
|
||||
M=3
|
||||
IF(ICONTL.EQ.1) M=1
|
||||
C
|
||||
C Opacity and emissivity in continuum
|
||||
C **** calculated only in the first and the last frequency *****
|
||||
C
|
||||
DO 200 IJ=1,IJ0
|
||||
FR=FREQ(IJ)
|
||||
FR15=FR*TEN15
|
||||
BNU=BN*FR15*FR15*FR15
|
||||
HKF=HKT*FR
|
||||
ABF=0.
|
||||
EBF=0.
|
||||
AFF=0.
|
||||
DO 100 IL=1,NION
|
||||
N0I=NFIRST(IL)
|
||||
N1I=NLAST(IL)
|
||||
NKE=NNEXT(IL)
|
||||
XN=POPUL(NKE,ID)
|
||||
C
|
||||
C Bound-free contribution + possibly
|
||||
c pseudo-continuum (accounting for dissolved fraction)
|
||||
C
|
||||
DO 10 II=N0I,N1I
|
||||
SG=0.
|
||||
IF(IFWOP(II).LT.0) THEN
|
||||
SG=SGMERG(II,ID,FR)
|
||||
ELSE
|
||||
SG=CROSS(II,IJ)
|
||||
IF(INDEXP(II).EQ.5) THEN
|
||||
IZZ=IZ(IEL(II))
|
||||
FR0=ENION(II)/6.6256E-27
|
||||
CALL DWNFR1(FR,FR0,ID,IZZ,DW1)
|
||||
SG=SG*DW1
|
||||
END IF
|
||||
END IF
|
||||
if(sg.le.0.) go to 10
|
||||
ABF=ABF+SG*POPUL(II,ID)
|
||||
XX=SG*XN*EXP(ENION(II)*TK)*WOP(II,ID)
|
||||
IF(XX.lt.conts) go to 10
|
||||
EBF=EBF+XX*CON*G(II)/G(NKE)
|
||||
10 CONTINUE
|
||||
|
||||
IT=IFREE(IL)
|
||||
IF(IT.EQ.0) GO TO 100
|
||||
C
|
||||
C Free-free contribution
|
||||
C
|
||||
IE=IL
|
||||
IF(IE.EQ.IELHM) GO TO 65
|
||||
CH=IZ(IL)*IZ(IL)
|
||||
SF1=CH*XN*SGFF/(FR*FR*FR)
|
||||
C
|
||||
C The following expression is the so-called modified free-free
|
||||
C opacity, ie. allowing for the photoionization from higher,
|
||||
C non-explicit, LTE energy levels of the ion IL
|
||||
C
|
||||
HKFM=HKT*MIN(FF(IL),FR)
|
||||
SF2=EXP(HKFM)
|
||||
IF(IT.NE.2) GO TO 50
|
||||
SG=GFREE(T,FR/CH)
|
||||
SF2=SF2+SG-UN
|
||||
50 SFF=SF1*SF2
|
||||
GO TO 70
|
||||
65 SFF=SFFHMI(XN,FR,T)
|
||||
70 AFF=AFF+SFF
|
||||
100 CONTINUE
|
||||
C
|
||||
C Additional opacities
|
||||
C
|
||||
CALL OPADD(0,ID,FR,ABAD,EMAD,SCAD)
|
||||
IF(IOPHLI.NE.0) CALL LYMLIN(ID,FR,ABLY,EMLY,SCLY)
|
||||
C
|
||||
C Total opacity and emissivity
|
||||
C
|
||||
X=EXP(-HKF)
|
||||
X1=UN-X
|
||||
BNE=BNU*X*ANE
|
||||
c ABSO(IJ)=ABF+ANE*(X1*AFF-X*EBF)+ABAD+ABLY
|
||||
ABSO(IJ)=ABF+ANE*(X1*AFF-X*EBF)+ABAD
|
||||
EMIS(IJ)=BNE*(AFF+EBF)+EMAD+EMLY
|
||||
SCAT(IJ)=SCAD+SCLY+sce
|
||||
IF(IJ.EQ.1) THEN
|
||||
ABLY1=ABLY
|
||||
EMLY1=EMLY
|
||||
SCLY1=SCLY
|
||||
END IF
|
||||
200 CONTINUE
|
||||
AVAB=(ABSO(1)+ABSO(2)+SCAT(1)+SCAT(2))*0.5*RELOP
|
||||
IF(NFREQ.LE.2.OR.IMODE.EQ.-1) RETURN
|
||||
IF(IMODE.EQ.2) GO TO 225
|
||||
C
|
||||
C interpolated continuum opacity, emissivity, and scattering
|
||||
C for all frequencies
|
||||
C
|
||||
DO IJ=3,NFREQ
|
||||
ABSO(IJ)=FRX1(IJ)*ABSO(2)+FRX2(IJ)*ABSO(1)
|
||||
EMIS(IJ)=FRX1(IJ)*EMIS(2)+FRX2(IJ)*EMIS(1)
|
||||
SCAT(IJ)=FRX1(IJ)*SCAT(2)+FRX2(IJ)*SCAT(1)
|
||||
END DO
|
||||
C
|
||||
C hydrogen lines -- for IHYL = 0
|
||||
C *** calculated only for the first and the last frequency
|
||||
C and interpolated hydrogen line opacity and emissivity
|
||||
C for all frequencies
|
||||
C
|
||||
IF(IHYL.EQ.0) THEN
|
||||
CALL HYDLIN(ID,1,2,ABLIN,EMLIN)
|
||||
DO IJ=M,NFREQ
|
||||
ABSO(IJ)=ABSO(IJ)+FRX1(IJ)*ABLIN(2)+FRX2(IJ)*ABLIN(1)
|
||||
EMIS(IJ)=EMIS(IJ)+FRX1(IJ)*EMLIN(2)+FRX2(IJ)*EMLIN(1)
|
||||
END DO
|
||||
END IF
|
||||
C
|
||||
C **** Opacity and emissivity in lines ****
|
||||
C
|
||||
CALL LINOP(ID,ABLIN,EMLIN,AVAB)
|
||||
DO IJ=3,NFREQ
|
||||
ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
|
||||
EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
|
||||
END DO
|
||||
C
|
||||
C **** Opacity and emissivity in molecular lines ****
|
||||
C
|
||||
if(ifmol.gt.0) then
|
||||
do ilist=1,nmlist
|
||||
CALL MOLOP(ID,ABLIN,EMLIN,AVAB,ILIST)
|
||||
DO IJ=3,NFREQ
|
||||
ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
|
||||
EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
|
||||
END DO
|
||||
end do
|
||||
end if
|
||||
225 CONTINUE
|
||||
C
|
||||
C **** Detailed opacity and emissivity in hydrogen lines ****
|
||||
C (for IHYL=1)
|
||||
C
|
||||
IF(IHYL.GT.0.OR.IMODE.EQ.2) THEN
|
||||
CALL HYDLIN(ID,M,NFREQ,ABLIN,EMLIN)
|
||||
DO IJ=M,NFREQ
|
||||
ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
|
||||
EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
|
||||
END DO
|
||||
END IF
|
||||
C
|
||||
C **** Detailed opacity and emissivity in HE II lines ****
|
||||
C (for IHE2L=1)
|
||||
C
|
||||
IF(IHE2L.GT.0) THEN
|
||||
CALL HE2LIN(ID,M,NFREQ,ABLIN,EMLIN)
|
||||
DO IJ=M,NFREQ
|
||||
ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
|
||||
EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
|
||||
END DO
|
||||
END IF
|
||||
C
|
||||
C opacity due to detailed photoinization cross-section
|
||||
C (from tables; including resonance features)
|
||||
C The two routines may be called and correspond to different formats
|
||||
C as well as difference in INPUT!
|
||||
C
|
||||
CALL PHTION(ID,ABSO,EMIS,FREQ,NFREQ)
|
||||
CALL PHTX(ID,ABSO,EMIS,FREQ,0)
|
||||
C
|
||||
if(imode.ge.0) then
|
||||
do ij=1,nfreq
|
||||
abso(ij)=abso(ij)+scat(ij)
|
||||
end do
|
||||
end if
|
||||
C
|
||||
IF(ICONTL.EQ.1) RETURN
|
||||
ABSO(1)=ABSO(1)-ABLY1
|
||||
EMIS(1)=EMIS(1)-EMLY1
|
||||
SCAT(1)=SCAT(1)-SCLY1
|
||||
ABSO(2)=ABSO(2)-ABLY
|
||||
EMIS(2)=EMIS(2)-EMLY
|
||||
SCAT(2)=SCAT(2)-SCLY
|
||||
RETURN
|
||||
END
|
||||
Reference in New Issue
Block a user