1C
2C
3C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
4C EQSTAT
5C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
6
7 SUBROUTINE EQSTAT2(TL,T,PL,P,DL,D,X,Z,BETA,BETAI,BETA14,FXION,
8 * *RMU,AMU,EMU,ETA,QDT,QDP,QCP,DELA,QDTT,QDTP,QAT,QAP,QCPT,QCPP,
9 * *LDERIV,LATMO,KSAHA)
10C 10/14/26 MHP via Claude
11C code changed to convert COMMON/COMP/ into COMP_MOD.
12 USE COMP_MOD
13C 10/14/26 MHP via Claude
14C code changed to convert COMMON/NMLPAR/ into NMLPAR_MOD.
15 USE NMLPAR_MOD
16C 10/14/26 MHP via Claude
17C code changed to convert COMMON/CONSTANTS/ into CONSTANTS_MOD.
18 USE CONSTANTS_MOD
19C 10/14/26 MHP via Claude
20C code changed to convert COMMON/IOUNITS/ into IOUNITS_MOD.
21 USE IOUNITS_MOD
22C 10/20/26 MHP via Claude
23C code changed to replace implicit typing with IMPLICIT NONE and
24C explicit declarations.
25 IMPLICIT NONE
26 REAL*8 AMU,AMUI,AMUO,ATOMW2,ATOMWT,BETA,BETA14,BETA14O,BETAI,
27 * * BETAIO,BETAO,D,D1,D10O,DELA,DELA0,DELA1,DELA2,DELAO,DFX1,
28 * * DFX12,DFX4,DL,DL0,DL1,DOO,DPL,DPL2,DTL,DTL2,DXX,DYY,EMU,
29 * * EMUO,ETA,FAC,FMUENV,FX,FXION,P,PL,PPL,QAP,QAP0,QAP1,QAT,
30 * * QAT0,QAT1,QCP,QCP0,QCP1,QCP2,QCPO,QCPP,QCPP0,QCPP1,QCPT,
31 * * QCPT0,QCPT1,QDP,QDP0,QDP1,QDP2,QDPO,QDT,QDT0,QDT1,QDT2,
32 * * QDTO,QDTP,QDTP0,QDTP1,QDTT,QDTT0,QDTT1,R1A,RAA,RAT,RMU,
33 * * RMUO,SCALES,SCALET,T,TL,TTL,WT0,WTS,WTS2,X,Z,Z0
34 INTEGER I,KSAHA,NZP1
35 LOGICAL*4 LATMO,LCALC,LCALC1,LCALC2,LDERIV,LONLYS,LRAMP,LSAHA,
36 * * LSCVD,LTAB
37c
38c Input Arguments: TL, PL, X, Z, LDERIV, LATMO
39c
40c Output Arguments: T, P, D, DL, BETA, BETAI, BETA14, FXION, RMU, AMU,
41c EMU, QDT, QDP, QCP, DELA, QDTT, QDTP, QAT, QAP, QCPT, QCPP,
42c
43c Update (Input and Output) Arguments: KSAHA
44c
45
46C KC 2025-05-30 addressed warning messages from Makefile.legacy
47C SAVE
48C 9/25/26 MHP via Claude
49C code changed to consolidate all I/O logical unit numbers, previously
50C scattered across COMMON/LUOUT/, COMMON/LUNUM/, COMMON/ALEX06/,
51C COMMON/ACDPTH/, COMMON/NEWOPAC/, COMMON/LOPAL95/, COMMON/ATMOS2/,
52C COMMON/ALATM03/, COMMON/OPALEOS/, and COMMON/SCV2/, into a single
53C COMMON/IOUNITS/
54 DIMENSION FX(12),ATOMWT(4),FXION(3),ATOMW2(12)
55C 10/12/26 MHP via Claude
56C code changed to extend COMMON/NMLPAR/ to 234 members, adding the
57C namelist variables that the physics routines read from 27 COMMON
58C blocks which also held derived or working members. Those blocks keep
59C only their non-namelist members; five of them -- NEWMX, VMULT,
60C PMMWIND, CCOUT1 and ENVGEN -- had nothing left and are gone.
61C Derivation-only namelist variables from the same blocks went to
62C COMMON/NMLBYPASS/ instead, not here.
63C
64C Declared identically in all 121 files that hold any of these members.
65C Generated from one member list, so every copy is byte-identical; the
66C linker's 'size of symbol changed' warning is the check that they are.
67C 10/13/26 MHP via Claude
68C code changed to drop COMMON/CTLIM/, declared here but never used.
69C 9/25/26 MHP via Claude
70C code changed to merge COMMON/CONST/, COMMON/CONST1/, COMMON/CONST2/,
71C and COMMON/CONST3/ into a single COMMON/CONSTANTS/
72C 10/13/26 MHP via Claude: removed the unused COMMON/DEBHU/ declaration
73C (no member referenced here; residue of the obsolete-option removals).
74C 10/13/26 MHP via Claude: removed the unused COMMON/SCVEOS/ declaration
75C (no member referenced here; residue of the obsolete-option removals).
76 DATA NZP1/12/
77 DATA ATOMWT/0.9921D0,0.24975D0,0.08322D0,0.4995D0/
78 DATA SCALET,SCALES/0.500D0, 2.000D0/
79 DATA ATOMW2/23.0D0,26.99D0,24.32D0,55.86D0,28.1D0,12.015D0,
80 * * 1.008D0,16.0D0,14.01D0,39.96D0,20.19D0,4.004D0/
81 SAVE
82C LSAHA = T IF T LOW ENOUGH TO REQUIRE CALL TO EQSAHA TO SOLVE
83C SAHA IONIZATION EQUATION. IF LSAHA = F, FULLY IONIZED GAS ASSUMED.
84C LONLYS = T IF SAHA EQUATION MUST BE SOLVED BUT RELATIVISTIC
85C EQUATION OF STATE NOT NEEDED.
86C 9 LSAHA = TL.LT.TSCUT
87 LSAHA = TL.LT.TSCUT
88 LONLYS = TL.LE.(TSCUT - SCALET)
89
90C MHP 3/94 METAL DIFFUSION ADDED. ASSUME ALL METALS SCALE EQUALLY.
91 Z0 = Z
92 IF(LDIFZ)THEN
93C THE VECTOR FXENV IS DEFINED IN STARIN AS
94C (MASS FRACTION OF SPECIES/ATOMIC WT/AMUENV) FOR THE COMPOSITION
95C XENV,ZENV.
96C AND AMU IS DEFINED AS THE SUM OF THE MASS FRACTIONS DIVIDED BY THEIR
97C ATOMIC WEIGHTS. FOR METAL DIFFUSION, ALL THE METALS ARE ASSUMED TO
98C CHANGE EQUALLY.
99 RAT = Z/ZENV
100 R1A = (RAT-1.0D0)*AMUENV
101 AMU = AMUENV
102 DO I = 1,6
103 AMU = AMU + R1A*FXENV(I)
104 END DO
105 DXX = (X - XENV)/ATOMW2(7)
106 AMU = AMU + DXX
107 DO I = 8,11
108 AMU = AMU + R1A*FXENV(I)
109 END DO
110 DYY = (XENV + ZENV - X - Z)/ATOMW2(12)
111 AMU = AMU + DYY
112 RAA = RAT*AMUENV/AMU
113 IF(LSAHA)THEN
114 DO I = 1,6
115 FX(I) = RAA*FXENV(I)
116 END DO
117 FX(7) = (FXENV(7)*AMUENV + DXX)/AMU
118 DO I = 8,11
119 FX(I) = RAA*FXENV(I)
120 END DO
121 FX(12) = (FXENV(12)*AMUENV + DYY)/AMU
122 ENDIF
123 ELSE
124C SET UP FRACTIONAL ABUNDANCES
125 DFX1 = (X - XENV)
126 DFX12 = (Z - ZENV)
127 IF(DABS(DFX1) + DABS(DFX12) .LT. 1.0D-5) THEN
128C USE ENVELOPE ABUNDANCES
129 AMU = AMUENV
130 IF(LSAHA) THEN
131 DO 10 I = 1,NZP1
132 FX(I) = FXENV(I)
133 10 10 CONTINUE
134 ENDIF
135 ELSE
136 DFX1 = DFX1*ATOMWT(1)
137 DFX12 = DFX12*ATOMWT(3)
138 DFX4 = (XENV+ZENV -X-Z)*ATOMWT(2)
139C ASSUME EXCESS Z(METALS) IS IN THE FORM OF CARBON(12)
140 AMU = AMUENV + DFX1 + DFX4 + DFX12
141 AMUI = 1.0D0/AMU
142 IF(LSAHA) THEN
143 FMUENV = AMUENV*AMUI
144 DO 20 I = 1,NZP1
145 FX(I) = FMUENV*FXENV(I)
146 20 20 CONTINUE
147 FX(6) = FX(6) + DFX12*AMUI
148 FX(7) = FX(7) + DFX1*AMUI
149 FX(12) = FX(12)+ DFX4*AMUI
150 ENDIF
151 ENDIF
152 ENDIF
153C COMPUTE RADIATION PRESSURE
154 T = DEXP(CLN*TL)
155 P = DEXP(CLN*PL)
156 BETA14 = CA3*(T**2)**2/P
157 BETA = 1 - BETA14
158
159 if(BETA .LT. 0d0) then
160 write(ishort,*) 'EQSTAT2: BETA is negative: TL,PL,BETA,1-BETA',
161 * * TL,PL,BETA,1D0-BETA
162 endif
163
164 BETAI = 1.0D0/BETA
165 BETA14 = 4.0D0*BETAI*DMIN1(1.0D0,BETA14)
166 ETA = 0.0D0
167 IF(.NOT.LSAHA) THEN
168C COMPUTE VALUES FOR FULLY IONIZED GAS AND RETURN
169 EMU = X*ATOMWT(1) + (1.0D0-X)*ATOMWT(4)
170 RMU = CGAS*(AMU+EMU)
171 FXION(1) = 1.0D0
172 FXION(2) = 0.0D0
173 FXION(3) = 1.0D0
174 CALL EQRELV(TL,T,PL,P,DL,D,BETA,AMU,EMU,ETA,QDT,QDP,QCP,DELA,
175C * QDTT,QDTP,QAT,QAP,QCPT,QCPP,X) ! KC 2025-05-31
176 * * QDTT,QDTP,QAT,QAP,QCPT,QCPP)
177 GOTO 200
178 ENDIF
179C CHECK IF SAUMON, CHABRIER, AND VAN HORN EQUATION OF STATE NEEDED.
180C THIS EOS REPLACES THE CALL TO EQSAHA, EXCEPT FOR DERIVATIVE PURPOSES.
181 IF(LSCV) THEN
182 CALL EQSAHA(FX,TL,T,PL,P,DL,D,BETA,BETAI,BETA14,FXION,RMU,
183 1 1 AMU,EMU,LDERIV,LATMO,QDT,QDP,QCP,DELA,QDTT,
184 2 2 QDTP,QAT,QAP,QCPT,QCPP,KSAHA)
185C CALL EQSCVE(TL,T,PL,P,DL,D,X,Z,BETA,BETAI,BETA14,FXION,
186C * RMU,AMU,EMU,ETA,QDT,QDP,QCP,DELA,LCALC) ! KC 2025-05-31
187 CALL EQSCVE(TL,T,P,DL,D,X,Z,BETA,FXION,QDT,QDP,QCP,DELA,LCALC)
188
189 LSCVD = .FALSE. ! Do not do SCV derivatives
190 IF(LSCVD .AND. LCALC)THEN
191c LLP 9/6/03 To get reasonable accuracy in numerical derivatives in
192c the 4-5 decimal place SCV tables, appropriate sizes for the
193c stepouts in the numerical derivatives must be obtained. The
194c row to row and column to column spacings are .20 in PL and
195c .08 in TL. Maximum row to row changes are of the order of
196c 0.2000 out of 10.0000 (in density). Maximum column to column
197c changes changes are of the order of .0500 out of 3.5000 (in
198c density. It appears that stepouts of plus and minus half a
199c row and column are needed to get appropriate accuracy for the
200c derivatives.
201
202 dpl = .010d0
203 dtl = .040d0
204 TTL = TL + dtl
205 T = 10.0D0**TTL
206C CALL EQSCVE(TTL,T,PL,P,DL1,D1,X,Z,BETA,BETAI,BETA14,
207C * FXION,RMU,AMU,EMU,ETA,QDT1,QDP1,QCP1,DELA1,LCALC1) ! KC 2025-05-31
208 CALL EQSCVE(TTL,T,P,DL1,D1,X,Z,BETA,FXION,QDT1,QDP1,QCP1,DELA1,LCALC1)
209 TTL = TL - dtl
210 T = 10.0D0**TTL
211C CALL EQSCVE(TTL,T,PL,P,DL1,D1,X,Z,BETA,BETAI,BETA14,
212C * FXION,RMU,AMU,EMU,ETA,QDT1,QDP1,QCP1,DELA1,LCALC1) ! KC 2025-05-31
213 CALL EQSCVE(TTL,T,P,DL1,D1,X,Z,BETA,FXION,QDT1,QDP1,QCP1,DELA1,LCALC1)
214 dtl2 = 2D0 * dtl
215 QDTT1 = (QDT1-QDT2)/dtl2/CLN
216 QCPT1 = (DLOG10(QCP1)-DLOG10(QCP2))/dtl2
217 QAT1 = (DLOG10(DELA1)-DLOG10(DELA2))/dtl2
218
219 T = 10.0D0**TL
220 PPL = PL + dpl
221 P = 10.0D0**PPL
222C CALL EQSCVE(TL,T,PPL,P,DL1,D1,X,Z,BETA,BETAI,BETA14,
223C * FXION,RMU,AMU,EMU,ETA,QDT1,QDP1,QCP1,DELA1,LCALC1) ! KC 2025-05-31
224 CALL EQSCVE(TL,T,P,DL1,D1,X,Z,BETA,FXION,QDT1,QDP1,QCP1,DELA1,LCALC1)
225 PPL = PL - dpl
226 P = 10.0D0**PPL
227C CALL EQSCVE(TL,T,PPL,P,DL1,D1,X,Z,BETA,BETAI,BETA14,
228C * FXION,RMU,AMU,EMU,ETA,QDT2,QDP2,QCP2,DELA2,LCALC2) ! KC 2025-05-31
229 CALL EQSCVE(TL,T,P,DL1,D1,X,Z,BETA,FXION,QDT2,QDP2,QCP2,DELA2,LCALC2)
230 P = 10.0D0**PL
231 dpl2 = 2D0 * dpl
232 QDTP1 = (QDT1-QDT2)/dpl2/CLN
233 QCPP1 = (DLOG10(QCP1)-DLOG10(QCP2))/dpl2
234 QAP1 = (DLOG10(DELA1)-DLOG10(DELA2))/dpl2
235 QDTT = QDTT1
236 QDTP = QDTP1
237 QAT = QAT1
238 QAP = QAP1
239 QCPP = QCPP1
240 QCPT = QCPT1
241 ENDIF
242 ELSE
243C CALL TO PRATHER EOS - Either because SCV was not requested or it has failed.
244 CALL EQSAHA(FX,TL,T,PL,P,DL,D,BETA,BETAI,BETA14,FXION,RMU,
245 1 1 AMU,EMU,LDERIV,LATMO,QDT,QDP,QCP,DELA,QDTT,QDTP,
246 2 2 QAT,QAP,QCPT,QCPP,KSAHA)
247 ENDIF
248C STORE EQSAHA VALUES FOR INTERPOLATION WITH EQRELV VALUES
249 DL0 = DL
250 QDT0 = QDT
251 QDP0 = QDP
252 QCP0 = QCP
253 DELA0 = DELA
254 IF(LDERIV) THEN
255 QDTT0 = QDTT
256 QDTP0 = QDTP
257 QCPT0 = QCPT
258 QCPP0 = QCPP
259 QAT0 = QAT
260 QAP0 = QAP
261 ENDIF
262 IF(LONLYS) GOTO 200 ! Bypass relativistic EOS (eqrelv) if in low temperature region
263C COMPUTE VALUES FOR FULLY IONIZED GAS
264 EMU = X*ATOMWT(1) + (1.0D0-X)*ATOMWT(4)
265 RMU = CGAS*(AMU+EMU)
266 FXION(1) = 1.0D0
267 FXION(2) = 0.0D0
268 FXION(3) = 1.0D0
269 CALL EQRELV(TL,T,PL,P,DL,D,BETA,AMU,EMU,ETA,QDT,QDP,QCP,DELA,
270C * QDTT,QDTP,QAT,QAP,QCPT,QCPP,X) ! KC 2025-05-31
271 * * QDTT,QDTP,QAT,QAP,QCPT,QCPP)
272C INTERPOLATE VALUES
273 WTS = SCALES*(TSCUT - TL)
274 WTS2 = WTS*WTS
275 WT0 = WTS2*WTS*(6.0D0*WTS2 - 15.0D0*WTS + 10.0D0)
276C WT1 =-SCALES*30.0D0*WTS2*(1.0D0-WTS)**2 ! Derivative of WT0
277 DL0 = DL0 - DL
278 QDT0 = QDT0 - QDT
279 QDP0 = QDP0 - QDP
280 QCP0 = QCP0 - QCP
281 DELA0 = DELA0 - DELA
282 QCPT0 = QCPT0-QCPT
283 QCPP0 = QCPP0-QCPP
284 QAT0 = QAT0 - QAT
285 QAP0 = QAP0 - QAP
286 DL = DL + WT0*DL0
287 D = DEXP(CLN*DL)
288 RMU = BETA*P/(D*T)
289 EMU = RMU/CGAS - AMU
290 FXION(1) = 1.0D0 + WT0*(FXION(1) - 1.0D0)
291 FXION(2) = WT0*FXION(2)
292 FXION(3) = 1.0D0 + WT0*(FXION(3) - 1.0D0)
293 QDT = QDT + WT0*QDT0
294 QDP = QDP + WT0*QDP0
295 QCP = QCP + WT0*QCP0
296 DELA = DELA + WT0*DELA0
297 IF(LDERIV) THEN
298 QDTT = QDTT + WT0*QDTT0
299 QDTP = QDTP + WT0*QDTP0
300 QCPT = QCPT + WT0*QCPT0
301 QCPP = QCPP + WT0*QCPP0
302 QAT = QAT + WT0*QAT0
303 QAP = QAP + WT0*QAP0
304 ENDIF
305 200 200 CONTINUE
306
307C 9/24/26 MHP via Claude
308C code changed to remove the OPAL 1995/2001 equations of state
309
310C 2006 OPAL eqos LLP 10/13/2996
311 IF(LOPALE06)THEN
312 IF(T.GE.1.870D3 .AND. T.LE.200D6 .AND. DL.LE.7.0D0)THEN
313 CALL OEQOS06(TL,T,PL,P,D10o,Doo,X,Z,BETAo,BETAIo,
314 1 1 BETA14o,RMUo,AMUo,EMUo,QDTo,QDPo,QCPo,DELAo,*998)
315
316C CALL EQBOUND06(T,D10o,DL0,FAC,LTAB,LRAMP) ! KC 2025-05-31
317 CALL EQBOUND06(T,D10o,FAC,LTAB,LRAMP)
318C EQBOUND01 determines whether or not the point is in the OPAL 2006 EOS table
319C If LTAB is true, point is in Opal 2006 table
320C If LRAMP is true, point is in ramp area, and ramping is required. The ramp
321C factor FAC is the weight of the point for ramping purposes.
322C Also, to eliminate a point, one can set LRAMP to true and FAC to zero.
323
324 IF(.NOT. LTAB) goto 998 ! Point is not in OPAL 2006 EOS table, so exit.
325
326C USE OPAL 2006 RESULTS ONLY IF NOT IN (RHO,T) REGIME WHERE RAMPING is NEEDED
327 IF(.NOT.LRAMP)THEN
328C No ramping needed between OPAL 2006 EOS and Yale/SCV. Result is
329C fully in the OPAL 2006 table
330 DL=D10o
331 D=10.0D0**DL
332 BETA=BETAo
333 BETAI=1.0D0/BETA
334 BETA14=1.0D0-BETA
335 RMU=RMUo
336 AMU=AMUo
337 EMU=EMUo
338 QDT=QDTo
339 QDP=QDPo
340 QCP=QCPo
341 DELA=DELAo
342 ELSE
343C Ramping required. Result is on border between OPAL 2006 EOS and Yale/SCV.
344 DL=DL+FAC*(D10o-DL)
345 D=10.0D0**DL
346 BETA=BETA+FAC*(BETAo-BETA)
347 BETAI=1.0D0/BETA
348 BETA14=1.0D0-BETA
349 RMU=RMU+FAC*(RMUo-RMU)
350 AMU=AMU+FAC*(AMUo-AMU)
351 EMU=EMU+FAC*(EMUo-EMU)
352 QDT=QDT+FAC*(QDTo-QDT)
353 QDP=QDP+FAC*(QDPo-QDP)
354 QCP=QCP+FAC*(QCPo-QCP)
355 DELA=DELA+FAC*(DELAo-DELA)
356 ENDIF
357 ENDIF
358 ENDIF
359
360
361 998 998 CONTINUE
362 Z = Z0
363 RETURN
364 END
1"""Python version of eqstat2.f (YREC development, 7be4133): the core of
2the equation of state, choosing and blending Saha, SCV, the relativistic
3gas and OPAL 2006 by regime."""
4
5import math
6
7import numpy as np
8
9from pyrec import comp_mod
10from pyrec import constants_mod
11from pyrec import iounits_mod
12from pyrec import nmlpar_mod
13from pyrec.eqbound06 import eqbound06
14from pyrec.eqrelv import eqrelv
15from pyrec.eqsaha import eqsaha
16from pyrec.eqscve import eqscve
17from pyrec.oeqos06 import oeqos06
18
19# DATA, kept between calls (SAVE; Fortran lines 76–81).
20NZP1 = 12
21ATOMWT = np.array([0.0, 0.9921, 0.24975, 0.08322, 0.4995])
22SCALET = 0.500
23SCALES = 2.000
24# Atomic weights of Na, Al, Mg, Fe, Si, C, H, O, N, Ar, Ne, He.
25ATOMW2 = np.array([0.0, 23.0, 26.99, 24.32, 55.86, 28.1, 12.015,
26 1.008, 16.0, 14.01, 39.96, 20.19, 4.004])
27
28# Locals kept between calls (SAVE).
29fx = np.zeros(NZP1 + 1)
30qdtt0 = qdtp0 = qcpt0 = qcpp0 = qat0 = qap0 = 0.0
31qdt2 = qcp2 = dela2 = 0.0
32
33
34def eqstat2(tl: float, t: float, pl: float, p: float, dl: float, d: float, x: float, z: float, beta: float,
35 betai: float, beta14: float, fxion: np.ndarray, rmu: float, amu: float, emu: float, eta: float, qdt: float,
36 qdp: float, qcp: float, dela: float, qdtt: float, qdtp: float, qat: float, qap: float, qcpt: float,
37 qcpp: float, lderiv: bool, latmo: bool,
38 ksaha: int) -> tuple[float, float, float, float, float, float,
39 float, float, float, float, float, float,
40 float, float, float, float, float, float,
41 float, float, float, int]:
42 """Choose and blend the equations of state by regime: composition,
43 radiation, Saha (or SCV) below TSCUT, the relativistic gas above it
44 with a smooth-step blend between, and OPAL 2006 on top where its
45 table covers the point.
46
47 Translates: eqstat2.f#EQSTAT2 (7be4133)
48
49 Arguments: tl, pl (log T, log P), x, z, lderiv (also the second
50 derivatives), latmo (passed to eqsaha), ksaha (eqsaha's iteration
51 counter); dl is a starting guess. t, p, d, beta ... qcpp are only set.
52 Array changed in place: fxion (H+, He+, He++ fractions, index 0
53 unused).
54
55 Returns (t, p, dl, d, beta, betai, beta14, rmu, amu, emu, eta, qdt,
56 qdp, qcp, dela, qdtt, qdtp, qat, qap, qcpt, qcpp, ksaha).
57
58 """
59
60 global qdtt0, qdtp0, qcpt0, qcpp0, qat0, qap0, qdt2, qcp2, dela2
61 c = constants_mod
62 nml = nmlpar_mod
63 cmp = comp_mod
64
65 def _out():
66 return (t, p, dl, d, beta, betai, beta14, rmu, amu, emu, eta, qdt,
67 qdp, qcp, dela, qdtt, qdtp, qat, qap, qcpt, qcpp, ksaha)
68
69 # lsaha: solve Saha (else fully ionized); lonlys: Saha alone, no
70 # relativistic gas (Fortran lines 87–88).
71 lsaha = tl < nml.tscut
72 lonlys = tl <= (nml.tscut - SCALET)
73
74 # Composition: AMU (ions per unit mass) and the number fractions FX
75 # (Fortran lines 91–152).
76 z0 = z
77 if nml.ldifz:
78 # Metal diffusion: all metals scale together by Z/ZENV.
79 rat = z / cmp.zenv
80 r1a = (rat - 1.0) * cmp.amuenv
81 amu = cmp.amuenv
82 for i in range(1, 7):
83 amu = amu + r1a * cmp.fxenv[i]
84 dxx = (x - cmp.xenv) / ATOMW2[7]
85 amu = amu + dxx
86 for i in range(8, 12):
87 amu = amu + r1a * cmp.fxenv[i]
88 dyy = (cmp.xenv + cmp.zenv - x - z) / ATOMW2[12]
89 amu = amu + dyy
90 raa = rat * cmp.amuenv / amu
91 if lsaha:
92 for i in range(1, 7):
93 fx[i] = raa * cmp.fxenv[i]
94 fx[7] = (cmp.fxenv[7] * cmp.amuenv + dxx) / amu
95 for i in range(8, 12):
96 fx[i] = raa * cmp.fxenv[i]
97 fx[12] = (cmp.fxenv[12] * cmp.amuenv + dyy) / amu
98 else:
99 dfx1 = x - cmp.xenv
100 dfx12 = z - cmp.zenv
101 if abs(dfx1) + abs(dfx12) < 1.0e-5:
102 # The envelope abundances.
103 amu = cmp.amuenv
104 if lsaha:
105 for i in range(1, NZP1 + 1):
106 fx[i] = cmp.fxenv[i]
107 else:
108 # Any excess Z is taken as carbon 12.
109 dfx1 = dfx1 * ATOMWT[1]
110 dfx12 = dfx12 * ATOMWT[3]
111 dfx4 = (cmp.xenv + cmp.zenv - x - z) * ATOMWT[2]
112 amu = cmp.amuenv + dfx1 + dfx4 + dfx12
113 amui = 1.0 / amu
114 if lsaha:
115 fmuenv = cmp.amuenv * amui
116 for i in range(1, NZP1 + 1):
117 fx[i] = fmuenv * cmp.fxenv[i]
118 fx[6] = fx[6] + dfx12 * amui
119 fx[7] = fx[7] + dfx1 * amui
120 fx[12] = fx[12] + dfx4 * amui
121
122 # Radiation pressure (Fortran lines 154–166).
123 t = math.exp(c.cln * tl)
124 p = math.exp(c.cln * pl)
125 beta14 = c.ca3 * (t**2)**2 / p
126 beta = 1 - beta14
127 if beta < 0.0:
128 # Question (see the page): the routine goes on with beta < 0.
129 iounits_mod.write(iounits_mod.ishort,
130 f" EQSTAT2: BETA is negative: TL,PL,BETA,1-BETA "
131 f"{tl} {pl} {beta} {1.0 - beta}")
132 betai = 1.0 / beta
133 beta14 = 4.0 * betai * min(1.0, beta14)
134 eta = 0.0
135
136 if not lsaha:
137 # Fully ionized gas (Fortran lines 167–178).
138 emu = x * ATOMWT[1] + (1.0 - x) * ATOMWT[4]
139 rmu = c.cgas * (amu + emu)
140 fxion[1] = 1.0
141 fxion[2] = 0.0
142 fxion[3] = 1.0
143 (dl, d, eta, qdt, qdp, qcp, dela, qdtt, qdtp, qat, qap, qcpt,
144 qcpp) = eqrelv(tl, t, pl, p, dl, d, beta, amu, emu, eta, qdt, qdp,
145 qcp, dela, qdtt, qdtp, qat, qap, qcpt, qcpp)
146 else:
147 if nml.lscv:
148 # SCV replaces Saha, except for the second derivatives
149 # (Fortran lines 181–187).
150 # Question (see the page): rmu, emu and the second derivatives
151 # stay from eqsaha.
152 (dl, d, rmu, emu, qdt, qdp, qcp, dela, qdtt, qdtp, qat, qap,
153 qcpt, qcpp, ksaha) = eqsaha(
154 fx, tl, t, pl, p, dl, d, beta, betai, beta14, fxion, rmu,
155 amu, emu, lderiv, latmo, qdt, qdp, qcp, dela, qdtt, qdtp,
156 qat, qap, qcpt, qcpp, ksaha)
157 lcalc = None
158 dl, d, qdt, qdp, qcp, dela, lcalc = eqscve(
159 tl, t, p, dl, d, x, z, beta, fxion, qdt, qdp, qcp, dela,
160 lcalc)
161
162 # Suspected bug (see the page): this block never runs, and
163 # would use qdt2, qcp2, dela2, dl1, d1 unset (Fortran lines
164 # 189–241).
165 lscvd = False
166 if lscvd and lcalc:
167 # Unset in the Fortran (uninitialized locals).
168 dl1 = d1 = qdt1 = qdp1 = qcp1 = dela1 = lcalc1 = None
169 qdp2 = lcalc2 = None
170 dpl = 0.010
171 dtl = 0.040
172 ttl = tl + dtl
173 t = 10.0**ttl
174 dl1, d1, qdt1, qdp1, qcp1, dela1, lcalc1 = eqscve(
175 ttl, t, p, dl1, d1, x, z, beta, fxion, qdt1, qdp1,
176 qcp1, dela1, lcalc1)
177 ttl = tl - dtl
178 t = 10.0**ttl
179 dl1, d1, qdt1, qdp1, qcp1, dela1, lcalc1 = eqscve(
180 ttl, t, p, dl1, d1, x, z, beta, fxion, qdt1, qdp1,
181 qcp1, dela1, lcalc1)
182 dtl2 = 2.0 * dtl
183 qdtt1 = (qdt1 - qdt2) / dtl2 / c.cln
184 qcpt1 = (math.log10(qcp1) - math.log10(qcp2)) / dtl2
185 qat1 = (math.log10(dela1) - math.log10(dela2)) / dtl2
186 t = 10.0**tl
187 ppl = pl + dpl
188 p = 10.0**ppl
189 dl1, d1, qdt1, qdp1, qcp1, dela1, lcalc1 = eqscve(
190 tl, t, p, dl1, d1, x, z, beta, fxion, qdt1, qdp1, qcp1,
191 dela1, lcalc1)
192 ppl = pl - dpl
193 p = 10.0**ppl
194 dl1, d1, qdt2, qdp2, qcp2, dela2, lcalc2 = eqscve(
195 tl, t, p, dl1, d1, x, z, beta, fxion, qdt2, qdp2, qcp2,
196 dela2, lcalc2)
197 p = 10.0**pl
198 dpl2 = 2.0 * dpl
199 qdtp1 = (qdt1 - qdt2) / dpl2 / c.cln
200 qcpp1 = (math.log10(qcp1) - math.log10(qcp2)) / dpl2
201 qap1 = (math.log10(dela1) - math.log10(dela2)) / dpl2
202 qdtt = qdtt1
203 qdtp = qdtp1
204 qat = qat1
205 qap = qap1
206 qcpp = qcpp1
207 qcpt = qcpt1
208 else:
209 # Saha alone (Prather's EOS; Fortran lines 242–247).
210 (dl, d, rmu, emu, qdt, qdp, qcp, dela, qdtt, qdtp, qat, qap,
211 qcpt, qcpp, ksaha) = eqsaha(
212 fx, tl, t, pl, p, dl, d, beta, betai, beta14, fxion, rmu,
213 amu, emu, lderiv, latmo, qdt, qdp, qcp, dela, qdtt, qdtp,
214 qat, qap, qcpt, qcpp, ksaha)
215
216 # Store the Saha values for the blend with the relativistic gas
217 # (Fortran lines 249–261).
218 dl0 = dl
219 qdt0 = qdt
220 qdp0 = qdp
221 qcp0 = qcp
222 dela0 = dela
223 if lderiv:
224 qdtt0 = qdtt
225 qdtp0 = qdtp
226 qcpt0 = qcpt
227 qcpp0 = qcpp
228 qat0 = qat
229 qap0 = qap
230
231 if not lonlys:
232 # Transition band: the fully ionized gas too (Fortran lines
233 # 262–271).
234 emu = x * ATOMWT[1] + (1.0 - x) * ATOMWT[4]
235 rmu = c.cgas * (amu + emu)
236 fxion[1] = 1.0
237 fxion[2] = 0.0
238 fxion[3] = 1.0
239 (dl, d, eta, qdt, qdp, qcp, dela, qdtt, qdtp, qat, qap, qcpt,
240 qcpp) = eqrelv(tl, t, pl, p, dl, d, beta, amu, emu, eta, qdt,
241 qdp, qcp, dela, qdtt, qdtp, qat, qap, qcpt,
242 qcpp)
243
244 # Blend with the smooth step W(w) = w^3 (6w^2 - 15w + 10)
245 # (Fortran lines 273–304).
246 # No term from dW/dlog T (WT1), a known gap (KNOWN_ISSUES.md,
247 # section 40).
248 wts = SCALES * (nml.tscut - tl)
249 wts2 = wts * wts
250 wt0 = wts2 * wts * (6.0 * wts2 - 15.0 * wts + 10.0)
251 dl0 = dl0 - dl
252 qdt0 = qdt0 - qdt
253 qdp0 = qdp0 - qdp
254 qcp0 = qcp0 - qcp
255 dela0 = dela0 - dela
256 # No differences for qdtt0, qdtp0, a known gap (KNOWN_ISSUES.md,
257 # section 40).
258 qcpt0 = qcpt0 - qcpt
259 qcpp0 = qcpp0 - qcpp
260 qat0 = qat0 - qat
261 qap0 = qap0 - qap
262 dl = dl + wt0 * dl0
263 d = math.exp(c.cln * dl)
264 rmu = beta * p / (d * t)
265 emu = rmu / c.cgas - amu
266 fxion[1] = 1.0 + wt0 * (fxion[1] - 1.0)
267 fxion[2] = wt0 * fxion[2]
268 fxion[3] = 1.0 + wt0 * (fxion[3] - 1.0)
269 qdt = qdt + wt0 * qdt0
270 qdp = qdp + wt0 * qdp0
271 qcp = qcp + wt0 * qcp0
272 dela = dela + wt0 * dela0
273 if lderiv:
274 qdtt = qdtt + wt0 * qdtt0
275 qdtp = qdtp + wt0 * qdtp0
276 qcpt = qcpt + wt0 * qcpt0
277 qcpp = qcpp + wt0 * qcpp0
278 qat = qat + wt0 * qat0
279 qap = qap + wt0 * qap0
280 # label 200
281
282 # OPAL 2006, replacing or blended with the Yale/SCV result (Fortran
283 # lines 311–358).
284 # Question (see the page): the rough ranges are hard-coded.
285 if nml.lopale06 and t >= 1.870e3 and t <= 200e6 and dl <= 7.0:
286 # oeqos06's alternate return (*998) is its last returned value,
287 # alt1: True means it failed, and the Yale/SCV result stands.
288 (t, p, d10o, doo, betao, betaio, beta14o, rmuo, amuo, emuo, qdto,
289 qdpo, qcpo, delao, alt1) = oeqos06(
290 tl, t, pl, p, 0.0, 0.0, x, z, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
291 0.0, 0.0, 0.0, 0.0)
292 if alt1:
293 return _out() # go to 998
294 fac, ltab, lramp = eqbound06(t, d10o, 0.0, False, False)
295 if not ltab:
296 return _out() # go to 998
297 if not lramp:
298 # Fully in the OPAL 2006 table.
299 dl = d10o
300 d = 10.0**dl
301 beta = betao
302 betai = 1.0 / beta
303 beta14 = 1.0 - beta
304 rmu = rmuo
305 amu = amuo
306 emu = emuo
307 qdt = qdto
308 qdp = qdpo
309 qcp = qcpo
310 dela = delao
311 else:
312 # On the border: ramp between OPAL 2006 and Yale/SCV.
313 dl = dl + fac * (d10o - dl)
314 d = 10.0**dl
315 beta = beta + fac * (betao - beta)
316 betai = 1.0 / beta
317 beta14 = 1.0 - beta
318 rmu = rmu + fac * (rmuo - rmu)
319 amu = amu + fac * (amuo - amu)
320 emu = emu + fac * (emuo - emu)
321 qdt = qdt + fac * (qdto - qdt)
322 qdp = qdp + fac * (qdpo - qdp)
323 qcp = qcp + fac * (qcpo - qcp)
324 dela = dela + fac * (delao - dela)
325 # label 998: Z = Z0, though nothing here changes z (unused?; Fortran
326 # lines 361–363).
327 z = z0
328 return _out()