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

97 lines
2.6 KiB
Fortran

SUBROUTINE ODFHYD(ID,ITR)
C =========================
C
C Line ODF's for hydrogen line series
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
PARAMETER (CDOP=TWO*BOLK/HMASS)
PARAMETER (CA=2.997925D18,CCM=CA/1.D8,FRH=3.28805D15)
PARAMETER (RYDEL=911.764,TTW=2./3.)
PARAMETER (C00=1.25D-9,CID=0.02654)
DIMENSION SIG(MFRO),SGT(MFRO),ODF(MFRO),IODF(MFRO)
DIMENSION YNUS(MFRO),ALAM(MFRO)
C
JO=JNDODF(ITR)
IF(ISPODF.EQ.0) THEN
NF=NFRODF(JO)
DO IJ=1,NF
IODF(IJ)=0
SIG(IJ)=0.
ODF(IJ)=0.
YNUS(IJ)=FROS(IJ,JO)
ALAM(IJ)=CAS/YNUS(IJ)
END DO
ELSE
NF=IFR1(ITR)-IFR0(ITR)+1
DO IJ=1,NF
SIG(IJ)=0.
YNUS(IJ)=FREQ(IFR0(ITR)+IJ-1)
ALAM(IJ)=CAS/YNUS(IJ)
END DO
END IF
C
II=ILOW(ITR)
JJ=IUP(ITR)
ANES=EXP(TTW*LOG(ELEC(ID)))
F00=C00*ANES
FRA=FRH*(XI2(NQUANT(II))-XI2(NQUANT(JJ)))
DOPO=FRA/CCM*SQRT(CDOP*TEMP(ID)+VTB*VTB)
DO J=NQLODF(II),NLMX
WL=RYDEL/(XI2(NQUANT(II))-XI2(J))
FXK=F00*XKIJ(JO,J)
DBETA=WL*WL/CA/FXK
BETAD=DBETA*DOPO
FID=CID*FIJ(JO,J)*DBETA
CALL DIVSTR(1)
WPROB=WNHINT(J,ID)
CALL ODFHST(NF,FXK,FID,WPROB,WL,ALAM,SGT)
DO IJ=1,NF
SIG(IJ)=SIG(IJ)+SGT(IJ)
END DO
END DO
C
IF(ISPODF.EQ.0) THEN
CALL INDEXX(NF,SIG,IODF)
DO IJ=1,NF
ODF(IJ)=SIG(IODF(IJ))
END DO
I0=IFR0(ITR)
I1=IFR1(ITR)
IF(IABS(INDEXP(ITR)).EQ.2) YNUS(1)=FREQ(I0)
IW1=IODF(1)
DO IJ=2,NF
IW2=IODF(IJ)
IF(IJ.GT.2 .AND. IJ.LT.NF) THEN
YNUS(IJ)=YNUS(IJ-1)-HALF*(WNUS(IW1,JO)+WNUS(IW2,JO))
ELSE IF (IJ.EQ.2) THEN
YNUS(IJ)=YNUS(IJ-1)-HALF*(TWO*WNUS(IW1,JO)+WNUS(IW2,JO))
ELSE IF (IJ.EQ.NF) THEN
YNUS(IJ)=YNUS(IJ-1)-HALF*(WNUS(IW1,JO)+TWO*WNUS(IW2,JO))
END IF
IW1=IW2
END DO
END IF
C
IF(ISPODF.EQ.0) THEN
PRFLIN(ID,I1)=1.E-35
DO IJQ=I0,I1-1
DO IJ=2,NF
JI=IJ
IF(YNUS(IJ).LE.FREQ(IJQ)) GO TO 70
END DO
70 PRFLN=ODF(JI-1)+(ODF(JI)-ODF(JI-1))*
* (FREQ(IJQ)-YNUS(JI-1))/(YNUS(JI)-YNUS(JI-1))
PRFLIN(ID,IJ0)=real(PRFLN)
END DO
ELSE
DO IJ=1,NF
PRFLIN(ID,KFR0(ITR)+IJ-1)=real(SIG(IJ))
END DO
END IF
RETURN
END