git push -u origin main
This commit is contained in:
@@ -0,0 +1,187 @@
|
||||
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
|
||||
Reference in New Issue
Block a user