fmq/SpectraRust
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
f286ddacfe
SpectraRust/tlusty/extracted/opacfl.f
Asfmq 1e30b7bc63 git push -u origin main
2026-03-19 14:05:33 +08:00

281 lines
7.9 KiB
Fortran
Raw Blame History

SUBROUTINE OPACFL(IJ)
C =====================
C
C Absorption, emission, and scattering coefficients
C at frequency IJ and for all depths
C
C Input: IJ opacity and emissivity is calculated for the
C frequency points with index IJ
C Output: ABSO1 - array of absorption coefficient
C EMIS1 - array of emission coefficient
C SCAT1 - array of scattering coefficient (all scattering
C mechanisms except electron scattering)
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
PARAMETER (C14=2.99793D14, CFF1=1.3727D-25)
C
C initialize
c
DO ID=1,ND
ABSO1(ID)=ELSCAT(ID)
EMIS1(ID)=0.
SCAT1(ID)=ELSCAT(ID)
ABSO1L(ID)=0.
EMIS1L(ID)=0.
END DO
C
C basic frequency- and depth-dependent quantities
C
FR=FREQ(IJ)
FRINV=UN/FR
FR3INV=FRINV*FRINV*FRINV
DO ID=1,ND
XKF(ID)=EXP(-HKT1(ID)*FR)
XKF1(ID)=UN-XKF(ID)
XKFB(ID)=XKF(ID)*BNUE(IJ)
END DO
lfre=fr.gt.frtabm
C
C ******** 1a. bound-free contribution - without dielectronic rec.
C
if(ifdiel.eq.0) then
DO IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
idp=iadop(iatm(ii))
if(sg.gt.0.and.(idp.eq.0.or.(idp.gt.0.and.lfre))) then
IZZ=IZ(IEL(II))
IMER=IMRG(II)
DO ID=1,ND
SGD=SG
IF(MCDW(ITR).GT.0) THEN
CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1)
DWF1(MCDW(ITR),ID)=DW1
SGD=SG*DW1
END IF
IF(IFWOP(II).LT.0) THEN
CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1)
SGMG(IMER,ID)=SGME1
SGD=SGME1
END IF
EMISBF=SGD*EMTRA(ITR,ID)
ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+EMISBF
if(iluctr(itr).gt.0) then
ABSO1L(ID)=ABSO1L(ID)+SGD*ABTRA(ITR,ID)
EMIS1L(ID)=EMIS1L(ID)+EMISBF
end if
END DO
END IF
END DO
else
C
C ******** 1. bound-free contribution - with dielectronic rec.
C
DO IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
idp=iadop(iatm(ii))
if(sg.gt.0.and.(idp.eq.0.or.(idp.gt.0.and.lfre))) then
IZZ=IZ(IEL(II))
IMER=IMRG(II)
DO ID=1,ND
SG=CROSSD(IBFT,IJ,ID)
IF(SG.GT.0.) THEN
SGD=SG
IF(MCDW(ITR).GT.0) THEN
CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1)
DWF1(MCDW(ITR),ID)=DW1
SGD=SG*DW1
END IF
IF(IFWOP(II).LT.0) THEN
CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1)
SGMG(IMER,ID)=SGME1
SGD=SGME1
END IF
EMISBF=SGD*EMTRA(ITR,ID)
ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+EMISBF
if(iluctr(itr).eq.0) then
ABSO1L(ID)=ABSO1L(ID)+SGD*ABTRA(ITR,ID)
EMIS1L(ID)=EMIS1L(ID)+EMISBF
endif
END IF
END DO
END IF
END DO
end if
C
C ******** 2. free-free contribution
C
DO 40 ION=1,NION
IT=ITRA(NNEXT(ION),NNEXT(ION))
idp=iadop(iatm(nnext(ion)))
if(idp.gt.0.and..not.lfre) go to 40
C
C hydrogenic with Gaunt factor = 1
C
IF(IT.EQ.1) THEN
DO ID=1,ND
SF1=SFF3(ION,ID)*FR3INV
SF2=SFF2(ION,ID)
IF(FR.LT.FF(ION)) SF2=UN/XKF(ID)
ABSOFF=SF1*SF2
ABSO1(ID)=ABSO1(ID)+ABSOFF
EMIS1(ID)=EMIS1(ID)+ABSOFF
END DO
C
C hydrogenic with exact Gaunt factor
C
ELSE IF(IT.EQ.2) THEN
DO ID=1,ND
SF1=SFF3(ION,ID)*FR3INV
SF2=SFF2(ION,ID)
IF(FR.LT.FF(ION)) SF2=UN/XKF(ID)
X=C14*CHARG2(ION)/FR
SF2=SF2-UN+GFREE1(ID,X)
ABSOFF=SF1*SF2
ABSO1(ID)=ABSO1(ID)+ABSOFF
EMIS1(ID)=EMIS1(ID)+ABSOFF
END DO
C
C H minus free-free opacity
C
ELSE IF(IT.EQ.3) THEN
DO ID=1,ND
ABSOFF=SFFHMI(POPUL(NFIRST(IELH),ID),FR,TEMP(ID))*
* ELEC(ID)
ABSO1(ID)=ABSO1(ID)+ABSOFF
EMIS1(ID)=EMIS1(ID)+ABSOFF
END DO
C
C special evaluation of the cross-section
C
ELSE IF(IT.LT.0) THEN
DO ID=1,ND
ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)*
* POPUL(NNEXT(ION),ID)*ELEC(ID)
ABSO1(ID)=ABSO1(ID)+ABSOFF
EMIS1(ID)=EMIS1(ID)+ABSOFF
END DO
END IF
40 CONTINUE
C
C ******** 3. - additional continuum opacity (OPADD)
C
IF(IOPADD.NE.0) THEN
ICALL=1
DO ID=1,ND
CALL OPADD(0,ICALL,IJ,ID)
ABSO1(ID)=ABSO1(ID)+ABAD
EMIS1(ID)=EMIS1(ID)+EMAD
SCAT1(ID)=SCAT1(ID)+SCAD
END DO
END IF
C
C ******** 4. - opacity and emissivity in lines
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)
iad=iadop(iatm(ilow(itr)))
if(iad.eq.0.or.(lfre.and.iad.gt.0)) then
DO ID=1,ND
SG=PRFLIN(ID,IJ)
ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID)
END DO
if(iluctr(itr).gt.0) then
DO ID=1,ND
SG=PRFLIN(ID,IJ)
ABSO1L(ID)=ABSO1L(ID)+SG*ABTRA(ITR,ID)
EMIS1L(ID)=EMIS1L(ID)+SG*EMTRA(ITR,ID)
END DO
end if
end if
END IF
IF(NLINES(IJ).LE.0) GO TO 200
C
C the "overlapping" lines at the given frequency
C
DO 100 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
iad=iadop(iatm(ilow(itr)))
if(iad.gt.0.and..not.lfre) go to 100
if(linexp(itr)) go to 100
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))
A2=UN-A1
DO ID=1,ND
SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID)
END DO
100 CONTINUE
200 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 400
DO 300 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
iad=iadop(iatm(ilow(itr)))
if(iad.gt.0.and..not.lfre) go to 300
c IF(LINEXP(ITR)) GO TO 300
C IF(IJ.LT.IFR0(ITR) .OR. IJ.GT.IFR1(ITR)) GO TO 300
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO ID=1,ND
SG=PRFLIN(ID,KJ)
ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID)
END DO
ELSE
DO ID=1,ND
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID)
EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID)
END DO
END IF
300 CONTINUE
400 CONTINUE
END IF
C
C ----------------------------
C total opacity and emissivity
C ----------------------------
C
DO ID=1,ND
ABSO1(ID)=ABSO1(ID)-EMIS1(ID)*XKF(ID)
EMIS1(ID)=EMIS1(ID)*XKFB(ID)
ABSO1L(ID)=ABSO1L(ID)-EMIS1L(ID)*XKF(ID)
EMIS1L(ID)=EMIS1L(ID)*XKFB(ID)
ABSO1L(ID)=ABSO1(ID)-ABSO1L(ID)
EMIS1L(ID)=EMIS1(ID)-EMIS1L(ID)
END DO
RETURN
END
Reference in New Issue View Git Blame Copy Permalink