127 lines
3.6 KiB
Fortran
127 lines
3.6 KiB
Fortran
SUBROUTINE OPACON(ID,CROSS,ABSOC,EMISC,SCATC)
|
|
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
|
|
C
|
|
C
|
|
INCLUDE 'PARAMS.FOR'
|
|
INCLUDE 'MODELP.FOR'
|
|
INCLUDE 'LINDAT.FOR'
|
|
INCLUDE 'SYNTHP.FOR'
|
|
INCLUDE 'WINCOM.FOR'
|
|
DIMENSION CROSS(MCROSS,MFRQ)
|
|
DIMENSION ABSOC(MFREQC),EMISC(MFREQC),SCATC(MFREQC)
|
|
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
|
|
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
|
|
ABLY=0.
|
|
EMLY=0.
|
|
SCLY=0.
|
|
sce=ane*sige
|
|
C
|
|
C Opacity and emissivity in continuum
|
|
C **** calculated only for the continuum frequencies *****
|
|
C
|
|
DO 200 IJ=1,NFREQC
|
|
FR=FREQC(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(sg.le.0.) go to 10
|
|
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(popul(ii,id).lt.1.e-20.or.xn.lt.1.e-20) go to 10
|
|
ABF=ABF+SG*POPUL(II,ID)
|
|
XX=SG*XN*EXP(ENION(II)*TK-hkf)*WOP(II,ID)
|
|
ee=exp(enion(ii)*tk-hkf)
|
|
EBF=EBF+XX*CON*G(II)/G(NKE)
|
|
c if(id.eq.1.or.id.eq.50) write(*,*)'opacon',id,ij,ii,
|
|
c * popul(ii,id),sg,abf
|
|
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
|
|
IF(IT.NE.2) GO TO 50
|
|
SG=GFREE(T,FR/CH)
|
|
SF2=SF2+SG-UN
|
|
50 SFF=SF1
|
|
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
|
|
ABSOC(IJ)=ABF+ANE*(X1*AFF-EBF)+ABAD+ABLY
|
|
EMISC(IJ)=BNE*AFF+BNU*ANE*EBF+EMAD+EMLY
|
|
SCATC(IJ)=SCAD+SCLY+sce
|
|
c if(id.eq.1.or.id.eq.50) write(*,*)'opacon-tot',id,ij,
|
|
c * abf,ane,absoc(ij)
|
|
|
|
200 CONTINUE
|
|
C
|
|
CALL PHTION(ID,ABSOC,EMISC,FREQC,NFREQC)
|
|
CALL PHTX(ID,ABSOC,EMISC,FREQC,1)
|
|
C
|
|
RETURN
|
|
END
|