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

69 lines
1.8 KiB
Fortran

subroutine rayset
c ===================
c
c set up a table of Rayleigh scattering opacity
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
c
do id=1,nd
t=temp(id)
rho=dens(id)
c
if(numtemp.eq.nd) then
opac=raytab(id,1)
go to 10
end if
c
TL=LOG(T)
DELTAT=(TL-TTAB1)/(TTAB2-TTAB1)*FLOAT(numtemp-1)
JT = 1 + IDINT(DELTAT)
JU = JT + 1
IF(JT.LT.1) JT = 1
IF(JT.GT.numtemp-1) JT = numtemp-1
t1i=tempvec(jt)
t2i=tempvec(jt+1)
dti=(TL-T1i)/(T2i-T1i)
if(deltat.lt.0.) dti = 0.d0
C
if(numrho.gt.1) then
rtab1=rhomat(jt,1)
rtab2=rhomat(jt,numrho)
RL = LOG(RHO)
DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1)
JR = 1 + IDINT(DELTAR)
IF(JR.LT.1) JR = 1
IF(JR.GT.(numrho-1)) JR = numrho-1
r1i=rhomat(jt,jr)
r2i=rhomat(jt,jr+1)
dri=(RL-R1i)/(R2i-R1i)
if(deltar.lt.0.) dri = 0.d0
opr1=raytab(jt,jr)+
* dri*(raytab(jt,jr+1)-raytab(jt,jr))
c
rtab1=rhomat(ju,1)
rtab2=rhomat(ju,numrho)
RL = LOG(RHO)
DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1)
JR = 1 + IDINT(DELTAR)
IF(JR.LT.1) JR = 1
IF(JR.GT.(numrho-1)) JR = numrho-1
r1i=rhomat(ju,jr)
r2i=rhomat(ju,jr+1)
dri=(RL-R1i)/(R2i-R1i)
if(deltar.lt.0.) dri = 0.d0
opr2=raytab(ju,jr)+
* dri*(raytab(ju,jr+1)-raytab(ju,jr))
c
opac=opr1+(opr2-opr1)*dti
else
jr=1
opac=raytab(jt,jr)+(raytab(ju,jr)-raytab(jt,jr))*dti
end if
10 continue
raysc(id)=exp(opac)
end do
return
end