242 lines
7.0 KiB
Fortran
242 lines
7.0 KiB
Fortran
SUBROUTINE RTESCA
|
|
C =================
|
|
C
|
|
C Solution of the radiative transfer equation
|
|
C for deriving the scattering in continuum
|
|
C
|
|
C Solution along every rays, for the spherically-symmetric case
|
|
C
|
|
C Solution in the optical depth scale
|
|
C
|
|
C The numerical method used:
|
|
C Discontinuous Finite Element method
|
|
C Castor, Dykema, Klein, 1992, ApJ 387, 561.
|
|
C
|
|
INCLUDE 'PARAMS.FOR'
|
|
INCLUDE 'MODELP.FOR'
|
|
INCLUDE 'SYNTHP.FOR'
|
|
INCLUDE 'WINCOM.FOR'
|
|
PARAMETER (UN=1., TWO=2., HALF=0.5)
|
|
PARAMETER (NTRALI=10,DJMAX=1.D-3)
|
|
COMMON/RTEOPA/CH(MFREQ,MDEPTH),ET(MFREQ,MDEPTH),
|
|
* SC(MFREQ,MDEPTH)
|
|
COMMON/CONOPA/CHC(MFREQC,MDEPTH),ETC(MFREQC,MDEPTH),
|
|
* SCC(MFREQC,MDEPTH)
|
|
COMMON/EMFLUX/FLUX(MFREQ),FLUXC(MFREQC)
|
|
COMMON/CONSCV/SCCF(MFREQC,mdepf)
|
|
DIMENSION ST0(mdepf ),RAD00(mdepf ),AB0(mdepf ),ALI1(mdepf ),
|
|
* rip(mdepf ),rim(mdepf ),riin(mdepf ),riup(mdepf ),
|
|
* aip(mdepf ),aim(mdepf ),aiin(mdepf ),aiup(mdepf )
|
|
dimension dt(mdepf ),dtau(mdepf ),RDX(mdepf ),PTX(mdepf )
|
|
dimension uf(mdepf ),af(mdepf ),ss0(mdepf ),scx(mdepth)
|
|
dimension densr(mdepf),rdy(mdepf),
|
|
* abc0(mdepf),abc1(mdepf),stc0(mdepf),stc1(mdepf),
|
|
* scc0(mdepf),scc01(mdepf)
|
|
COMMON/COPAC/AB(MOPAC,MDEPF),STH(MOPAC,MDEPF),SCH(MFREQC,MDEPF)
|
|
C
|
|
C overall loop over continuum frequencies
|
|
C
|
|
DO 500 IJ=1,NFREQC
|
|
FR=FREQC(IJ)
|
|
C
|
|
C Initialisation of J=B
|
|
C
|
|
if(ij.eq.1) then
|
|
FR15=FR*1.D-15
|
|
BNU=BN*FR15*FR15*FR15
|
|
HKFR=HK*FR
|
|
DO ID=1,ND
|
|
RAD00(ID)=BNU/(EXP(HKFR/TEMP(ID))-UN)
|
|
END DO
|
|
end if
|
|
C
|
|
C Loop over electron scattering
|
|
C
|
|
itrali=0
|
|
10 itrali=itrali+1
|
|
fluxc(ij)=0.
|
|
C
|
|
DO ID=1,ND
|
|
RAD1(ID)=0.
|
|
ALI1(ID)=0.
|
|
END DO
|
|
C
|
|
C Loop over impact rays
|
|
C
|
|
if(nd.eq.ndf) then
|
|
do id=1,nd
|
|
densf(id)=dens(id)
|
|
rdx(id)=rad00(id)
|
|
abc0(id)=chc(ij,id)
|
|
stc0(id)=etc(ij,id)/chc(ij,id)
|
|
scc0(id)=scc(ij,id)
|
|
end do
|
|
else
|
|
CALL INTERP(DENS,RAD00,DENSF,RDX,ND,NDF,4,1,0)
|
|
do id=1,nd
|
|
abc1(id)=chc(ij,id)
|
|
stc1(id)=etc(ij,id)/chc(ij,id)
|
|
scc01(ij)=scc(ij,id)
|
|
end do
|
|
CALL INTERP(DENS,abc1,DENSF,abc0,ND,NDF,4,1,0)
|
|
CALL INTERP(DENS,stc1,DENSF,stc0,ND,NDF,4,1,0)
|
|
CALL INTERP(DENS,scc01,DENSF,scc0,ND,NDF,4,1,0)
|
|
end if
|
|
DO 100 IU=1,KMU
|
|
iud=nud(iu)
|
|
IF(IU.LE.NFIRY) IUD=NUDF(IU)
|
|
if(iud.le.1) goto 100
|
|
DO ID=1,IUD
|
|
KY=KRAY(IU,ID)
|
|
YDR=DRAY(IU,ID)
|
|
YDR1=UN-DRAY(IU,ID)
|
|
DENSR(ID)=YDR1*DENSF(KY-1)+YDR*DENSF(KY)
|
|
AB0(ID)=YDR1*abc0(KY-1)+YDR*abc0(KY)
|
|
ST0(ID)=YDR1*stc0(KY-1)+YDR*stc0(KY)
|
|
SC0=YDR1*scc0(KY-1)+YDR*scc0(KY)
|
|
RDY(id)=YDR1*RDX(KY-1)+YDR*RDX(KY)
|
|
SS0(ID)=SC0/AB0(ID)
|
|
ST0(ID)=ST0(ID)+SS0(ID)*RDY(ID)
|
|
END DO
|
|
IF(IU.LE.NFIRY) THEN
|
|
DO ID=1,IUD-1
|
|
DTAU(ID)=HALF*(AB0(ID)+AB0(ID+1))*DELZF(IU,ID)
|
|
END DO
|
|
ELSE
|
|
DO ID=1,IUD-1
|
|
DT(ID)=HALF*(AB0(ID)+AB0(ID+1))
|
|
DTAU(ID)=DT(ID)*DELZ(IU,ID)
|
|
END DO
|
|
END IF
|
|
C
|
|
C incoming intensity (TAUMIN=0.)
|
|
C
|
|
rim(1)=0.
|
|
aim(1)=0.
|
|
do id=1,iud-1
|
|
dt0=dtau(id)
|
|
dtaup1=dt0+un
|
|
dtau2=dt0*dt0
|
|
bb=two*dtaup1
|
|
cc=dt0*dtaup1
|
|
aa=un/(dtau2+bb)
|
|
rip(id)=(bb*rim(id)+cc*st0(id)-dt0*st0(id+1))*aa
|
|
rim(id+1)=(two*rim(id)+dt0*st0(id)+cc*st0(id+1))*aa
|
|
aip(id)=(cc+bb*aim(id))*aa
|
|
aim(id+1)=cc*aa
|
|
enddo
|
|
do id=2,iud-1
|
|
dtt=un/(dtau(id-1)+dtau(id))
|
|
riin(id)=(rim(id)*dtau(id)+rip(id)*dtau(id-1))*dtt
|
|
aiin(id)=(aim(id)*dtau(id)+aip(id)*dtau(id-1))*dtt
|
|
enddo
|
|
riin(1)=rim(1)
|
|
riin(iud)=rim(iud)
|
|
aiin(1)=aim(1)
|
|
aiin(iud)=aim(iud)
|
|
rip(iud)=rim(iud)
|
|
C
|
|
C Outgoing intensity
|
|
C symmetric boundary condition (rim(iud)=riin(iud))
|
|
C or diffusion approx. for core rays
|
|
C
|
|
IF(IU.GT.NREXT) THEN
|
|
PLAND=BNU/(EXP(HKFR/TEMP(ND))-UN)
|
|
DPLAN=PLAND-BNU/(EXP(HKFR/TEMP(ND-1))-UN)
|
|
c rim(iud)=PLAND+dplan/dtau(iud-1)
|
|
rip(iud)=PLAND+dplan/dtau(iud-1)
|
|
dt0=dtau(iud-1)
|
|
dtaup1=dt0+un
|
|
dtau2=dt0*dt0
|
|
bb=two*dtaup1
|
|
cc=dt0*dtaup1
|
|
aa=dtau2+bb
|
|
rim(iud)=(aa*rip(iud)-cc*st0(iud)+dt0*st0(iud-1))/bb
|
|
ENDIF
|
|
do id=iud-1,1,-1
|
|
dt0=dtau(id)
|
|
dtaup1=dt0+un
|
|
dtau2=dt0*dt0
|
|
bb=two*dtaup1
|
|
cc=dt0*dtaup1
|
|
aa=un/(dtau2+bb)
|
|
rip(id+1)=(bb*rim(id+1)+cc*st0(id+1)-dt0*st0(id))*aa
|
|
rim(id)=(two*rim(id+1)+dt0*st0(id+1)+cc*st0(id))*aa
|
|
aip(id+1)=(cc+bb*aim(id+1))*aa
|
|
aim(id)=cc*aa
|
|
enddo
|
|
do id=2,iud-1
|
|
dtt=un/(dtau(id-1)+dtau(id))
|
|
riup(id)=(rim(id)*dtau(id-1)+rip(id)*dtau(id))*dtt
|
|
aiup(id)=(aim(id)*dtau(id-1)+aip(id)*dtau(id))*dtt
|
|
enddo
|
|
riup(1)=rim(1)
|
|
riup(iud)=rim(iud)
|
|
aiup(1)=aim(1)
|
|
aiup(iud)=aim(iud)
|
|
C
|
|
C symmetrized (Feautrier) intensity -- (riin+riup)/2 --
|
|
C and interpolation in original radial grid
|
|
C
|
|
do id=1,iud
|
|
uf(id)=(riup(id)+riin(id))
|
|
af(id)=(aiup(id)+aiin(id))
|
|
end do
|
|
if(iu.le.nfiry) then
|
|
inrp=min(nud(iu),4)
|
|
call interp(densr,uf,dens,ptx,iud,nud(iu),inrp,1,0)
|
|
do id=1,nud(iu)
|
|
uf(id)=ptx(id)
|
|
end do
|
|
call interp(densr,af,dens,ptx,iud,nud(iu),inrp,1,0)
|
|
do id=1,nud(iu)
|
|
af(id)=ptx(id)
|
|
end do
|
|
iud=nud(iu)
|
|
end if
|
|
C
|
|
C Contribution to J
|
|
C
|
|
do id=1,nud(iu)
|
|
rad1(id)=rad1(id)+wmuj(iu,id)*uf(id)
|
|
ali1(id)=ali1(id)+wmuj(iu,id)*af(id)
|
|
end do
|
|
FLUXc(IJ)=FLUXc(IJ)+WMUH(IU)*RIM(1)
|
|
C
|
|
C End loop over impact rays
|
|
C
|
|
100 CONTINUE
|
|
C
|
|
C solution of the transfer equation
|
|
C Variables:
|
|
C RAD1 - mean intensity
|
|
C
|
|
NDX=NUDF(KMU)
|
|
CALL INTERP(DENSR,SS0,DENS,SCX,NDX,ND,4,1,1)
|
|
DJTOT=0.
|
|
DO ID=1,ND
|
|
RAD1(ID)=RAD1(ID)*HALF
|
|
ALI1(ID)=ALI1(ID)*HALF
|
|
SSS=SCX(ID)
|
|
c DELTAJ=(UN+SSS*ALI1(ID))*(RAD1(ID)-RAD00(ID))
|
|
DELTAJ=(RAD1(ID)-RAD00(ID))/(UN-SSS*ALI1(ID))
|
|
c DELTAJ=RAD1(ID)-RAD00(ID)
|
|
RAD00(ID)=RAD00(ID)+DELTAJ
|
|
DJTOT=MAX(DJTOT,ABS(DELTAJ/RAD00(ID)))
|
|
END DO
|
|
write(6,1600) ij,2.997925e18/fr,itrali,djtot,djmax
|
|
IF(DJTOT.GT.DJMAX.AND.ITRALI.LE.NTRALI) GO TO 10
|
|
1600 format(' IJ,LAM,ITRALI,DJ',i5,f10.2,i5,1p2e12.3)
|
|
C
|
|
C end loop for electron scattering
|
|
C
|
|
CALL INTERP(DENS,RAD00,DENSF,RDX,ND,NDF,4,1,0)
|
|
do id=1,ndf
|
|
sccf(ij,id)=scc0(ID)*RDX(ID)
|
|
enddo
|
|
fluxc(ij)=fluxc(ij)*2.997925e18/wlamc(ij)**2*0.5
|
|
C
|
|
500 CONTINUE
|
|
RETURN
|
|
END
|