55 lines
1.4 KiB
Fortran
55 lines
1.4 KiB
Fortran
SUBROUTINE ODFHST(N,FXK,FID,WP,WL,ALAM,SG)
|
|
C ==========================================
|
|
C
|
|
C Auxiliary routine for ODF1 (replaces multiple calls to STARKA)
|
|
C
|
|
INCLUDE 'IMPLIC.FOR'
|
|
INCLUDE 'BASICS.FOR'
|
|
INCLUDE 'MODELQ.FOR'
|
|
INCLUDE 'ODFPAR.FOR'
|
|
PARAMETER (F0=-0.5758228,F1=0.4796232,F2=0.07209481,AL=1.26)
|
|
PARAMETER (SD=0.5641895,SLO=-2.5,THRA=1.5,BL1=1.14,BL2=11.4)
|
|
PARAMETER (SAC=0.08, THR=THRA*TWO)
|
|
DIMENSION ALAM(MFRO),SG(MFRO)
|
|
C
|
|
BETAD1=UN/BETAD
|
|
FXK1=UN/FXK
|
|
FIDWP=FID*WP
|
|
C
|
|
C for a > 1 Doppler core + asymptotic Holtzmark wing with division
|
|
C point DIV
|
|
C
|
|
IF(ADH.GT.AL) THEN
|
|
DO IJ=1,N
|
|
BETA=ABS(ALAM(IJ)-WL)*FXK1
|
|
XD=BETA*BETAD1
|
|
IF(XD.LE.DIVH) THEN
|
|
ST=SD*EXP(-XD*XD)*BETAD1
|
|
ELSE
|
|
ST=THR*EXP(SLO*LOG(BETA))
|
|
END IF
|
|
SG(IJ)=ST*FIDWP
|
|
END DO
|
|
ELSE
|
|
C
|
|
C empirical formula for a < 1
|
|
C
|
|
DO IJ=1,N
|
|
BETA=ABS(ALAM(IJ)-WL)*FXK1
|
|
XD=BETA*BETAD1
|
|
IF(BETA.LE.BL1) THEN
|
|
ST=SAC
|
|
ELSE IF(BETA.LT.BL2) THEN
|
|
XL=LOG(BETA)
|
|
FL=(F0*XL+F1)*XL
|
|
ST=F2*EXP(FL)
|
|
ELSE
|
|
ST=THR*EXP(SLO*LOG(BETA))
|
|
END IF
|
|
SG(IJ)=ST*FIDWP
|
|
END DO
|
|
END IF
|
|
C
|
|
RETURN
|
|
END
|