git push -u origin main

2026-03-19 14:05:33 +08:00
commit 1e30b7bc63
739 changed files with 572150 additions and 0 deletions
@@ -0,0 +1,126 @@
+      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