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

80 lines
2.2 KiB
Fortran

FUNCTION HIDALG(IB,FR)
C ======================
C
C Read table of wavelengths and photo-ionization cross-sections
C from Hidalgo (1968, Ap. J., 153, 981) for the species indicated by IB
C (Hidalgo's number = INDEX = -IB-100).
C Compute linearly interpolated value of the cross-section
C at the frequency FR.
C
C (At the moment, only a few transitions are considered)
C
INCLUDE 'IMPLIC.FOR'
DIMENSION WL1(20),WL2(20),WL(20),SIG0(20,24),SIGS(20)
C
DATA WL1 /
* 39.1, 80.9, 97.6,100.1,104.3,107.2,108.7,111.9,113.6,115.4,
* 117.1,119.0,124.8,126.9,129.1,131.3,133.6,136.0,138.5,141.1/
DATA WL2 /
* 68.5, 80.9,100.1,120.9,158.8,165.7,177.3,190.6,200.7,206.2,
* 211.9,218.0,224.5,231.3,246.3,5*0./
DATA SIG0 /
* 120*0.,
*.0460,.2400,.3500,.3700,.4000,.4300,.4400,.4600,.4700,.4900,
*.5000,.5200,.5700,.6200, 6*0.,
* 80*0.,
*.0092,.1000,.1900,.2100,.2300,.2500,.2600,.2900,.3000,.3200,
*.3400,.3500,.4100,.4300,.4500,.4800,.5000,.5300,.5600,.5900,
* 20*0.,
*.3400,.4600,.6300,.7700,.9100,1.080, 14*0.,
* 20*0.,
*.0064,.1100,.2200,.4100,.9400,1.000,1.300,1.600, 12*0.,
* 80*0.,
*.0370,.0650,.1300,.2400,.5500,.6300,.7700,.9500,1.100,1.250,
* 10*0.,
* 20*0.,
* 20*0.,
*.0220,.0390,.0800,.1500,.3500,.4000,.4900,.6200,.7200,.7800,
*.8500,.9300,1.020,
* 7*0./
SAVE WL1,WL2,SIG0
C
INDEX=-IB-100
NUM=20
IF(INDEX.GE.13.AND.INDEX.LE.27) NUM=15
DO I=1,NUM
IF(INDEX.LT.13) WL(I)=WL1(I)
IF(INDEX.GE.13) WL(I)=WL2(I)
SIGS(I)=SIG0(I,INDEX)
END DO
C
WLAM=2.997925D18/FR
IL=1
IR=NUM
DO I=1,NUM-1
IF(WLAM.GE.WL(I).AND.WLAM.LE.WL(I+1)) THEN
IL=I
IR=I+1
GO TO 60
END IF
END DO
C
C LINEAR INTERPOLATION:
C
60 SIGM=(SIGS(IR)-SIGS(IL))*(WLAM-WL(IL))/(WL(IR)-WL(IL))
* + SIGS(IL)
C
C IF OUTSIDE WAVELENGTH RANGE SET TO FIRST(LAST) VALUE:
C
IF(WLAM.LE.WL(1)) SIGM=SIGS(1)
IF(WLAM.GE.WL(NUM)) SIGM=SIGS(NUM)
C
C IF LAST NON-ZERO SIG VALUES, NO INTERPOLATION:
C
c IF(SIGS(IR).EQ.0.) SIGM=SIGS(IL)
C
HIDALG=SIGM*1.D-18
RETURN
END