224 lines
6.2 KiB
Fortran
224 lines
6.2 KiB
Fortran
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
|