188 lines
5.0 KiB
Fortran
188 lines
5.0 KiB
Fortran
SUBROUTINE RESOLW
|
|
C =================
|
|
C
|
|
C driver for evaluating opacities and emissivities which then
|
|
C enter the solution of the radiative transfer equation (RTEWIN)
|
|
C Setup opacities for a given frequency set
|
|
C Oversample in radial and frequency space for later interpolation
|
|
C
|
|
INCLUDE 'PARAMS.FOR'
|
|
INCLUDE 'MODELP.FOR'
|
|
INCLUDE 'SYNTHP.FOR'
|
|
INCLUDE 'WINCOM.FOR'
|
|
PARAMETER (UN=1., TWO=2., HALF=0.5)
|
|
DIMENSION CROSS(MCROSS,MOPAC),
|
|
* ABSO(MOPAC),EMIS(MOPAC),
|
|
* ABSOC(MFREQC),EMISC(MFREQC),SCATC(MFREQC)
|
|
DIMENSION ABSD(MDEPTH),ASF(MDEPF),XDS(MDEPTH),XDSF(MDEPF)
|
|
COMMON/CONOPA/CHC(MFREQC,MDEPTH),ETC(MFREQC,MDEPTH),
|
|
* SCC(MFREQC,MDEPTH)
|
|
COMMON/HPOPST/HPOP
|
|
COMMON/COPAC/AB(MOPAC,MDEPF),STH(MOPAC,MDEPF),SCH(MFREQC,MDEPF)
|
|
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
|
|
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
|
|
COMMON/FRQSET/IFRS,NFRS
|
|
COMMON/EMFLUX/FLUX(MFREQ),FLUXC(MFREQC)
|
|
C
|
|
C set up the partial line list for the current interval
|
|
C
|
|
CALL INISET
|
|
C
|
|
C output of information about selected lines
|
|
C
|
|
IF(IMODE.LT.2) CALL INIBLA
|
|
C
|
|
C Setup fine grid of frequencies
|
|
C
|
|
CLV=UN/2.997925E10
|
|
FQ1=FREQ(1)*(UN+VINF*CLV)
|
|
FQ2=FREQ(NFREQ)*(UN-VINF*CLV)
|
|
VXD=SQRT(0.3e7*TSTD)*FREQ(1)*CLV
|
|
VXS=SPACE0*FREQ(1)*FREQ(1)*CLV*1.e-7
|
|
c DVX=MAX(VXD,VXS)
|
|
DVX=VXS
|
|
NOPAC=int((FQ1-FQ2)/DVX)+1
|
|
DVX=(FQ1-FQ2)/DFLOAT(NOPAC)
|
|
NOPAC=NOPAC+3
|
|
nopac=nfreq
|
|
WRITE(6,600) NOPAC,NDF
|
|
IF(NOPAC.GT.MOPAC) CALL quit('Too many freqs in fine grid')
|
|
DO IJ=1,NOPAC
|
|
FFQ(ij)=FQ1-DFLOAT(ij-1)*DVX
|
|
c freq(ij)=ffq(ij)
|
|
c wlam(ij)=2.997925e18/freq(ij)
|
|
fr=freq(ij)*1.d-15
|
|
BNUE(IJ)=BN*fr*fr*fr
|
|
DO IJCI=IJC,NFREQC-1
|
|
IF(WLAM(IJ).LE.WLAMC(IJCI)) GO TO 248
|
|
END DO
|
|
248 CONTINUE
|
|
IJC=IJCI
|
|
IJCINT(IJ)=MAX(IJC-1,1)
|
|
IJCI=IJCINT(IJ)
|
|
FRX1(IJ)=(FREQ(IJ)-FREQC(IJCI+1))/
|
|
* (FREQC(IJCI)-FREQC(IJCI+1))
|
|
c write(80,681) ij,ijci,wlam(ij),wlamc(ijci),freq(ij),frx1(ij)
|
|
c 681 format(2i5,2f10.3,1p2e11.3)
|
|
END DO
|
|
nfreq=nopac
|
|
DO JI=1,NOPAC-1
|
|
FFQV(JI)=UN/(FFQ(JI)-FFQ(JI+1))
|
|
END DO
|
|
FFQV(NOPAC)=UN
|
|
c
|
|
c the continuum opacities and radiation field - done only once
|
|
c
|
|
c -----------------------------------
|
|
if(iblank.le.1) then
|
|
C
|
|
c determine the "core" radius and the factor that multiplies
|
|
c H_nu at ID=1 to get physical flux there (R2F)
|
|
c
|
|
ID0=ND
|
|
DO WHILE(TEMP(ID0).GT.TEFF .AND. ID0.GT.1)
|
|
ID0=ID0-1
|
|
END DO
|
|
ID0=ID0+1
|
|
R2F=RD(1)*RD(1)/RD(ID0)/RD(ID0)
|
|
c
|
|
C photoinization cross-sections
|
|
C
|
|
CALL CROSEW(CROSS)
|
|
C
|
|
C store opacity and emissivity in continuum
|
|
C
|
|
DO ID=1,ND
|
|
CALL OPACW(ID,CROSS,ABSO,EMIS,ABSOC,EMISC,SCATC,0)
|
|
DO IJ=1,NFREQC
|
|
CHC(IJ,ID)=ABSOC(IJ) / DENSCON(ID)
|
|
ETC(IJ,ID)=EMISC(IJ) / DENSCON(ID)
|
|
SCC(IJ,ID)=(SCATC(IJ)+ELEC(ID)*SIGE) / DENSCON(ID)
|
|
END DO
|
|
END DO
|
|
C
|
|
c radiation field in the continuum
|
|
c
|
|
call rtesca
|
|
do ij=1,nfreqc
|
|
write(17,640) wlamc(ij),fluxc(ij)*r2f
|
|
end do
|
|
640 FORMAT(1H ,F10.4,1PE15.5)
|
|
c
|
|
end if
|
|
c -----------------------------------
|
|
C
|
|
C Store opacity and thermal source function in all frequencies
|
|
C and depths
|
|
C
|
|
DO ID=1,ND
|
|
CALL OPACW(ID,CROSS,ABSO,EMIS,ABSOC,EMISC,SCATC,1)
|
|
DO IJ=1,NOPAC
|
|
AB(IJ,ID)=ABSO(IJ) / DENSCON(ID)
|
|
STH(IJ,ID)=EMIS(IJ)/ABSO(IJ)
|
|
END DO
|
|
END DO
|
|
C
|
|
c do id=1,nd
|
|
c do ij=1,nopac
|
|
c write(92,693) id,ij,wlam(ij),ab(ij,id),sth(ij,id)
|
|
c end do
|
|
c end do
|
|
c 693 format(2i5,f10.3,1p2e10.3)
|
|
C
|
|
C Interpolate to a finer radial (density) grid
|
|
C
|
|
if(ndf.ne.nd) then
|
|
DO ID=1,ND
|
|
XDS(ID)=LOG10(DENS(ID))
|
|
END DO
|
|
DO ID=1,NDF
|
|
XDSF(ID)=LOG10(DENSF(ID))
|
|
END DO
|
|
DO IJ=1,NOPAC
|
|
DO ID=1,ND
|
|
ABSD(ID)=AB(IJ,ID)
|
|
END DO
|
|
CALL INTERP(XDS ,ABSD,XDSF ,ASF,ND,NDF,2,0,1)
|
|
DO ID=1,NDF
|
|
AB(IJ,ID)=ASF(ID)
|
|
END DO
|
|
DO ID=1,ND
|
|
ABSD(ID)=STH(IJ,ID)
|
|
END DO
|
|
CALL INTERP(XDS ,ABSD,XDSF ,ASF,ND,NDF,2,0,1)
|
|
DO ID=1,NDF
|
|
STH(IJ,ID)=ASF(ID)
|
|
END DO
|
|
END DO
|
|
DO IJ=1,NFREQC
|
|
DO ID=1,ND
|
|
ABSD(ID)=SCC(IJ,ID)
|
|
END DO
|
|
CALL INTERP(XDS ,ABSD,XDSF ,ASF,ND,NDF,2,0,1)
|
|
DO ID=1,NDF
|
|
SCH(IJ,ID)=ASF(ID)
|
|
END DO
|
|
END DO
|
|
end if
|
|
WRITE(6,601)
|
|
600 FORMAT(/,' Opacity table for',i5,' frequencies and',/,
|
|
* ' ',i5,' radial (density) points')
|
|
601 FORMAT(' Done'/)
|
|
C
|
|
C
|
|
C Loop on rays, solving radiative transfer equation
|
|
C
|
|
DO IJ=1,NFREQ
|
|
FLUX(IJ)=0.
|
|
END DO
|
|
DO IU=2,KMU
|
|
CALL RTEWIN(IU)
|
|
END DO
|
|
DO IJ=1,NFREQ
|
|
FLUX(IJ)=FLUX(IJ)*R2F
|
|
END DO
|
|
C
|
|
RETURN
|
|
END
|