SpectraRust/tlusty/extracted/inthyd.f
2026-03-19 14:05:33 +08:00

91 lines
2.5 KiB
Fortran

SUBROUTINE INTHYD(W0,X0,Z0,IWL,ILINE)
C =====================================
C
C Interpolation in temperature and electron density from the
C Lemke tables for hydrogen lines to the actual valus of
C temperature and electron density
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
DIMENSION ZZ(3),XX(3),WX(3),WZ(3)
C
NX=2
NZ=2
NT=NTH(ILINE)
NE=NEH(ILINE)
BETA=WLH(IWL,ILINE)/XK
IZH=1
C
C for values lower than the lowest grid value of electron density
C the profiles are determined by the approximate expression
C (see STARKA); not by an extrapolation in the HYD tables which may
C be very inaccurate
C
IF(Z0.LT.XNELEM(1,ILINE)*0.99) THEN
CALL DIVSTR(IZH)
W0=STARKA(BETA,TWO)*DBETA
W0=LOG10(W0)
RETURN
END IF
C
C Otherwise, one interpolates (or extrapolates for higher than the
C highes grid value of electron density) in the HYD tables
C
DO IZZ=1,NE-1
IPZ=IZZ
IF(Z0.LE.XNELEM(IZZ+1,ILINE)) GO TO 20
END DO
20 N0Z=IPZ-NZ/2+1
IF(N0Z.LT.1) N0Z=1
IF(N0Z.GT.NE-NZ+1) N0Z=NE-NZ+1
N1Z=N0Z+NZ-1
C
DO IZZ=N0Z,N1Z
I0Z=IZZ-N0Z+1
ZZ(I0Z)=XNELEM(IZZ,ILINE)
C
C Likewise, the approximate expression instead of extrapolation
C is used for higher that the highest grid value of temperature,
C if the Doppler width expressed in beta units (BETAD) is
C sufficiently large (> 10)
C
C IF(X0.GT.1.01*XTLEM(NT,ILINE).AND.BETAD.GT.10.) THEN
IF(X0.GT.1.01*XTLEM(NT,ILINE)) THEN
CALL DIVSTR(IZH)
W0=STARKA(BETA,TWO)*DBETA
W0=LOG10(W0)
RETURN
END IF
C
C Otherwise, normal inter- or extrapolation
C
C Both interpolations (in T as well as in electron density) are
C by default the quadratic interpolations in logarithms
C
DO IX=1,NT-1
IPX=IX
IF(X0.LE.XTLEM(IX+1,ILINE)) GO TO 40
END DO
40 N0X=IPX-NX/2+1
IF(N0X.LT.1) N0X=1
IF(N0X.GT.NT-NX+1) N0X=NT-NX+1
N1X=N0X+NX-1
DO IX=N0X,N1X
I0=IX-N0X+1
XX(I0)=XTLEM(IX,ILINE)
WX(I0)=PRFHYD(ILINE,IWL,IX,IZZ)
END DO
IF(WX(1).LT.-99..OR.WX(2).LT.-99..OR.WX(3).LT.-99.) THEN
CALL DIVSTR(IZH)
W0=STARKA(BETA,TWO)*DBETA
W0=LOG10(W0)
RETURN
ELSE
WZ(I0Z)=YINT(XX,WX,X0)
END IF
END DO
W0=YINT(ZZ,WZ,Z0)
RETURN
END