fmq/SpectraRust
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

git push -u origin main

Browse Source
This commit is contained in:
fmq
2026-03-19 14:05:33 +08:00
commit 1e30b7bc63
739 changed files with 572150 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tlusty/._.DS_Store
BIN
View File
Binary file not shown.
tlusty/._BASICS.FOR
BIN
View File
Binary file not shown.
tlusty/ALIPAR.FOR
+29
View File
@@ -0,0 +1,29 @@
COMMON/FIXALP/ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ),
* REIT(MDEPTH),REIN(MDEPTH),REIM(MDEPTH),
* REIP(MLVEXP,MDEPTH),
* AREIT(MDEPTH),AREIN(MDEPTH),AREIM(MDEPTH),
* AREIP(MLVEXP,MDEPTH),
* CREIT(MDEPTH),CREIN(MDEPTH),CREIM(MDEPTH),
* CREIP(MLVEXP,MDEPTH),
* REIX(MDEPTH),CREIX(MDEPTH),
* REDX(MDEPTH),REDT(MDEPTH),REDN(MDEPTH),
* REDM(MDEPTH),REDP(MLVEXP,MDEPTH),
* REDXM(MDEPTH),REDTM(MDEPTH),REDNM(MDEPTH),
* REDMM(MDEPTH),REDPM(MLVEXP,MDEPTH),
* REDTP(MDEPTH),REDNP(MDEPTH),REDXP(MDEPTH),
* REDMP(MDEPTH),REDPP(MLVEXP,MDEPTH),
* HEIT(MDEPTH),HEIN(MDEPTH),HEIM(MDEPTH),
* HEIP(MLVEXP,MDEPTH),
* HEITM(MDEPTH),HEINM(MDEPTH),HEIMM(MDEPTH),
* HEIPM(MLVEXP,MDEPTH),
* HEITP(MDEPTH),HEINP(MDEPTH),HEIMP(MDEPTH),
* HEIPP(MLVEXP,MDEPTH),
* EHET(MDEPTH),EHEN(MDEPTH),ERET(MDEPTH),EREN(MDEPTH),
* EHEP(MLVEX3,MDEPTH),EREP(MLVEX3,MDEPTH),
* APT(MLVEXP,MDEPTH),APN(MLVEXP,MDEPTH),
* AAPT(MLVEX3,MDEPTH),AAPN(MLVEX3,MDEPTH),
* CAPT(MLVEX3,MDEPTH),CAPN(MLVEX3,MDEPTH),
* APP(MLVEXP,MLVEXP,MDEPTH),
* AAPP(MLVEX3,MLVEX3,MDEPTH),
* CAPP(MLVEX3,MLVEX3,MDEPTH),QTLAS,
* IFALI,IFPOPR,irprec,ifprec,itold1,itold2,itlas
tlusty/ARRAY1.FOR
+33
View File
@@ -0,0 +1,33 @@
COMMON A(MTOT,MTOT), B(MTOT,MTOT), C(MTOT,MTOT),
* E(MTOT,MTOT),
* VECL(MTOT), Y1(MTOT), Y2(MTOT),
* PSI0(MTOT), PSIM(MTOT), PSIP(MTOT),
* RAD0(MTOT), RADM(MTOT), RADP(MTOT),
* FKM(MFREX), FK0(MFREX), FKP(MFREX),
* ABSOM(MFREX), ABSO0(MFREX), ABSOP(MFREX),
* EMISM(MFREX), EMIS0(MFREX), EMISP(MFREX),
* SCATM(MFREX), SCAT0(MFREX), SCATP(MFREX),
* DABTM(MFREX), DABT0(MFREX), DABTP(MFREX),
* DEMTM(MFREX), DEMT0(MFREX), DEMTP(MFREX),
* DABNM(MFREX), DABN0(MFREX), DABNP(MFREX),
* DEMNM(MFREX), DEMN0(MFREX), DEMNP(MFREX),
* DABMM(MFREX), DABM0(MFREX), DABMP(MFREX),
* DEMMM(MFREX), DEMM0(MFREX), DEMMP(MFREX),
* WDEPM(MFREX), WDEP0(MFREX), WDEPP(MFREX),
* SBFM(MLEVEL), SBF0(MLEVEL), SBFP(MLEVEL),
* HEX(MLEVEL), REX(MLEVEL), REXA(MLEVEL),
* DSBFM(MLEVEL), DSBF0(MLEVEL), DSBFP(MLEVEL),
* SUMDCH(MLEVEL),
* DRCHM(MLEVEL,MFREX), DRETM(MLEVEL,MFREX),
* DRCH0(MLEVEL,MFREX), DRET0(MLEVEL,MFREX),
* DRCHP(MLEVEL,MFREX), DRETP(MLEVEL,MFREX)
COMMON/EXPRAD/
* ABSOEX(MFREX,MDEPTH),EMISEX(MFREX,MDEPTH),
* SCATEX(MFREX,MDEPTH),
* DABTEX(MFREX,MDEPTH),DEMTEX(MFREX,MDEPTH),
* DABNEX(MFREX,MDEPTH),DEMNEX(MFREX,MDEPTH),
* DABMEX(MFREX,MDEPTH),DEMMEX(MFREX,MDEPTH),
* DRCHEX(MLVEXP,MFREX,MDEPTH),
* DRETEX(MLVEXP,MFREX,MDEPTH)
COMMON/BPOCOM/ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),
* ATT(MLEVEL),ANN(MLEVEL)
tlusty/ATOMIC.FOR
+56
View File
@@ -0,0 +1,56 @@
C
PARAMETER (MPAG=MLEVEL/6+1)
C
CHARACTER*40 FIDATA(MION),FIODF1(MION),FIODF2(MION),FIBFCS(MION)
CHARACTER*10 TYPLEV(MLEVEL)
CHARACTER*4 TYPION(MION)
C
COMMON/ATOPAR/AMASS(MATOM),ABUND(MATOM,MDEPTH),NUMAT(MATOM),
* N0A(MATOM),NKA(MATOM),nref(matom),iatex(matom),
* nrefs(matom,mdepth),iadop(matom),
* iifix(matom),iatref,modref
common/atomas/amas(100)
COMMON/IONPAR/FF(MION),CHARG2(MION),
* NFIRST(MION),NLAST(MION),NNEXT(MION),
* IZ(MION),IUPSUM(MION),ICUP(MION),ilte(mion),
* iltion(mion)
COMMON/LEVPAR/ENION(MLEVEL),G(MLEVEL),NQUANT(MLEVEL),
* IATM(MLEVEL),IEL(MLEVEL),ILK(MLEVEL),ilin(mlevel),
* iltlev(mlevel),indlev(mlevel),
* imodl(mlevel),iiexp(mlevel),iifor(mlevel),
* ipzert(mlevel),
* igzert(mlevel),indlgz(mlevel),iinonz(mlevel),
* NLVEXP,NLVFOR,NLVEXZ,LBPFX
COMMON/TRAPAR/FR0(MTRANS),OSC0(MTRANS),CPAR(MTRANS),
* FRQMX(MTRANS),FR0PC(MTRANS),OMECOL(MLEVEL,MLEVEL),
* XGRAD,STRL1,STRL2,STRLX,
* ILOW(MTRANS),IUP(MTRANS),INDEXP(MTRANS),
* KFR0(MTRANS),KFR1(MTRANS),ILUCTR(MTRANS),
* IFC0(MTRANS),IFC1(MTRANS),
* IFR0(MTRANS),IFR1(MTRANS),ITRA(MLEVEL,MLEVEL),
* IPROF(MTRANS),ICOL(MTRANS),INTMOD(MTRANS),
* ITRCON(MTRANS),IDIEL(MTRANS),
* IJTF(MTRANS),LCOMP(MTRANS),LINE(MTRANS)
COMMON/PHOSET/S0CS(MLEVEL),ALFCS(MLEVEL),BETCS(MLEVEL),
* GAMCS(MLEVEL),IBF(MLEVEL)
COMMON/TOPCS/CTOP(MFIT,MCROSS), !sigma=alog10(sigma/10^-18) of fit point
* XTOP(MFIT,MCROSS) ! x = alog10(nu/nu0) of fit point
COMMON/TABCOL/CTEMP(MXTCOL,MCFIT,MCORAT), ! temperature vs.
* CRATE(MXTCOL,MCFIT,MCORAT) ! collisional rates
COMMON/VOIPAR/GAMAR(MVOIGT),STARK1(MVOIGT),STARK2(MVOIGT),
* STARK3(MVOIGT),VDWH(MVOIGT)
COMMON/HECRAT/COLHE1(19,19)
COMMON/TRACOR/LEXP(MTRANS),LALI(MTRANS)
COMMON/TRAALI/NFFIX,IFSUB,IFLEV
COMMON/AUXIND/IATH,IATHE,IELH,IELHM,IELHE1,IELHE2
COMMON/IONFIL/FIDATA,FIODF1,FIODF2,FIBFCS
COMMON/IONDAT/IATI(MION),IZI(MION),NLEVS(MION),NLLIM(MION)
COMMON/OSCHYD/OSH(20,20)
COMMON/PRINTP/NPGPOP,IIPR(6,MPAG),TYPLEV,TYPION
common/tabmax/frtabm
c
PARAMETER (MTRPRD=5)
COMMON/PRDPAR/DOPTR(MTRPRD,MDEPTH),COHER(MTRPRD,MDEPTH),
* PJBAR(MTRPRD,MDEPTH),RJBAR(MTRPRD,MDEPTH),
* XPDIV,
* IPRD(MTRANS),ITRTOT(MTRPRD),NTRPRD,IFPRD
tlusty/BASICS.FOR
+129
View File
@@ -0,0 +1,129 @@
C
C Parameters that specify dimensions of arrays
C
PARAMETER (MATOM = 99, ! max.num. of explicit atoms
* MION = 170, ! max.num. of explicit ions
* MLEVEL = 1134, ! max.num. of explicit levels
* MLVEXP = 233, ! max.num. of explicit linearized levels
* MTRANS =21000, ! max.num. of all transitions
* MDEPTH = 100, ! max.num. of depth points
* MFREQ =135000, ! max.num. of frequency points
* MFREQP=220000, ! working arrays of frequency
* MFREQC=125000, ! max.num. of freq.points in continuum
* MFREX = 54, ! max.num. of linearized frequencies
* MFREQL =25798, ! max.num. of frequencies per line
* MTOT = 280, ! max.num. of linearized parameters
* MMU = 6, ! max.num. of angle points
* MFIT = 357, ! max.num. of fit points (OP b-f c.s)
* MITJ = 380, ! max.num. of overlapping transitions
* MMCDW = 26, ! max.num. of levels with pseudocont.
* MMER = 12, ! max.num. of merged levels
* MVOIGT = 8080, ! max.num. of lines with Voigt profile
* MZZ = 10, ! maximum charge for occup.prob. ions
* NLMX = 80, ! highest hydrogenic level considered
* MSMX = 1, ! size of matrix kept in memory in SOLVE
* MFREQ1 =MFREQ, ! =1 for ISPLIN<5; =MFREQ otherwise
* MFRTAB =125000,! max.num. of freqeuncies in opac.table
C * MFRTAB = 3, ! max.num. of freqeuncies in opac.table
* MTABT = 21, ! max.number of temps in opac.table
* MTABR = 19, ! max.number of densities in opac.table
* MDEPTC = 2, ! max.num. of depth points (Compton)
* MMUC = 2, ! max.num. of angle points (Compton)
* MLEVE3 = 1, ! =1 for diag.prec; =MLEVEL for trid.prec.
* MLVEX3 = 1, ! =1 for diag.oper.; =MLVEXP for tridiag. .
* MTRAN3 = 1, ! =1 for diag.oper; =MTRANS for tridiag.
* MCROSS=MLEVEL+5,! max.num. of b-f cross.secs.
* MBF = MLEVEL, ! max.num. of b-f transitions
C NEW VARIABLES YFMO Jun 2017
* MCFIT = 10, ! max.num. of collision fit points
* MXTCOL = 3, ! max.num. of collision types (CE, CP, CH)
* MCORAT = MTRANS)! max.num. of col excitation transitions
C
C Basic physical constants
C
PARAMETER (H = 6.6256D-27, ! Planck constant h
* BOLK = 1.38054D-16, ! Boltzmann constant k
* HK = 4.79928144D-11, ! h/k
* CAS = 2.997925D18, ! light speed c (A/s)
* EH = 2.17853041D-11, ! ionizaton energy of hydrogen
* BN = 1.4743D-2, ! 2*h/c**3, c -light speed
* SIGE = 6.6516D-25, ! Thomson scattering c-s
* SIG4P = 4.5114062D-6, ! Stefan-Boltzmann const/4pi
* PI4H = 1.8966D27, ! 4pi/h
* PCK = 4.19168946D-10, ! 4pi/c
* HMASS = 1.67333D-24) ! mass of hydrogen atom
C
C Basic mathematical constants
C
PARAMETER (UN = 1.0D0,
* HALF = 0.5D0,
* TWO = 2.0D0)
C
C Unit number
C
PARAMETER (IBUFF = 95)
C
C Basic parameters
C
COMMON/BASNUM/NATOM,NION,NLEVEL,NTRANS,ND,NFREQ,NFREQC,NFREQE,
* IOPTAB,IDISK,IZSCAL,IDMFIX,IHESO6,IFMOL,IFENTR,
* NFREQL,NLEV0,ICOLHN,IOSCOR,ILGDER,IFRYB,IFRSET,
* NFREAD,NELSC,NTRANC,IOVER,JALI,IBC,IUBC,INTENS,
* IRDER,ILMCOR,IFDIEL,IFALIH,IFTENE,ITNDRE,
* ILPSCT,ILASCT,IRTE,IDLTE,IBFINT,INTRPL,ICHANG,
* NATOMS,IPSLTE,ISPODF,ITLUCY,NRETC,IFRAYL,IFPRAD
COMMON/INPPAR/TEFF,GRAV,
* YTOT(MDEPTH),WMM(MDEPTH),WMY(MDEPTH),
* TMOLIM,
* xmstar,xmdot,rstar,alpha0,reynum,
* QGRAV,EDISC,DZETA,RELDST,
* visc,zeta0,zeta1,dmvisc,fractv,
* omeg32,wbarm,wbar,alphav,pgas0,
* bergfc,cutlym,cutbal,
* ISPLIN,IRSPLT,ivisc,ibche,LTE,LTGREY,LCHC,LRESC
COMMON/MATKEY/NN,NN0,INHE,INRE,INPC,INSE,INZD,INMP,NDRE,insel
COMMON/FIXDEN/IFIXDE
COMMON/INVINT/XI2(NLMX),XI3(NLMX)
COMMON/RUNKEY/CHMAX,ITER,NITER,NITZER,INIT,LAC2,LFIN
COMMON/CONKEY/HMIX0,crflim,
* NCONIT,ICONV,INDL,IPRESS,ITEMP,ICBEG,
* itmcor,iconre,ideepc,ndcgap,IDCONZ
COMMON/OPCKEY/NCON,IOPHL1,IOPHL2,IPHE2C,IFMOFF
COMMON/PRINTS/IPRINT,IPRING,IPRIND,IPRINP,ICOOLP,ICHCKP,
* IPOPAC,IPRINI
COMMON/PSILIM/DPSILG,DPSILT,DPSILN,DPSILD
COMMON/CENTRL/ZND,IFZ0
C
C additional opacities
c
COMMON/OPCPAR/IOPADD,
* IOPHMI,
* IOPH2P,
* IOPHEM,
* IOPCH,
* IOPOH,
* IOPH2M,
* IOH2H2,IOH2HE,IOH2H,IOHHE,
* IOPHLI,
* IRSCT,
* IRSCHE,
* IRSCH2,
* KEEPOP,
* IOPOLD
C
COMMON/ANGLES/AMU(MMU),WTMU(MMU),FMU(MMU),NMU
c
common/comptn/amuc(mmuc),wtmuc(mmuc),
* amuc1(mmuc),amuc2(mmuc),amuc3(mmuc),
* amuj(mmuc),amuk(mmuc),amuh(mmuc),amun(mmuc),
* calph(mmuc,mmuc),cbeta(mmuc,mmuc),
* cgamm(mmuc,mmuc),RADZER,FRLCOM,
* SIGEC(MFREQ),ijorig(mfreq)
common/angnum/nmuc
common/compti/nedd,nsti,islab,ilbc,icompt,icomst,icomde,
* icombc,icmdra,knish,itcomp,icomve,icomrt,
* ichcoo,icomgr
common/comite/ncfor1,ncfor2,nccoup,ncitot,ncfull
common/mlcons/aconml,bconml,cconml
common/taursl/taurs(mdepth)
common/iprkey/iprybh,ipelch,ipeldo,ipconf
tlusty/IMPLIC.FOR
+1
View File
@@ -0,0 +1 @@
IMPLICIT REAL*8 (A-H,O-Z), LOGICAL*1 (L)
tlusty/ITERAT.FOR
+14
View File
@@ -0,0 +1,14 @@
PARAMETER (MITER = 200,
* MLAMBD = 100)
COMMON/LAMBDA/NLAMBD,IFFIX(MITER),NETEXP(MITER),NETFIX(MITER),
* IETEXP(MITER,MLAMBD),IETFIX(MITER,MLAMBD),
* NITLAM(MITER+1),IELCOR
COMMON/CHNMAT/INHE0(MITER),INRE0(MITER),INPC0(MITER),
* INDL0(MITER),INSE0(MITER),INMP0(MITER),
* NN00(MITER),NDRE0(MITER),LCHMAT,LIROST
COMMON/ACCEL/ORELAX,ITEK,IACC,IACC0,IACD,KANT(MITER),KSNG,
* LSNG(MTOT),LASO,LRES2
COMMON/ACCLP/ILAM,IACPP,IACC0P,IACDP,LAC2P
COMMON/ACCLT/IACLT,IACLDT
COMMON/CHNAD/CHMAXT,NLAMT,ILDER,IBPOPE
tlusty/MODELQ.FOR
+217
View File
@@ -0,0 +1,217 @@
C
PARAMETER (MLINH = 78,
* MHT = 7,
* MHE = 20,
* MHWL = 90)
c * MHWL = 65)
parameter (mfhtab=1000,
* mtabth=10,
* mtabeh=10)
INTEGER*2 ITRLIN
REAL*4 PRFLIN,BFCS
real*8 absopac(mtabt,mtabr,mfrtab)
C
COMMON/MODPAR/DM(MDEPTH),TEMP(MDEPTH),ELEC(MDEPTH),DENS(MDEPTH),
* TOTN(MDEPTH),
* ANTO(MDEPTH),ANMA(MDEPTH),ANH1(MDEPTH),ZD(MDEPTH),
* HKT1(MDEPTH),TK1(MDEPTH),HKT21(MDEPTH),SQT1(MDEPTH),
* TEMP1(MDEPTH),ELEC1(MDEPTH),DENS1(MDEPTH),
* DENSI(MDEPTH),DENSIM(MDEPTH),
* ELSCAT(MDEPTH),ALAB(MDEPTH),
c * ENRG(MDEPTH),
* DELDM(MDEPTH),DEDM1,DELDMZ(MDEPTH),
* THETAV(MDEPTH),VISCD(MDEPTH),DALPMX,XHYD,
* DMTOT,RRDIL,TEMPBD,ALPTAV,ALPGAV,NALP,IBETA
COMMON/LEVPOP/POPUL(MLEVEL,MDEPTH),BFAC(MLEVEL,MDEPTH),
* POPINV(MLEVEL,MDEPTH),
* POPGRP(MLEVEL),
* POP(MLEVEL),SBF(MLEVEL),DSBF(MLEVEL),USUM(MION)
COMMON/POPZR0/POPZER,POPZR2,POPZCH,RPOP0(MLVEXP,MDEPTH),
* IPZERO(MLEVEL,MDEPTH),IGZERO(MLVEXP,MDEPTH)
COMMON/CRSWPS/CRSW(MDEPTH),SWPFAC,SWPLIM,SWPINC,ICRSW
COMMON/WMCOMP/WNHINT(NLMX,MDEPTH),WNHEII(NLMX,MDEPTH),
* wop(mlevel,mdepth),ifwop(mlevel)
COMMON/REPART/REINT(MDEPTH),REDIF(MDEPTH),TAUDIV,IDLST
COMMON/TURBUL/VTURB(MDEPTH),VTURBS(MDEPTH),VTB,IPTURB
C
COMMON/LEVREF/SBPSI(MLEVEL,MDEPTH),SBLPSI(MLEVEL,MDEPTH),
* DSBPST(MLEVEL,MDEPTH),DSBPSN(MLEVEL,MDEPTH),
* ILTREF(MLEVEL,MDEPTH),IGUIDE(MLEVEL),
* ILTERF(MLEVEL,MDEPTH)
COMMON/LEVFIX/PT(MLEVEL,MDEPTH),PN(MLEVEL,MDEPTH),
* PP(MLEVEL,MDEPTH)
COMMON/LEVADD/USUMS(MION,MDEPTH),
* DUSMT(MION,MDEPTH),
* DUSMN(MION,MDEPTH),
* DIESIG(MION,MDEPTH)
COMMON/MRGPAR/SGM0(MMER),
* FRCH(MMER),
* SGEXT1(MMER,MDEPTH),
* GMER(MMER,MDEPTH),
* SGMSUM(NLMX,MMER,MDEPTH),
* SGMSUD(NLMX,MMER,MDEPTH),
* SGMG(MMER,MDEPTH),
* IMRG(MLEVEL),
* IIMER(MMER)
COMMON/UPSUMS/DUSUMT(MION),DUSUMN(MION)
C
COMMON/DWNPAR/ELEC23(MDEPTH),
* ACOR(MDEPTH),
* Z3(MZZ),
* DWC1(MZZ,MDEPTH),
* DWC2(MDEPTH),
* DWF1(MMCDW,MDEPTH),
C * DWFL(MFREQL,MDEPTH,MMCDW),
* MCDW(MTRANS),ITRCDW(MMCDW),NCDW
C
COMMON/OBFPAR/ITRBF(MBF)
C
COMMON/GFFPAR/GF0(MDEPTH),GF1(MDEPTH),GF2(MDEPTH),
* GF3(MDEPTH),GF4(MDEPTH),GF5(MDEPTH),GF6(MDEPTH),
* GF0D(MDEPTH),GF1D(MDEPTH),GF2D(MDEPTH),
* GF3D(MDEPTH),GF4D(MDEPTH),GF5D(MDEPTH),
* GF6D(MDEPTH),DELTT(MDEPTH)
C
COMMON/OFFPAR/SFF3(MION,MDEPTH),
* SFF2(MION,MDEPTH),
* DSFF(MION,MDEPTH),
* CFFN(MDEPTH),CFFT(MDEPTH)
C
COMMON/OTRPAR/ABTRA(MTRANS,MDEPTH),EMTRA(MTRANS,MDEPTH),
* DEMLT(MTRANS,MDEPTH)
C
COMMON/CURRNT/XKF(MDEPTH),XKF1(MDEPTH),XKFB(MDEPTH)
COMMON/CUROPA/ABSO1(MDEPTH),EMIS1(MDEPTH),SCAT1(MDEPTH),
* ABSOT(MDEPTH),ABSOE1(MFREX),
* EMEL1(MDEPTH),ABSO1L(MDEPTH),EMIS1L(MDEPTH),
* ABSOPR(MDEPTH),EMISPR(MDEPTH)
COMMON/TOTRAD/RAD(MFREQ1,MDEPTH),FHD(MFREQ),
* FAK(MFREQ1,MDEPTH),RADK(MFREQ1,MDEPTH),
* EXTRAD(MFREQ),EXTINT(MFREQ,MMU),HEXTRD(MFREQ),
* TRAD,WDIL,EXTOT,TSTAR
COMMON/CURRAD/RAD1(MDEPTH),ALI1(MDEPTH),FAK1(MDEPTH),
* radcm(mfreq,mdepth),
* RADL(MFREQL,MDEPTH),ABSALI(MFREQL,MDEPTH),
* alih1(mdepth)
COMMON/CURDER/DABT1(MDEPTH),DEMT1(MDEPTH),
* DABN1(MDEPTH),DEMN1(MDEPTH),
* DABM1(MDEPTH),DEMM1(MDEPTH),
* DABX1(MDEPTH),DEMX1(MDEPTH),
* DABP1(MLEVEL,MDEPTH),DEMP1(MLEVEL,MDEPTH),
* DRCH1(MLEVEL,MDEPTH),DRET1(MLEVEL,MDEPTH),
* ABSFF(MDEPTH),DABFT(MDEPTH),DABFN(MDEPTH),
* DSFDT(MDEPTH),DSFDN(MDEPTH),DSFDM(MDEPTH),
* DSFDP(MLVEXP,MDEPTH),
* DSFDTM(MDEPTH),DSFDNM(MDEPTH),
* DSFDPM(MLVEXP,MDEPTH),
* DSFDTP(MDEPTH),DSFDNP(MDEPTH),
* DSFDPP(MLVEXP,MDEPTH)
COMMON/CURTRI/ALIM1(MDEPTH),ALIP1(MDEPTH)
COMMON/EXPRAF/RADEX(MFREX,MDEPTH),FAKEX(MFREX,MDEPTH)
C
COMMON/TOTPRF/PRFLIN(MDEPTH,MFREQP)
COMMON/TOTFLX/FLTOT(MDEPTH),FLFIX(MDEPTH),FLEXP(MDEPTH),
* FCOOL(MDEPTH),FCOOLI(MDEPTH),FLRD(MDEPTH),
* FPRAD(MDEPTH),GRAD(MDEPTH),FPRD(MDEPTH),
* GRADF(MDEPTH,MFREQ)
C
COMMON/RRATES/RRU(MTRANS,MDEPTH),RRD(MTRANS,MDEPTH),
* DRDT(MTRANS,MDEPTH)
COMMON/RRTOFF/RDDP(MTRAN3,MDEPTH),RDDM(MTRAN3,MDEPTH)
COMMON/CRATES/COLRAT(MTRANS,MDEPTH),COLTAR(MTRANS,MDEPTH)
C
COMMON/FRQALL/FREQ(MFREQ),W(MFREQ),PROF(MFREQP),WCH(MFREQ),
* JIK(MFREQ),IJX(MFREQ),IJBF(MFREQ),IFS0,
* KIJ(MFREQ),LSKIP(MDEPTH,MFREQ)
COMMON/FRQINT/FRCMAX,FRCMIN,FRLMAX,FRLMIN,CFRMAX,DFTAIL,
* TSNU,VTNU,DDNU,CNU1,CNU2,IELNU,NFTAIL
COMMON/LINOVR/NITJ(MFREQ),IJLIN(MFREQ),ITRLIN(MITJ,MFREQ)
COMMON/LINFRQ/NLINES(MFREQ)
COMMON/PHOEXP/AIJBF(MFREQ),BFCS(MCROSS,MFREQC),IFREQB(MFREQC)
COMMON/FREAUX/W0E(MFREQ),BNUE(MFREQ),WC(MFREQ),
* IJTC(MTRANS),IJALI(MFREQ),IJEX(MFREQ),IJFR(MFREQ)
COMMON/COMPIF/LINEXP(MTRANS)
C
COMMON/SURFAC/FLUX(MFREQ),FH(MFREQ),Q0(MFREQ),UU0(MFREQ)
C
COMMON/FILES/PSY0(MTOT,MDEPTH),PSY1(MTOT,MDEPTH),
* PSY2(MTOT,MDEPTH),PSY3(MTOT,MDEPTH)
C
COMMON/PRESSR/PTOTAL(MDEPTH),PGS(MDEPTH),PRADT(MDEPTH),
& PRADA(MDEPTH)
COMMON/HEQAUX/PRD0,IHECOR
COMMON/OPMEAN/ABROSD(MDEPTH),SUMDPL(MDEPTH),
& ABPLAD(MDEPTH),ABPMIN
COMMON/CHARFX/QFIX(MDEPTH)
COMMON/WINDBL/ALBE(MFREQ),IWINBL
COMMON/DFEALI/DJMAX,NTRALI
COMMON/OPACAD/ABAD,EMAD,SCAD,DAT,DAN,DET,DEN,DST,DSN,DDN(MLEVEL)
COMMON/MODCON/FLXC(MDEPTH),DELTA(MDEPTH)
COMMON/RESDER/RSAT,RSBT,RSAN,RSBN,RSAX(MLEVEL),RSBX(MLEVEL)
COMMON/GRAYTS/TAUROS(MDEPTH),TAUFLX(MDEPTH),
* TAUTHE(MDEPTH),THETA(MDEPTH)
COMMON/TAURSS/TROSS(MDEPTH)
COMMON/TCONST/TDISK,ITCONS
C
COMMON/HYDADD/PHMOL(MDEPTH),ANEREL,IHM,IH2,IH2P
COMMON/ELDNSP/ANP,AHTOT,AHMOL
C
COMMON/RRVALS/RR(99,99),ABNDD(99,MDEPTH),ENEV(99,30),IONIZ(99),
* IREF,IREFA,LGR(99),LRM(99)
COMMON/STATEP/Q,QM,DQT,DQN,DQM,ENER,ENTR,QREF,DQTR,DQNR,PFHYD
COMMON/ODFCHT/CHANT(MDEPTH)
COMMON/STRAUX/XK0(MLINH),XK,DBETA,BETAD,ADH,DIVH
COMMON/STDPAR/ELSTD,IDSTD
c
c parameters for hydrogen Stark broadening tables
c
COMMON/HYDPRF/PRFHYD(MLINH,MHWL,MHT,MHE),
* WLHYD(MLINH,MHWL),
* WLH(MHWL,MLINH),
* XTLEM(MHT,MLINH),
* XNELEM(MHE,MLINH),
* NWLHYD(MLINH),
* NWLH(MLINH),
* NTH(MLINH),
* NEH(MLINH),
* ILINH(4,22),
* IHYDPR
C
COMMON/XENPRF/PRFXB(MLINH,MHWL,MHT,MHE),
* PRFXR(MLINH,MHWL,MHT,MHE),
* ALXEN(MLINH,MHWL),
* XTXEN(MHT,MLINH),
* XNEXEN(MHE,MLINH),XNEMIN,
* NWLXEN(MLINH),
* NTHXEN(MLINH),
* NEHXEN(MLINH),
* ILXEN(4,22),
* IHXENB
C
COMMON/LTEGRP/TAUFIR,TAULAS,ABROS0,TSURF,ALBAVE,DION0,
* DM1,ABPLA0,NNEWD,
* NDGREY,IDGREY
COMMON/COMPTF/DLNFR(MFREQ),BNUS(MFREQ),
* CDER10(MFREQ),CDER1P(MFREQ),CDER1M(MFREQ),
* CDER20(MFREQ),CDER2P(MFREQ),CDER2M(MFREQ),
* DELJ(MFREQ,MDEPTH)
COMMON/VISPAR/TVISC(MDEPTH),DTVIST(MDEPTH),DTVISN(MDEPTH),
* DTVISR(MDEPTH)
C
c parameters for the opacity tables
c
COMMON/TABLOP/ FRTB1,FRTB2,RTAB1,RTAB2,TTAB1,TTAB2
common/numbopac/ numfreq,numrho,numtemp,numrh(mtabt)
common/vectors/ tempvec(mtabt),rhovec(mtabr),
* rhomat(mtabt,mtabr)
common/opacities/frtab(mfrtab),frtlim,absopac
common/raytbl/raytab(mtabt,mtabr),raysc(mdepth)
common/binopa/ibinop
C
c parameters for the hydrogen opacity tables
c
common/tabhyg/hglim,ihgom
COMMON/TABLOH/ FRGTB1,FRGTB2,EGTAB1,EGTAB2,TGTAB1,TGTAB2
common/numgopac/ nugfreq,nugele,nugtemp
common/vectorg/ temvec(mtabth),elevec(mtabeh)
common/opacitieg/frgtab(mfhtab),hydcrs(mtabth,mtabeh,mfhtab)
tlusty/ODFPAR.FOR
+34
View File
@@ -0,0 +1,34 @@
PARAMETER (MFODF = 180,
* MHOD = 3,
* MFRO = MFREQL,
* MDODF = 3,
c * MKULEV= 2,
c * MLINE = 2,
c * MCFE = 2 )
* MKULEV= 7000,
* MLINE = 1140000,
* MCFE = 7824000 )
C
REAL*4 SIGFE
C
COMMON/ODFION/INODF1(MION),INODF2(MION),INBFCS(MION),
* IKOBS(MION)
C
COMMON/ODFCTR/FRODF(MLEVEL),NFRODF(MHOD),INDODF(MLEVEL),
* JNDODF(MTRANS)
COMMON/ODFFRQ/FROS(MFRO,MHOD),WNUS(MFRO,MHOD),XDO(3,MHOD),
* KDO(4,MHOD)
COMMON/ODFMOD/I1ODF(MLEVEL),I2ODF(MLEVEL),NQLODF(MLEVEL)
COMMON/ODFSTK/XKIJ(MHOD,NLMX),WL0(MHOD,NLMX),FIJ(MHOD,NLMX)
COMMON/SPLCOM/SIGFE(MDODF,MCFE),
& FRS1,FRS2,DXNU,XJID(MDEPTH),JIDI(MDEPTH),JIDR(MDODF),
& JIDS,JIDN,NFRS1,NFTT
COMMON/OPALIM/M1FILE(NLMX,MHOD),M2FILE(NLMX,MHOD),IMERG
COMMON/OPLIMT/ALLIM1,ABLIM1,ABLIM2,ABLIM3
COMMON/LEVCOM/EMKU(MLEVEL,2),YMKU(MLEVEL,2),
& XEV(MLEVEL,MION),XOD(MLEVEL,MION),EU(2*MLEVEL),
& JEN(2*MLEVEL),
& EEV(MKULEV),AEV(MKULEV),SEV(MKULEV),WEV(MKULEV),
& EOD(MKULEV),AOD(MKULEV),SOD(MKULEV),WOD(MKULEV),
& KSEV(MKULEV),KSOD(MKULEV),NEVKU(MION),NODKU(MION),
& NLEVKU,NLINKU,KEVE,KODD
tlusty/extracted/ALIPAR.FOR
+29
View File
@@ -0,0 +1,29 @@
COMMON/FIXALP/ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ),
* REIT(MDEPTH),REIN(MDEPTH),REIM(MDEPTH),
* REIP(MLVEXP,MDEPTH),
* AREIT(MDEPTH),AREIN(MDEPTH),AREIM(MDEPTH),
* AREIP(MLVEXP,MDEPTH),
* CREIT(MDEPTH),CREIN(MDEPTH),CREIM(MDEPTH),
* CREIP(MLVEXP,MDEPTH),
* REIX(MDEPTH),CREIX(MDEPTH),
* REDX(MDEPTH),REDT(MDEPTH),REDN(MDEPTH),
* REDM(MDEPTH),REDP(MLVEXP,MDEPTH),
* REDXM(MDEPTH),REDTM(MDEPTH),REDNM(MDEPTH),
* REDMM(MDEPTH),REDPM(MLVEXP,MDEPTH),
* REDTP(MDEPTH),REDNP(MDEPTH),REDXP(MDEPTH),
* REDMP(MDEPTH),REDPP(MLVEXP,MDEPTH),
* HEIT(MDEPTH),HEIN(MDEPTH),HEIM(MDEPTH),
* HEIP(MLVEXP,MDEPTH),
* HEITM(MDEPTH),HEINM(MDEPTH),HEIMM(MDEPTH),
* HEIPM(MLVEXP,MDEPTH),
* HEITP(MDEPTH),HEINP(MDEPTH),HEIMP(MDEPTH),
* HEIPP(MLVEXP,MDEPTH),
* EHET(MDEPTH),EHEN(MDEPTH),ERET(MDEPTH),EREN(MDEPTH),
* EHEP(MLVEX3,MDEPTH),EREP(MLVEX3,MDEPTH),
* APT(MLVEXP,MDEPTH),APN(MLVEXP,MDEPTH),
* AAPT(MLVEX3,MDEPTH),AAPN(MLVEX3,MDEPTH),
* CAPT(MLVEX3,MDEPTH),CAPN(MLVEX3,MDEPTH),
* APP(MLVEXP,MLVEXP,MDEPTH),
* AAPP(MLVEX3,MLVEX3,MDEPTH),
* CAPP(MLVEX3,MLVEX3,MDEPTH),QTLAS,
* IFALI,IFPOPR,irprec,ifprec,itold1,itold2,itlas
tlusty/extracted/ARRAY1.FOR
+33
View File
@@ -0,0 +1,33 @@
COMMON A(MTOT,MTOT), B(MTOT,MTOT), C(MTOT,MTOT),
* E(MTOT,MTOT),
* VECL(MTOT), Y1(MTOT), Y2(MTOT),
* PSI0(MTOT), PSIM(MTOT), PSIP(MTOT),
* RAD0(MTOT), RADM(MTOT), RADP(MTOT),
* FKM(MFREX), FK0(MFREX), FKP(MFREX),
* ABSOM(MFREX), ABSO0(MFREX), ABSOP(MFREX),
* EMISM(MFREX), EMIS0(MFREX), EMISP(MFREX),
* SCATM(MFREX), SCAT0(MFREX), SCATP(MFREX),
* DABTM(MFREX), DABT0(MFREX), DABTP(MFREX),
* DEMTM(MFREX), DEMT0(MFREX), DEMTP(MFREX),
* DABNM(MFREX), DABN0(MFREX), DABNP(MFREX),
* DEMNM(MFREX), DEMN0(MFREX), DEMNP(MFREX),
* DABMM(MFREX), DABM0(MFREX), DABMP(MFREX),
* DEMMM(MFREX), DEMM0(MFREX), DEMMP(MFREX),
* WDEPM(MFREX), WDEP0(MFREX), WDEPP(MFREX),
* SBFM(MLEVEL), SBF0(MLEVEL), SBFP(MLEVEL),
* HEX(MLEVEL), REX(MLEVEL), REXA(MLEVEL),
* DSBFM(MLEVEL), DSBF0(MLEVEL), DSBFP(MLEVEL),
* SUMDCH(MLEVEL),
* DRCHM(MLEVEL,MFREX), DRETM(MLEVEL,MFREX),
* DRCH0(MLEVEL,MFREX), DRET0(MLEVEL,MFREX),
* DRCHP(MLEVEL,MFREX), DRETP(MLEVEL,MFREX)
COMMON/EXPRAD/
* ABSOEX(MFREX,MDEPTH),EMISEX(MFREX,MDEPTH),
* SCATEX(MFREX,MDEPTH),
* DABTEX(MFREX,MDEPTH),DEMTEX(MFREX,MDEPTH),
* DABNEX(MFREX,MDEPTH),DEMNEX(MFREX,MDEPTH),
* DABMEX(MFREX,MDEPTH),DEMMEX(MFREX,MDEPTH),
* DRCHEX(MLVEXP,MFREX,MDEPTH),
* DRETEX(MLVEXP,MFREX,MDEPTH)
COMMON/BPOCOM/ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),
* ATT(MLEVEL),ANN(MLEVEL)
tlusty/extracted/ATOMIC.FOR
+56
View File
@@ -0,0 +1,56 @@
C
PARAMETER (MPAG=MLEVEL/6+1)
C
CHARACTER*40 FIDATA(MION),FIODF1(MION),FIODF2(MION),FIBFCS(MION)
CHARACTER*10 TYPLEV(MLEVEL)
CHARACTER*4 TYPION(MION)
C
COMMON/ATOPAR/AMASS(MATOM),ABUND(MATOM,MDEPTH),NUMAT(MATOM),
* N0A(MATOM),NKA(MATOM),nref(matom),iatex(matom),
* nrefs(matom,mdepth),iadop(matom),
* iifix(matom),iatref,modref
common/atomas/amas(100)
COMMON/IONPAR/FF(MION),CHARG2(MION),
* NFIRST(MION),NLAST(MION),NNEXT(MION),
* IZ(MION),IUPSUM(MION),ICUP(MION),ilte(mion),
* iltion(mion)
COMMON/LEVPAR/ENION(MLEVEL),G(MLEVEL),NQUANT(MLEVEL),
* IATM(MLEVEL),IEL(MLEVEL),ILK(MLEVEL),ilin(mlevel),
* iltlev(mlevel),indlev(mlevel),
* imodl(mlevel),iiexp(mlevel),iifor(mlevel),
* ipzert(mlevel),
* igzert(mlevel),indlgz(mlevel),iinonz(mlevel),
* NLVEXP,NLVFOR,NLVEXZ,LBPFX
COMMON/TRAPAR/FR0(MTRANS),OSC0(MTRANS),CPAR(MTRANS),
* FRQMX(MTRANS),FR0PC(MTRANS),OMECOL(MLEVEL,MLEVEL),
* XGRAD,STRL1,STRL2,STRLX,
* ILOW(MTRANS),IUP(MTRANS),INDEXP(MTRANS),
* KFR0(MTRANS),KFR1(MTRANS),ILUCTR(MTRANS),
* IFC0(MTRANS),IFC1(MTRANS),
* IFR0(MTRANS),IFR1(MTRANS),ITRA(MLEVEL,MLEVEL),
* IPROF(MTRANS),ICOL(MTRANS),INTMOD(MTRANS),
* ITRCON(MTRANS),IDIEL(MTRANS),
* IJTF(MTRANS),LCOMP(MTRANS),LINE(MTRANS)
COMMON/PHOSET/S0CS(MLEVEL),ALFCS(MLEVEL),BETCS(MLEVEL),
* GAMCS(MLEVEL),IBF(MLEVEL)
COMMON/TOPCS/CTOP(MFIT,MCROSS), !sigma=alog10(sigma/10^-18) of fit point
* XTOP(MFIT,MCROSS) ! x = alog10(nu/nu0) of fit point
COMMON/TABCOL/CTEMP(MXTCOL,MCFIT,MCORAT), ! temperature vs.
* CRATE(MXTCOL,MCFIT,MCORAT) ! collisional rates
COMMON/VOIPAR/GAMAR(MVOIGT),STARK1(MVOIGT),STARK2(MVOIGT),
* STARK3(MVOIGT),VDWH(MVOIGT)
COMMON/HECRAT/COLHE1(19,19)
COMMON/TRACOR/LEXP(MTRANS),LALI(MTRANS)
COMMON/TRAALI/NFFIX,IFSUB,IFLEV
COMMON/AUXIND/IATH,IATHE,IELH,IELHM,IELHE1,IELHE2
COMMON/IONFIL/FIDATA,FIODF1,FIODF2,FIBFCS
COMMON/IONDAT/IATI(MION),IZI(MION),NLEVS(MION),NLLIM(MION)
COMMON/OSCHYD/OSH(20,20)
COMMON/PRINTP/NPGPOP,IIPR(6,MPAG),TYPLEV,TYPION
common/tabmax/frtabm
c
PARAMETER (MTRPRD=5)
COMMON/PRDPAR/DOPTR(MTRPRD,MDEPTH),COHER(MTRPRD,MDEPTH),
* PJBAR(MTRPRD,MDEPTH),RJBAR(MTRPRD,MDEPTH),
* XPDIV,
* IPRD(MTRANS),ITRTOT(MTRPRD),NTRPRD,IFPRD
tlusty/extracted/BASICS.FOR
+129
View File
@@ -0,0 +1,129 @@
C
C Parameters that specify dimensions of arrays
C
PARAMETER (MATOM = 99, ! max.num. of explicit atoms
* MION = 170, ! max.num. of explicit ions
* MLEVEL = 1134, ! max.num. of explicit levels
* MLVEXP = 233, ! max.num. of explicit linearized levels
* MTRANS =21000, ! max.num. of all transitions
* MDEPTH = 100, ! max.num. of depth points
* MFREQ =135000, ! max.num. of frequency points
* MFREQP=220000, ! working arrays of frequency
* MFREQC=125000, ! max.num. of freq.points in continuum
* MFREX = 54, ! max.num. of linearized frequencies
* MFREQL =25798, ! max.num. of frequencies per line
* MTOT = 280, ! max.num. of linearized parameters
* MMU = 6, ! max.num. of angle points
* MFIT = 357, ! max.num. of fit points (OP b-f c.s)
* MITJ = 380, ! max.num. of overlapping transitions
* MMCDW = 26, ! max.num. of levels with pseudocont.
* MMER = 12, ! max.num. of merged levels
* MVOIGT = 8080, ! max.num. of lines with Voigt profile
* MZZ = 10, ! maximum charge for occup.prob. ions
* NLMX = 80, ! highest hydrogenic level considered
* MSMX = 1, ! size of matrix kept in memory in SOLVE
* MFREQ1 =MFREQ, ! =1 for ISPLIN<5; =MFREQ otherwise
* MFRTAB =125000,! max.num. of freqeuncies in opac.table
C * MFRTAB = 3, ! max.num. of freqeuncies in opac.table
* MTABT = 21, ! max.number of temps in opac.table
* MTABR = 19, ! max.number of densities in opac.table
* MDEPTC = 2, ! max.num. of depth points (Compton)
* MMUC = 2, ! max.num. of angle points (Compton)
* MLEVE3 = 1, ! =1 for diag.prec; =MLEVEL for trid.prec.
* MLVEX3 = 1, ! =1 for diag.oper.; =MLVEXP for tridiag. .
* MTRAN3 = 1, ! =1 for diag.oper; =MTRANS for tridiag.
* MCROSS=MLEVEL+5,! max.num. of b-f cross.secs.
* MBF = MLEVEL, ! max.num. of b-f transitions
C NEW VARIABLES YFMO Jun 2017
* MCFIT = 10, ! max.num. of collision fit points
* MXTCOL = 3, ! max.num. of collision types (CE, CP, CH)
* MCORAT = MTRANS)! max.num. of col excitation transitions
C
C Basic physical constants
C
PARAMETER (H = 6.6256D-27, ! Planck constant h
* BOLK = 1.38054D-16, ! Boltzmann constant k
* HK = 4.79928144D-11, ! h/k
* CAS = 2.997925D18, ! light speed c (A/s)
* EH = 2.17853041D-11, ! ionizaton energy of hydrogen
* BN = 1.4743D-2, ! 2*h/c**3, c -light speed
* SIGE = 6.6516D-25, ! Thomson scattering c-s
* SIG4P = 4.5114062D-6, ! Stefan-Boltzmann const/4pi
* PI4H = 1.8966D27, ! 4pi/h
* PCK = 4.19168946D-10, ! 4pi/c
* HMASS = 1.67333D-24) ! mass of hydrogen atom
C
C Basic mathematical constants
C
PARAMETER (UN = 1.0D0,
* HALF = 0.5D0,
* TWO = 2.0D0)
C
C Unit number
C
PARAMETER (IBUFF = 95)
C
C Basic parameters
C
COMMON/BASNUM/NATOM,NION,NLEVEL,NTRANS,ND,NFREQ,NFREQC,NFREQE,
* IOPTAB,IDISK,IZSCAL,IDMFIX,IHESO6,IFMOL,IFENTR,
* NFREQL,NLEV0,ICOLHN,IOSCOR,ILGDER,IFRYB,IFRSET,
* NFREAD,NELSC,NTRANC,IOVER,JALI,IBC,IUBC,INTENS,
* IRDER,ILMCOR,IFDIEL,IFALIH,IFTENE,ITNDRE,
* ILPSCT,ILASCT,IRTE,IDLTE,IBFINT,INTRPL,ICHANG,
* NATOMS,IPSLTE,ISPODF,ITLUCY,NRETC,IFRAYL,IFPRAD
COMMON/INPPAR/TEFF,GRAV,
* YTOT(MDEPTH),WMM(MDEPTH),WMY(MDEPTH),
* TMOLIM,
* xmstar,xmdot,rstar,alpha0,reynum,
* QGRAV,EDISC,DZETA,RELDST,
* visc,zeta0,zeta1,dmvisc,fractv,
* omeg32,wbarm,wbar,alphav,pgas0,
* bergfc,cutlym,cutbal,
* ISPLIN,IRSPLT,ivisc,ibche,LTE,LTGREY,LCHC,LRESC
COMMON/MATKEY/NN,NN0,INHE,INRE,INPC,INSE,INZD,INMP,NDRE,insel
COMMON/FIXDEN/IFIXDE
COMMON/INVINT/XI2(NLMX),XI3(NLMX)
COMMON/RUNKEY/CHMAX,ITER,NITER,NITZER,INIT,LAC2,LFIN
COMMON/CONKEY/HMIX0,crflim,
* NCONIT,ICONV,INDL,IPRESS,ITEMP,ICBEG,
* itmcor,iconre,ideepc,ndcgap,IDCONZ
COMMON/OPCKEY/NCON,IOPHL1,IOPHL2,IPHE2C,IFMOFF
COMMON/PRINTS/IPRINT,IPRING,IPRIND,IPRINP,ICOOLP,ICHCKP,
* IPOPAC,IPRINI
COMMON/PSILIM/DPSILG,DPSILT,DPSILN,DPSILD
COMMON/CENTRL/ZND,IFZ0
C
C additional opacities
c
COMMON/OPCPAR/IOPADD,
* IOPHMI,
* IOPH2P,
* IOPHEM,
* IOPCH,
* IOPOH,
* IOPH2M,
* IOH2H2,IOH2HE,IOH2H,IOHHE,
* IOPHLI,
* IRSCT,
* IRSCHE,
* IRSCH2,
* KEEPOP,
* IOPOLD
C
COMMON/ANGLES/AMU(MMU),WTMU(MMU),FMU(MMU),NMU
c
common/comptn/amuc(mmuc),wtmuc(mmuc),
* amuc1(mmuc),amuc2(mmuc),amuc3(mmuc),
* amuj(mmuc),amuk(mmuc),amuh(mmuc),amun(mmuc),
* calph(mmuc,mmuc),cbeta(mmuc,mmuc),
* cgamm(mmuc,mmuc),RADZER,FRLCOM,
* SIGEC(MFREQ),ijorig(mfreq)
common/angnum/nmuc
common/compti/nedd,nsti,islab,ilbc,icompt,icomst,icomde,
* icombc,icmdra,knish,itcomp,icomve,icomrt,
* ichcoo,icomgr
common/comite/ncfor1,ncfor2,nccoup,ncitot,ncfull
common/mlcons/aconml,bconml,cconml
common/taursl/taurs(mdepth)
common/iprkey/iprybh,ipelch,ipeldo,ipconf
tlusty/extracted/IMPLIC.FOR
+1
View File
@@ -0,0 +1 @@
IMPLICIT REAL*8 (A-H,O-Z), LOGICAL*1 (L)
tlusty/extracted/ITERAT.FOR
+14
View File
@@ -0,0 +1,14 @@
PARAMETER (MITER = 200,
* MLAMBD = 100)
COMMON/LAMBDA/NLAMBD,IFFIX(MITER),NETEXP(MITER),NETFIX(MITER),
* IETEXP(MITER,MLAMBD),IETFIX(MITER,MLAMBD),
* NITLAM(MITER+1),IELCOR
COMMON/CHNMAT/INHE0(MITER),INRE0(MITER),INPC0(MITER),
* INDL0(MITER),INSE0(MITER),INMP0(MITER),
* NN00(MITER),NDRE0(MITER),LCHMAT,LIROST
COMMON/ACCEL/ORELAX,ITEK,IACC,IACC0,IACD,KANT(MITER),KSNG,
* LSNG(MTOT),LASO,LRES2
COMMON/ACCLP/ILAM,IACPP,IACC0P,IACDP,LAC2P
COMMON/ACCLT/IACLT,IACLDT
COMMON/CHNAD/CHMAXT,NLAMT,ILDER,IBPOPE
tlusty/extracted/MODELQ.FOR
+217
View File
@@ -0,0 +1,217 @@
C
PARAMETER (MLINH = 78,
* MHT = 7,
* MHE = 20,
* MHWL = 90)
c * MHWL = 65)
parameter (mfhtab=1000,
* mtabth=10,
* mtabeh=10)
INTEGER*2 ITRLIN
REAL*4 PRFLIN,BFCS
real*8 absopac(mtabt,mtabr,mfrtab)
C
COMMON/MODPAR/DM(MDEPTH),TEMP(MDEPTH),ELEC(MDEPTH),DENS(MDEPTH),
* TOTN(MDEPTH),
* ANTO(MDEPTH),ANMA(MDEPTH),ANH1(MDEPTH),ZD(MDEPTH),
* HKT1(MDEPTH),TK1(MDEPTH),HKT21(MDEPTH),SQT1(MDEPTH),
* TEMP1(MDEPTH),ELEC1(MDEPTH),DENS1(MDEPTH),
* DENSI(MDEPTH),DENSIM(MDEPTH),
* ELSCAT(MDEPTH),ALAB(MDEPTH),
c * ENRG(MDEPTH),
* DELDM(MDEPTH),DEDM1,DELDMZ(MDEPTH),
* THETAV(MDEPTH),VISCD(MDEPTH),DALPMX,XHYD,
* DMTOT,RRDIL,TEMPBD,ALPTAV,ALPGAV,NALP,IBETA
COMMON/LEVPOP/POPUL(MLEVEL,MDEPTH),BFAC(MLEVEL,MDEPTH),
* POPINV(MLEVEL,MDEPTH),
* POPGRP(MLEVEL),
* POP(MLEVEL),SBF(MLEVEL),DSBF(MLEVEL),USUM(MION)
COMMON/POPZR0/POPZER,POPZR2,POPZCH,RPOP0(MLVEXP,MDEPTH),
* IPZERO(MLEVEL,MDEPTH),IGZERO(MLVEXP,MDEPTH)
COMMON/CRSWPS/CRSW(MDEPTH),SWPFAC,SWPLIM,SWPINC,ICRSW
COMMON/WMCOMP/WNHINT(NLMX,MDEPTH),WNHEII(NLMX,MDEPTH),
* wop(mlevel,mdepth),ifwop(mlevel)
COMMON/REPART/REINT(MDEPTH),REDIF(MDEPTH),TAUDIV,IDLST
COMMON/TURBUL/VTURB(MDEPTH),VTURBS(MDEPTH),VTB,IPTURB
C
COMMON/LEVREF/SBPSI(MLEVEL,MDEPTH),SBLPSI(MLEVEL,MDEPTH),
* DSBPST(MLEVEL,MDEPTH),DSBPSN(MLEVEL,MDEPTH),
* ILTREF(MLEVEL,MDEPTH),IGUIDE(MLEVEL),
* ILTERF(MLEVEL,MDEPTH)
COMMON/LEVFIX/PT(MLEVEL,MDEPTH),PN(MLEVEL,MDEPTH),
* PP(MLEVEL,MDEPTH)
COMMON/LEVADD/USUMS(MION,MDEPTH),
* DUSMT(MION,MDEPTH),
* DUSMN(MION,MDEPTH),
* DIESIG(MION,MDEPTH)
COMMON/MRGPAR/SGM0(MMER),
* FRCH(MMER),
* SGEXT1(MMER,MDEPTH),
* GMER(MMER,MDEPTH),
* SGMSUM(NLMX,MMER,MDEPTH),
* SGMSUD(NLMX,MMER,MDEPTH),
* SGMG(MMER,MDEPTH),
* IMRG(MLEVEL),
* IIMER(MMER)
COMMON/UPSUMS/DUSUMT(MION),DUSUMN(MION)
C
COMMON/DWNPAR/ELEC23(MDEPTH),
* ACOR(MDEPTH),
* Z3(MZZ),
* DWC1(MZZ,MDEPTH),
* DWC2(MDEPTH),
* DWF1(MMCDW,MDEPTH),
C * DWFL(MFREQL,MDEPTH,MMCDW),
* MCDW(MTRANS),ITRCDW(MMCDW),NCDW
C
COMMON/OBFPAR/ITRBF(MBF)
C
COMMON/GFFPAR/GF0(MDEPTH),GF1(MDEPTH),GF2(MDEPTH),
* GF3(MDEPTH),GF4(MDEPTH),GF5(MDEPTH),GF6(MDEPTH),
* GF0D(MDEPTH),GF1D(MDEPTH),GF2D(MDEPTH),
* GF3D(MDEPTH),GF4D(MDEPTH),GF5D(MDEPTH),
* GF6D(MDEPTH),DELTT(MDEPTH)
C
COMMON/OFFPAR/SFF3(MION,MDEPTH),
* SFF2(MION,MDEPTH),
* DSFF(MION,MDEPTH),
* CFFN(MDEPTH),CFFT(MDEPTH)
C
COMMON/OTRPAR/ABTRA(MTRANS,MDEPTH),EMTRA(MTRANS,MDEPTH),
* DEMLT(MTRANS,MDEPTH)
C
COMMON/CURRNT/XKF(MDEPTH),XKF1(MDEPTH),XKFB(MDEPTH)
COMMON/CUROPA/ABSO1(MDEPTH),EMIS1(MDEPTH),SCAT1(MDEPTH),
* ABSOT(MDEPTH),ABSOE1(MFREX),
* EMEL1(MDEPTH),ABSO1L(MDEPTH),EMIS1L(MDEPTH),
* ABSOPR(MDEPTH),EMISPR(MDEPTH)
COMMON/TOTRAD/RAD(MFREQ1,MDEPTH),FHD(MFREQ),
* FAK(MFREQ1,MDEPTH),RADK(MFREQ1,MDEPTH),
* EXTRAD(MFREQ),EXTINT(MFREQ,MMU),HEXTRD(MFREQ),
* TRAD,WDIL,EXTOT,TSTAR
COMMON/CURRAD/RAD1(MDEPTH),ALI1(MDEPTH),FAK1(MDEPTH),
* radcm(mfreq,mdepth),
* RADL(MFREQL,MDEPTH),ABSALI(MFREQL,MDEPTH),
* alih1(mdepth)
COMMON/CURDER/DABT1(MDEPTH),DEMT1(MDEPTH),
* DABN1(MDEPTH),DEMN1(MDEPTH),
* DABM1(MDEPTH),DEMM1(MDEPTH),
* DABX1(MDEPTH),DEMX1(MDEPTH),
* DABP1(MLEVEL,MDEPTH),DEMP1(MLEVEL,MDEPTH),
* DRCH1(MLEVEL,MDEPTH),DRET1(MLEVEL,MDEPTH),
* ABSFF(MDEPTH),DABFT(MDEPTH),DABFN(MDEPTH),
* DSFDT(MDEPTH),DSFDN(MDEPTH),DSFDM(MDEPTH),
* DSFDP(MLVEXP,MDEPTH),
* DSFDTM(MDEPTH),DSFDNM(MDEPTH),
* DSFDPM(MLVEXP,MDEPTH),
* DSFDTP(MDEPTH),DSFDNP(MDEPTH),
* DSFDPP(MLVEXP,MDEPTH)
COMMON/CURTRI/ALIM1(MDEPTH),ALIP1(MDEPTH)
COMMON/EXPRAF/RADEX(MFREX,MDEPTH),FAKEX(MFREX,MDEPTH)
C
COMMON/TOTPRF/PRFLIN(MDEPTH,MFREQP)
COMMON/TOTFLX/FLTOT(MDEPTH),FLFIX(MDEPTH),FLEXP(MDEPTH),
* FCOOL(MDEPTH),FCOOLI(MDEPTH),FLRD(MDEPTH),
* FPRAD(MDEPTH),GRAD(MDEPTH),FPRD(MDEPTH),
* GRADF(MDEPTH,MFREQ)
C
COMMON/RRATES/RRU(MTRANS,MDEPTH),RRD(MTRANS,MDEPTH),
* DRDT(MTRANS,MDEPTH)
COMMON/RRTOFF/RDDP(MTRAN3,MDEPTH),RDDM(MTRAN3,MDEPTH)
COMMON/CRATES/COLRAT(MTRANS,MDEPTH),COLTAR(MTRANS,MDEPTH)
C
COMMON/FRQALL/FREQ(MFREQ),W(MFREQ),PROF(MFREQP),WCH(MFREQ),
* JIK(MFREQ),IJX(MFREQ),IJBF(MFREQ),IFS0,
* KIJ(MFREQ),LSKIP(MDEPTH,MFREQ)
COMMON/FRQINT/FRCMAX,FRCMIN,FRLMAX,FRLMIN,CFRMAX,DFTAIL,
* TSNU,VTNU,DDNU,CNU1,CNU2,IELNU,NFTAIL
COMMON/LINOVR/NITJ(MFREQ),IJLIN(MFREQ),ITRLIN(MITJ,MFREQ)
COMMON/LINFRQ/NLINES(MFREQ)
COMMON/PHOEXP/AIJBF(MFREQ),BFCS(MCROSS,MFREQC),IFREQB(MFREQC)
COMMON/FREAUX/W0E(MFREQ),BNUE(MFREQ),WC(MFREQ),
* IJTC(MTRANS),IJALI(MFREQ),IJEX(MFREQ),IJFR(MFREQ)
COMMON/COMPIF/LINEXP(MTRANS)
C
COMMON/SURFAC/FLUX(MFREQ),FH(MFREQ),Q0(MFREQ),UU0(MFREQ)
C
COMMON/FILES/PSY0(MTOT,MDEPTH),PSY1(MTOT,MDEPTH),
* PSY2(MTOT,MDEPTH),PSY3(MTOT,MDEPTH)
C
COMMON/PRESSR/PTOTAL(MDEPTH),PGS(MDEPTH),PRADT(MDEPTH),
& PRADA(MDEPTH)
COMMON/HEQAUX/PRD0,IHECOR
COMMON/OPMEAN/ABROSD(MDEPTH),SUMDPL(MDEPTH),
& ABPLAD(MDEPTH),ABPMIN
COMMON/CHARFX/QFIX(MDEPTH)
COMMON/WINDBL/ALBE(MFREQ),IWINBL
COMMON/DFEALI/DJMAX,NTRALI
COMMON/OPACAD/ABAD,EMAD,SCAD,DAT,DAN,DET,DEN,DST,DSN,DDN(MLEVEL)
COMMON/MODCON/FLXC(MDEPTH),DELTA(MDEPTH)
COMMON/RESDER/RSAT,RSBT,RSAN,RSBN,RSAX(MLEVEL),RSBX(MLEVEL)
COMMON/GRAYTS/TAUROS(MDEPTH),TAUFLX(MDEPTH),
* TAUTHE(MDEPTH),THETA(MDEPTH)
COMMON/TAURSS/TROSS(MDEPTH)
COMMON/TCONST/TDISK,ITCONS
C
COMMON/HYDADD/PHMOL(MDEPTH),ANEREL,IHM,IH2,IH2P
COMMON/ELDNSP/ANP,AHTOT,AHMOL
C
COMMON/RRVALS/RR(99,99),ABNDD(99,MDEPTH),ENEV(99,30),IONIZ(99),
* IREF,IREFA,LGR(99),LRM(99)
COMMON/STATEP/Q,QM,DQT,DQN,DQM,ENER,ENTR,QREF,DQTR,DQNR,PFHYD
COMMON/ODFCHT/CHANT(MDEPTH)
COMMON/STRAUX/XK0(MLINH),XK,DBETA,BETAD,ADH,DIVH
COMMON/STDPAR/ELSTD,IDSTD
c
c parameters for hydrogen Stark broadening tables
c
COMMON/HYDPRF/PRFHYD(MLINH,MHWL,MHT,MHE),
* WLHYD(MLINH,MHWL),
* WLH(MHWL,MLINH),
* XTLEM(MHT,MLINH),
* XNELEM(MHE,MLINH),
* NWLHYD(MLINH),
* NWLH(MLINH),
* NTH(MLINH),
* NEH(MLINH),
* ILINH(4,22),
* IHYDPR
C
COMMON/XENPRF/PRFXB(MLINH,MHWL,MHT,MHE),
* PRFXR(MLINH,MHWL,MHT,MHE),
* ALXEN(MLINH,MHWL),
* XTXEN(MHT,MLINH),
* XNEXEN(MHE,MLINH),XNEMIN,
* NWLXEN(MLINH),
* NTHXEN(MLINH),
* NEHXEN(MLINH),
* ILXEN(4,22),
* IHXENB
C
COMMON/LTEGRP/TAUFIR,TAULAS,ABROS0,TSURF,ALBAVE,DION0,
* DM1,ABPLA0,NNEWD,
* NDGREY,IDGREY
COMMON/COMPTF/DLNFR(MFREQ),BNUS(MFREQ),
* CDER10(MFREQ),CDER1P(MFREQ),CDER1M(MFREQ),
* CDER20(MFREQ),CDER2P(MFREQ),CDER2M(MFREQ),
* DELJ(MFREQ,MDEPTH)
COMMON/VISPAR/TVISC(MDEPTH),DTVIST(MDEPTH),DTVISN(MDEPTH),
* DTVISR(MDEPTH)
C
c parameters for the opacity tables
c
COMMON/TABLOP/ FRTB1,FRTB2,RTAB1,RTAB2,TTAB1,TTAB2
common/numbopac/ numfreq,numrho,numtemp,numrh(mtabt)
common/vectors/ tempvec(mtabt),rhovec(mtabr),
* rhomat(mtabt,mtabr)
common/opacities/frtab(mfrtab),frtlim,absopac
common/raytbl/raytab(mtabt,mtabr),raysc(mdepth)
common/binopa/ibinop
C
c parameters for the hydrogen opacity tables
c
common/tabhyg/hglim,ihgom
COMMON/TABLOH/ FRGTB1,FRGTB2,EGTAB1,EGTAB2,TGTAB1,TGTAB2
common/numgopac/ nugfreq,nugele,nugtemp
common/vectorg/ temvec(mtabth),elevec(mtabeh)
common/opacitieg/frgtab(mfhtab),hydcrs(mtabth,mtabeh,mfhtab)
tlusty/extracted/Makefile
+52
View File
@@ -0,0 +1,52 @@
# Makefile for TLUSTY extracted modules
# 使用大内存模型支持大型 COMMON 数组
FC = gfortran
FFLAGS = -O3 -fno-automatic -mcmodel=large
# 编译输出目录
BUILD_DIR = build
# 目标可执行文件
MAIN = $(BUILD_DIR)/tlusty_extracted
# 所有 .f 源文件
SRCS = $(wildcard *.f)
# 目标文件（放在build目录）
OBJS = $(patsubst %.f,$(BUILD_DIR)/%.o,$(notdir $(SRCS)))
# 默认目标
all: $(BUILD_DIR) $(MAIN)
@echo "=========================================="
@echo "编译成功: $(MAIN)"
@echo "=========================================="
# 创建build目录
$(BUILD_DIR):
mkdir -p $(BUILD_DIR)
# 链接所有目标文件
$(MAIN): $(OBJS)
$(FC) $(FFLAGS) -o $@ $(OBJS)
# 编译规则
$(BUILD_DIR)/%.o: %.f | $(BUILD_DIR)
$(FC) $(FFLAGS) -c $< -o $@
# 清理
clean:
rm -rf $(BUILD_DIR)
# 只编译不链接（检查语法）
compile-only: $(OBJS)
@echo "所有文件编译完成（未链接）"
# 统计信息
stats:
@echo "=== 编译统计 ==="
@echo "源文件数: $(words $(SRCS))"
@echo "目标文件数: $(words $(OBJS))"
@wc -l *.f | tail -1
.PHONY: all clean compile-only stats
tlusty/extracted/ODFPAR.FOR
+34
View File
@@ -0,0 +1,34 @@
PARAMETER (MFODF = 180,
* MHOD = 3,
* MFRO = MFREQL,
* MDODF = 3,
c * MKULEV= 2,
c * MLINE = 2,
c * MCFE = 2 )
* MKULEV= 7000,
* MLINE = 1140000,
* MCFE = 7824000 )
C
REAL*4 SIGFE
C
COMMON/ODFION/INODF1(MION),INODF2(MION),INBFCS(MION),
* IKOBS(MION)
C
COMMON/ODFCTR/FRODF(MLEVEL),NFRODF(MHOD),INDODF(MLEVEL),
* JNDODF(MTRANS)
COMMON/ODFFRQ/FROS(MFRO,MHOD),WNUS(MFRO,MHOD),XDO(3,MHOD),
* KDO(4,MHOD)
COMMON/ODFMOD/I1ODF(MLEVEL),I2ODF(MLEVEL),NQLODF(MLEVEL)
COMMON/ODFSTK/XKIJ(MHOD,NLMX),WL0(MHOD,NLMX),FIJ(MHOD,NLMX)
COMMON/SPLCOM/SIGFE(MDODF,MCFE),
& FRS1,FRS2,DXNU,XJID(MDEPTH),JIDI(MDEPTH),JIDR(MDODF),
& JIDS,JIDN,NFRS1,NFTT
COMMON/OPALIM/M1FILE(NLMX,MHOD),M2FILE(NLMX,MHOD),IMERG
COMMON/OPLIMT/ALLIM1,ABLIM1,ABLIM2,ABLIM3
COMMON/LEVCOM/EMKU(MLEVEL,2),YMKU(MLEVEL,2),
& XEV(MLEVEL,MION),XOD(MLEVEL,MION),EU(2*MLEVEL),
& JEN(2*MLEVEL),
& EEV(MKULEV),AEV(MKULEV),SEV(MKULEV),WEV(MKULEV),
& EOD(MKULEV),AOD(MKULEV),SOD(MKULEV),WOD(MKULEV),
& KSEV(MKULEV),KSOD(MKULEV),NEVKU(MION),NODKU(MION),
& NLEVKU,NLINKU,KEVE,KODD
tlusty/extracted/_COMMON_ANALYSIS.txt
+418
View File
@@ -0,0 +1,418 @@
COMMON 块依赖分析
============================================================
有 COMMON 依赖的单元:
------------------------------------------------------------
ACCELP: POPULS
ALLARD: callarda, quasun, callardb, callardc, callardg, calphatd
ALLARDT: calphatd
BHED: SURFEX, CMATZD
BHEZ: SURFEX
BPOPC: ADCHAR
CHANGE: BLANK
CHCTAB: abntab
COLIS: CTRTEMP
COLUMN: relcor
COMPT0: auxcbc
COMSET: comgfs, auxcbc
CONOUT: CUBCON
CONREF: imucnn, CUBCON
CONTMD: BLANK, PRSAUX, CUBCON
CONTMP: ichndm, BLANK, CUBCON
CONVC1: CUBCON
CONVEC: CUBCON
COOLRT: COOLCO
CTDATA: CTRecomb, CTIon
CUBIC: CUBCON
DMDER: DEPTDR
ELCOR: ADCHAR
ELDENC: eospar, hmolab, eletab
ELDENS: terden, eospar
GETLAL: quasun, callarda, callardb, callardc, callardg, calphatd
GHYDOP: intcfg
GOMINI: intcfg
HCTION: CTIon, CTRTEMP
HCTRECOM: CTRecomb, CTRTEMP
HEDIF: hediff
HESOL6: PRSAUX
HESOLV: PRSAUX
INCLDY: BLANK
INICOM: comgfs
INIFRC: ijflar
INIFRT: ijflar
INITIA: INUNIT, freqcl, STRPAR
INKUL: LINED, COLKUR, lined
INPDIS: relcor
INPMOD: BLANK, eospar
IROSET: LINED
KURUCZ: BLANK, temlim
LEVCD: COLKUR
LINPRO: quasun
LTEGR: BLANK
LTEGRD: TOTJHK, FLXAUX, CUBCON, PRSAUX, FACTRS
MATCON: CUBCON
MOLEQ: terden, COMFH1, adchar, hmolab, ioniz2, eospar, moldat, entrop
MPARTF: moldat
NEWDM: FLXAUX, PRSAUX, FACTRS
NEWDMT: FLXAUX, PRSAUX, FACTRS
NSTPAR: ichndm, hediff, deridt, ifpzpa, irwint, quasun, FLXAUX, freqcl, adiaba, ipricr, imucnn, temlim, moldat, derdif, icnrsp
ODFSET: STFCR
OPACF0: hmolab
OPACF1: ipricr, hmolab
OPACFA: COOLCO
OPACFD: dsctva, hmolab, rhoder
OPACT1: hmolab
OPACTD: dsctva, hmolab, rhoder
OPACTR: dsctva, hmolab, grdpra
OPADD: eospar
OPDATA: TOPB
OPFRAC: pfoptb
OUTPRI: grdpra
PARTF: irwint, PFSTDS
PGSET: grdpra, rybpgs
PROFIL: quasun
PRSENT: TABLTD, THERM, tdflag, tdedge
PZEVAL: icnrsp
PZEVLD: PRSAUX, DEPTDR, grdpra, ifpzpa
QUASIM: quasun
RADTOT: OPTDPT, SURFEX, TOTJHK
RAYLEIGH: eospar, RAYSCT
RDATA: INUNIT, STRPAR, imodlc
RESOLV: icnrsp
RHSGEN: CUBCON
RTEANG: SURFEX, EXTINT
RTECF0: OPTDPT, AUXRTE, auxcbc
RTECF1: OPTDPT, SURFEX, comgfs, EXTINT, AUXRTE
RTECMC: comgfs, AUXRTE
RTECMU: OPTDPT, AUXRTE
RTECOM: OPTDPT, comgfs, AUXRTE
RTEDF1: OPTDPT
RTEFR1: OPTDPT
RTEINT: OPTDPT
RUSSEL: COMFH1
RYBCHN: grdpra, rybpgs
RYBENE: RYBMTX, deridt, CUBCON
RYBHEQ: grdpra, rybpgs
RYBMAT: RYBMTX, dsctva
RYBSOL: RYBMTX, imodlc
SETDRT: RHODER
SETTRM: TABLTD, THERM, tdflag, tdedge
SOLVE: CMATZD
SOLVES: CMATZD, STOMAT
START: hediff
STATE: terden, PFSTDS
STEQEQ: POPSTR, PPAPAR
TABINI: abntab, eletab, intcff
TABINT: intcff
TAUFR1: OPTDPT
TEMCOR: CUBCON
TEMPER: FLXAUX, PRSAUX, FACTRS
TLOCAL: FLXAUX, FACTRS
TOPBAS: TOPB
TRMDER: derdif, adiaba, terden
TRMDRT: CONVOUT, tdflag, tdedge, CC
共 108 个单元有 COMMON 依赖
共 108 个 COMMON 块被引用
唯一的 COMMON 块: ['ADCHAR', 'AUXRTE', 'BLANK', 'CC', 'CMATZD', 'COLKUR', 'COMFH1', 'CONVOUT', 'COOLCO', 'CTIon', 'CTRTEMP', 'CTRecomb', 'CUBCON', 'DEPTDR', 'EXTINT', 'FACTRS', 'FLXAUX', 'INUNIT', 'LINED', 'OPTDPT', 'PFSTDS', 'POPSTR', 'POPULS', 'PPAPAR', 'PRSAUX', 'RAYSCT', 'RHODER', 'RYBMTX', 'STFCR', 'STOMAT', 'STRPAR', 'SURFEX', 'TABLTD', 'THERM', 'TOPB', 'TOTJHK', 'abntab', 'adchar', 'adiaba', 'auxcbc', 'callarda', 'callardb', 'callardc', 'callardg', 'calphatd', 'comgfs', 'derdif', 'deridt', 'dsctva', 'eletab', 'entrop', 'eospar', 'freqcl', 'grdpra', 'hediff', 'hmolab', 'ichndm', 'icnrsp', 'ifpzpa', 'ijflar', 'imodlc', 'imucnn', 'intcff', 'intcfg', 'ioniz2', 'ipricr', 'irwint', 'lined', 'moldat', 'pfoptb', 'quasun', 'relcor', 'rhoder', 'rybpgs', 'tdedge', 'tdflag', 'temlim', 'terden']
INCLUDE 文件依赖:
------------------------------------------------------------
ACCEL2: MODELQ.FOR, ITERAT.FOR, BASICS.FOR, IMPLIC.FOR
ACCELP: ITERAT.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
ALIFR1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
ALIFR3: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
ALIFR6: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
ALIFRK: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
ALISK1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
ALISK2: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
ALIST1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
ALIST2: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
ALLARD: BASICS.FOR, IMPLIC.FOR
ALLARDT: BASICS.FOR, IMPLIC.FOR
ANGSET: BASICS.FOR, IMPLIC.FOR
BETAH: IMPLIC.FOR
BHE: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BHED: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BHEZ: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BKHSGO: IMPLIC.FOR
BPOP: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
BPOPC: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ARRAY1.FOR, IMPLIC.FOR
BPOPE: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
BPOPF: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ARRAY1.FOR, IMPLIC.FOR
BPOPT: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ARRAY1.FOR, IMPLIC.FOR
BRE: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BREZ: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BRTE: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BRTEZ: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
BUTLER: IMPLIC.FOR
CARBON: IMPLIC.FOR
CEH12: IMPLIC.FOR
CHANGE: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CHCKSE: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CHCTAB: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
CHEAV: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CHEAVJ: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CION: IMPLIC.FOR
CKOEST: BASICS.FOR, IMPLIC.FOR
COLH: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
COLHE: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
COLIS: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
COLLHE: IMPLIC.FOR
COLUMN: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
COMPT0: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
COMSET: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
CONCOR: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
CONOUT: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
CONREF: MODELQ.FOR, ARRAY1.FOR, BASICS.FOR, IMPLIC.FOR
CONTMD: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
CONTMP: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
CONVC1: BASICS.FOR, IMPLIC.FOR
CONVEC: BASICS.FOR, IMPLIC.FOR
COOLRT: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
CORRWM: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CROSS: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CROSSD: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CSPEC: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
CTDATA: IMPLIC.FOR
CUBIC: BASICS.FOR, IMPLIC.FOR
DIELRC: IMPLIC.FOR
DIETOT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
DIVSTR: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
DMDER: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
DMEVAL: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
DOPGAM: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
DWNFR: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
DWNFR0: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
DWNFR1: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
EINT: IMPLIC.FOR
ELCOR: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
ELDENC: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
ELDENS: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
EMAT: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
ENTENE: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
ERFCIN: IMPLIC.FOR
ERFCX: IMPLIC.FOR
EXPINT: IMPLIC.FOR
EXPINX: IMPLIC.FOR
EXPO: IMPLIC.FOR
FFCROS: IMPLIC.FOR
GAMI: IMPLIC.FOR
GAMSP: BASICS.FOR, IMPLIC.FOR
GAULEG: IMPLIC.FOR
GAUNT: IMPLIC.FOR
GETLAL: BASICS.FOR, IMPLIC.FOR
GETWRD: IMPLIC.FOR
GFREE0: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
GFREE1: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
GFREED: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
GHYDOP: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
GNTK: IMPLIC.FOR
GOMINI: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
GRCOR: IMPLIC.FOR
GREYD: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
GRIDP: BASICS.FOR, IMPLIC.FOR
H2MINUS: BASICS.FOR, IMPLIC.FOR
HCTION: IMPLIC.FOR
HCTRECOM: IMPLIC.FOR
HEDIF: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
HEPHOT: IMPLIC.FOR
HESOL6: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
HESOLV: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
HIDALG: IMPLIC.FOR
IJALI2: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
IJALIS: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
INCLDY: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
INDEXX: IMPLIC.FOR
INICOM: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
INIFRC: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
INIFRS: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
INIFRT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
INILAM: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
INITIA: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
INKUL: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
INPDIS: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
INPMOD: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
INTERP: BASICS.FOR, IMPLIC.FOR
INTHYD: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
INTLEM: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
INTXEN: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
IRC: IMPLIC.FOR
IROSET: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
KURUCZ: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
LAGRAN: IMPLIC.FOR
LAGUER: IMPLIC.FOR
LEMINI: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
LEVCD: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
LEVGRP: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
LEVSET: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
LEVSOL: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
LINEQS: BASICS.FOR, IMPLIC.FOR
LINPRO: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
LINSEL: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
LINSET: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
LINSPL: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
LOCATE: IMPLIC.FOR
LTEGR: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
LTEGRD: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
LUCY: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
LYMLIN: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
MATCON: MODELQ.FOR, ARRAY1.FOR, BASICS.FOR, IMPLIC.FOR
MATGEN: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
MATINV: BASICS.FOR, IMPLIC.FOR
MEANOP: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
MEANOPT: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
MINV3: IMPLIC.FOR
MOLEQ: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
NEWDM: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
NEWDMT: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
NEWPOP: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
NSTOUT: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
NSTPAR: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
ODF1: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
ODFFR: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
ODFHST: ODFPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
ODFHYD: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
ODFHYS: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
ODFMER: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
ODFSET: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPACF0: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPACF1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPACFA: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPACFD: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
OPACFL: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPACT1: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
OPACTD: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
OPACTR: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
OPADD: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
OPADD0: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
OPAHST: ODFPAR.FOR, BASICS.FOR, IMPLIC.FOR
OPAINI: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
OPCTAB: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
OPDATA: IMPLIC.FOR
OPFRAC: IMPLIC.FOR
OSCCOR: ITERAT.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
OUTPRI: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
OUTPUT: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
PARTF: BASICS.FOR, IMPLIC.FOR
PFCNO: BASICS.FOR, IMPLIC.FOR
PFFE: IMPLIC.FOR
PFHEAV: IMPLIC.FOR
PFNI: IMPLIC.FOR
PFSPEC: IMPLIC.FOR
PGSET: MODELQ.FOR, ITERAT.FOR, BASICS.FOR, IMPLIC.FOR
PRCHAN: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
PRD: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
PRDINI: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
PRINC: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
PRNT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
PROFIL: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
PROFSP: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
PRSENT: IMPLIC.FOR
PSOLVE: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
PZERT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
PZEVAL: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
PZEVLD: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
QUARTC: IMPLIC.FOR
QUASIM: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
RADPRE: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
RADTOT: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
RAPH: IMPLIC.FOR
RATES1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
RATMAL: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
RATMAT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
RATSP1: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
RAYINI: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
RAYLEIGH: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
RAYSET: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RDATA: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, ITERAT.FOR, IMPLIC.FOR
RDATAX: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
READBF: BASICS.FOR, IMPLIC.FOR
RECHCK: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
REFLEV: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
REIMAN: IMPLIC.FOR
RESOLV: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
RHOEOS: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RHONEN: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RHSGEN: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
ROSSOP: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, IMPLIC.FOR
ROSSTD: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTEANG: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RTECF0: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTECF1: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTECMC: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTECMU: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTECOM: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTEDF1: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RTEDF2: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RTEFE2: BASICS.FOR, IMPLIC.FOR
RTEFR1: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTEINT: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
RTESOL: BASICS.FOR, IMPLIC.FOR
RTE_SC: BASICS.FOR, IMPLIC.FOR
RUSSEL: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RYBCHN: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
RYBENE: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
RYBHEQ: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
RYBMAT: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
RYBSOL: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
SABOLF: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SBFCH: IMPLIC.FOR
SBFHE1: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SBFHMI: IMPLIC.FOR
SBFHMI_OLD: IMPLIC.FOR
SBFOH: IMPLIC.FOR
SETDRT: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
SETTRM: IMPLIC.FOR
SFFHMI: IMPLIC.FOR
SFFHMI_ADD: IMPLIC.FOR
SGHE12: IMPLIC.FOR
SGMER0: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SGMER1: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SGMERD: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SIGAVE: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
SIGK: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SIGMAR: BASICS.FOR, IMPLIC.FOR
SOLVE: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
SOLVES: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, ARRAY1.FOR, IMPLIC.FOR
SPSIGK: IMPLIC.FOR
SRTFRQ: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
STARK0: IMPLIC.FOR
STARKA: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
START: BASICS.FOR, IMPLIC.FOR
STATE: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
STEQEQ: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
SWITCH: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
SZIRC: IMPLIC.FOR
TABINI: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
TABINT: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
TAUFR1: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
TDPINI: ATOMIC.FOR, BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
TEMCOR: BASICS.FOR, ALIPAR.FOR, MODELQ.FOR, ARRAY1.FOR, IMPLIC.FOR
TEMPER: ALIPAR.FOR, MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
TIOPF: IMPLIC.FOR
TLOCAL: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
TLUSTY: ALIPAR.FOR, ITERAT.FOR, BASICS.FOR, IMPLIC.FOR
TOPBAS: IMPLIC.FOR
TRAINI: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ODFPAR.FOR, IMPLIC.FOR
TRIDAG: IMPLIC.FOR
TRMDER: BASICS.FOR, IMPLIC.FOR
TRMDRT: BASICS.FOR, IMPLIC.FOR
UBETA: IMPLIC.FOR
VERN16: BASICS.FOR, IMPLIC.FOR
VERN18: BASICS.FOR, IMPLIC.FOR
VERN20: BASICS.FOR, IMPLIC.FOR
VERN26: BASICS.FOR, IMPLIC.FOR
VERNER: ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
VISINI: ATOMIC.FOR, BASICS.FOR, MODELQ.FOR, ITERAT.FOR, IMPLIC.FOR
VOIGT: IMPLIC.FOR
VOIGTE: IMPLIC.FOR
WN: BASICS.FOR, IMPLIC.FOR
WNSTOR: MODELQ.FOR, ATOMIC.FOR, BASICS.FOR, IMPLIC.FOR
XENINI: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
XK2DOP: IMPLIC.FOR
YINT: IMPLIC.FOR
YLINTP: IMPLIC.FOR
ZMRHO: MODELQ.FOR, BASICS.FOR, IMPLIC.FOR
tlusty/extracted/_PURE_UNITS.txt
+198
View File
@@ -0,0 +1,198 @@
无 COMMON 依赖的纯函数/子程序
========================================
ACCEL2
ALIFR1
ALIFR3
ALIFR6
ALIFRK
ALISK1
ALISK2
ALIST1
ALIST2
ANGSET
BETAH
BHE
BKHSGO
BPOP
BPOPE
BPOPF
BPOPT
BRE
BREZ
BRTE
BRTEZ
BUTLER
CARBON
CEH12
CHCKSE
CHEAV
CHEAVJ
CIA_H2H
CIA_H2H2
CIA_H2HE
CIA_HHE
CION
CKOEST
COLH
COLHE
COLLHE
CONCOR
CORRWM
CROSS
CROSSD
CSPEC
DIELRC
DIETOT
DIVSTR
DMEVAL
DOPGAM
DWNFR
DWNFR0
DWNFR1
EINT
EMAT
ENTENE
ERFCIN
ERFCX
EXPINT
EXPINX
EXPO
FFCROS
GAMI
GAMSP
GAULEG
GAUNT
GETWRD
GFREE0
GFREE1
GFREED
GNTK
GRCOR
GREYD
GRIDP
H2MINUS
HEPHOT
HIDALG
IJALI2
IJALIS
INDEXX
INIFRS
INILAM
INTERP
INTHYD
INTLEM
INTXEN
IRC
LAGRAN
LAGUER
LEMINI
LEVGRP
LEVSET
LEVSOL
LINEQS
LINSEL
LINSET
LINSPL
LOCATE
LUCY
LYMLIN
MATGEN
MATINV
MEANOP
MEANOPT
MINV3
NEWPOP
NSTOUT
ODF1
ODFFR
ODFHST
ODFHYD
ODFHYS
ODFMER
OPACFL
OPADD0
OPAHST
OPAINI
OPCTAB
OSCCOR
OUTPUT
PFCNO
PFFE
PFHEAV
PFNI
PFSPEC
PRCHAN
PRD
PRDINI
PRINC
PRNT
PROFSP
PSOLVE
PZERT
QUARTC
QUIT
RADPRE
RAPH
RATES1
RATMAL
RATMAT
RATSP1
RAYINI
RAYSET
RDATAX
READBF
RECHCK
REFLEV
REIMAN
RHOEOS
RHONEN
ROSSOP
ROSSTD
RTEDF2
RTEFE2
RTESOL
RTE_SC
SABOLF
SBFCH
SBFHE1
SBFHMI
SBFHMI_OLD
SBFOH
SFFHMI
SFFHMI_ADD
SGHE12
SGMER0
SGMER1
SGMERD
SIGAVE
SIGK
SIGMAR
SPSIGK
SRTFRQ
STARK0
STARKA
SWITCH
SZIRC
TDPINI
TIMING
TIOPF
TLUSTY
TRAINI
TRIDAG
UBETA
VERN16
VERN18
VERN20
VERN26
VERNER
VISINI
VOIGT
VOIGTE
WN
WNSTOR
XENINI
XK2DOP
YINT
YLINTP
ZMRHO
tlusty/extracted/_SUMMARY.txt
+319
View File
@@ -0,0 +1,319 @@
SYNSPEC54.F 提取摘要
============================================================
源文件: tlusty/tlusty208.f
总单元数: 304
总行数: 50011
名称 类型 文件 行数
------------------------------------------------------------
TLUSTY PROGRAM tlusty.f 61
_UNNAMED_BLOCK_DATA_ BLOCK DATA _unnamed_block_data_.f 40
START SUBROUTINE start.f 18
INITIA SUBROUTINE initia.f 879
RDATA SUBROUTINE rdata.f 628
NSTPAR SUBROUTINE nstpar.f 373
NSTOUT SUBROUTINE nstout.f 123
GETWRD SUBROUTINE getwrd.f 47
STATE SUBROUTINE state.f 809
INPMOD SUBROUTINE inpmod.f 170
KURUCZ SUBROUTINE kurucz.f 143
INCLDY SUBROUTINE incldy.f 74
CHANGE SUBROUTINE change.f 286
RESOLV SUBROUTINE resolv.f 227
INILAM SUBROUTINE inilam.f 341
OSCCOR SUBROUTINE osccor.f 64
ROSSTD SUBROUTINE rosstd.f 131
NEWPOP SUBROUTINE newpop.f 42
SWITCH SUBROUTINE switch.f 87
SABOLF SUBROUTINE sabolf.f 144
OPACF1 SUBROUTINE opacf1.f 382
LEVSOL SUBROUTINE levsol.f 54
STEQEQ SUBROUTINE steqeq.f 112
PZERT SUBROUTINE pzert.f 86
RATMAT SUBROUTINE ratmat.f 206
RATMAL SUBROUTINE ratmal.f 38
ELCOR SUBROUTINE elcor.f 93
REFLEV SUBROUTINE reflev.f 276
LEVGRP SUBROUTINE levgrp.f 82
RATES1 SUBROUTINE rates1.f 188
RATSP1 SUBROUTINE ratsp1.f 247
ALIST1 SUBROUTINE alist1.f 253
ALIST2 SUBROUTINE alist2.f 785
ALISK1 SUBROUTINE alisk1.f 162
ALISK2 SUBROUTINE alisk2.f 204
DOPGAM SUBROUTINE dopgam.f 120
GAMSP SUBROUTINE gamsp.f 14
PROFIL FUNCTION profil.f 74
VOIGT FUNCTION voigt.f 64
VOIGTE FUNCTION voigte.f 92
PROFSP FUNCTION profsp.f 86
UBETA FUNCTION ubeta.f 40
LAGRAN SUBROUTINE lagran.f 16
LINSET SUBROUTINE linset.f 272
LINSPL SUBROUTINE linspl.f 45
LINPRO SUBROUTINE linpro.f 215
SIGK FUNCTION sigk.f 195
VERNER FUNCTION verner.f 237
VERN26 FUNCTION vern26.f 94
VERN16 FUNCTION vern16.f 74
VERN18 FUNCTION vern18.f 77
VERN20 FUNCTION vern20.f 85
GAUNT FUNCTION gaunt.f 45
GNTK FUNCTION gntk.f 17
SPSIGK SUBROUTINE spsigk.f 33
HIDALG FUNCTION hidalg.f 79
REIMAN FUNCTION reiman.f 68
CARBON SUBROUTINE carbon.f 53
SGHE12 FUNCTION sghe12.f 18
SBFHE1 FUNCTION sbfhe1.f 157
HEPHOT FUNCTION hephot.f 163
CKOEST FUNCTION ckoest.f 59
TOPBAS FUNCTION topbas.f 51
OPDATA SUBROUTINE opdata.f 66
YLINTP FUNCTION ylintp.f 31
GFREE0 SUBROUTINE gfree0.f 62
GFREE1 FUNCTION gfree1.f 21
GFREED SUBROUTINE gfreed.f 26
FFCROS FUNCTION ffcros.f 13
SBFHMI_OLD FUNCTION sbfhmi_old.f 22
SBFHMI FUNCTION sbfhmi.f 42
SFFHMI FUNCTION sffhmi.f 73
COLIS SUBROUTINE colis.f 443
HCTRECOM FUNCTION hctrecom.f 36
HCTION FUNCTION hction.f 28
CTDATA BLOCK DATA ctdata.f 234
COLH SUBROUTINE colh.f 522
BUTLER SUBROUTINE butler.f 141
COLHE SUBROUTINE colhe.f 355
CEH12 FUNCTION ceh12.f 25
CSPEC SUBROUTINE cspec.f 89
COLLHE SUBROUTINE collhe.f 314
CHEAV FUNCTION cheav.f 148
CHEAVJ FUNCTION cheavj.f 111
MATINV SUBROUTINE matinv.f 90
MINV3 SUBROUTINE minv3.f 36
LINEQS SUBROUTINE lineqs.f 87
EXPINT FUNCTION expint.f 30
INTERP SUBROUTINE interp.f 94
OUTPUT SUBROUTINE output.f 117
OUTPRI SUBROUTINE outpri.f 257
SOLVE SUBROUTINE solve.f 314
SOLVES SUBROUTINE solves.f 341
MATGEN SUBROUTINE matgen.f 178
BRTE SUBROUTINE brte.f 618
BRTEZ SUBROUTINE brtez.f 574
BHE SUBROUTINE bhe.f 174
BHED SUBROUTINE bhed.f 342
BHEZ SUBROUTINE bhez.f 283
BRE SUBROUTINE bre.f 301
BREZ SUBROUTINE brez.f 273
BPOP SUBROUTINE bpop.f 79
BPOPE SUBROUTINE bpope.f 187
BPOPF SUBROUTINE bpopf.f 106
BPOPT SUBROUTINE bpopt.f 200
BPOPC SUBROUTINE bpopc.f 109
OPACFD SUBROUTINE opacfd.f 521
ALIFR1 SUBROUTINE alifr1.f 1134
ALIFR3 SUBROUTINE alifr3.f 1127
ALIFR6 SUBROUTINE alifr6.f 653
ALIFRK SUBROUTINE alifrk.f 51
EMAT SUBROUTINE emat.f 39
RHSGEN SUBROUTINE rhsgen.f 722
PRCHAN SUBROUTINE prchan.f 86
OPADD SUBROUTINE opadd.f 274
OPADD0 SUBROUTINE opadd0.f 110
PARTF SUBROUTINE partf.f 983
PFCNO SUBROUTINE pfcno.f 165
PFSPEC SUBROUTINE pfspec.f 44
PFFE SUBROUTINE pffe.f 306
PFNI SUBROUTINE pfni.f 326
OPFRAC SUBROUTINE opfrac.f 293
PFHEAV SUBROUTINE pfheav.f 365
XK2DOP FUNCTION xk2dop.f 32
LTEGR SUBROUTINE ltegr.f 294
ROSSOP SUBROUTINE rossop.f 97
CONTMP SUBROUTINE contmp.f 222
CONTMD SUBROUTINE contmd.f 144
ELDENS SUBROUTINE eldens.f 259
ENTENE SUBROUTINE entene.f 59
MEANOP SUBROUTINE meanop.f 43
MEANOPT SUBROUTINE meanopt.f 38
CONVEC SUBROUTINE convec.f 66
CONVC1 SUBROUTINE convc1.f 67
TRMDER SUBROUTINE trmder.f 79
CUBIC SUBROUTINE cubic.f 62
CONOUT SUBROUTINE conout.f 130
ERFCX FUNCTION erfcx.f 20
MATCON SUBROUTINE matcon.f 224
TEMCOR SUBROUTINE temcor.f 99
CONCOR SUBROUTINE concor.f 48
CONREF SUBROUTINE conref.f 328
PZEVAL SUBROUTINE pzeval.f 49
PZEVLD SUBROUTINE pzevld.f 176
LEMINI SUBROUTINE lemini.f 85
INTLEM SUBROUTINE intlem.f 33
INTHYD SUBROUTINE inthyd.f 90
YINT FUNCTION yint.f 18
STARK0 SUBROUTINE stark0.f 51
STARKA FUNCTION starka.f 55
DIVSTR SUBROUTINE divstr.f 41
OPAHST SUBROUTINE opahst.f 131
WNSTOR SUBROUTINE wnstor.f 64
WN FUNCTION wn.f 41
DWNFR SUBROUTINE dwnfr.f 44
ODF1 SUBROUTINE odf1.f 179
ODFHST SUBROUTINE odfhst.f 54
ODFFR SUBROUTINE odffr.f 97
CHCKSE SUBROUTINE chckse.f 86
ACCEL2 SUBROUTINE accel2.f 110
ACCELP SUBROUTINE accelp.f 103
TIMING SUBROUTINE timing.f 24
QUIT SUBROUTINE quit.f 10
ODFSET SUBROUTINE odfset.f 224
ODFHYS SUBROUTINE odfhys.f 136
ODFMER SUBROUTINE odfmer.f 22
ODFHYD SUBROUTINE odfhyd.f 96
INDEXX SUBROUTINE indexx.f 45
SIGAVE SUBROUTINE sigave.f 93
READBF SUBROUTINE readbf.f 29
CORRWM SUBROUTINE corrwm.f 125
IJALIS SUBROUTINE ijalis.f 78
IJALI2 SUBROUTINE ijali2.f 131
LEVSET SUBROUTINE levset.f 177
DWNFR0 SUBROUTINE dwnfr0.f 25
DWNFR1 SUBROUTINE dwnfr1.f 31
SGMER0 SUBROUTINE sgmer0.f 45
SGMER1 SUBROUTINE sgmer1.f 14
SGMERD SUBROUTINE sgmerd.f 15
TDPINI SUBROUTINE tdpini.f 38
OPAINI SUBROUTINE opaini.f 155
TRAINI SUBROUTINE traini.f 46
RTEDF1 SUBROUTINE rtedf1.f 405
RTEDF2 SUBROUTINE rtedf2.f 256
RTEFR1 SUBROUTINE rtefr1.f 752
RTEINT SUBROUTINE rteint.f 357
OPACF0 SUBROUTINE opacf0.f 358
SRTFRQ SUBROUTINE srtfrq.f 263
INIFRC SUBROUTINE inifrc.f 360
INIFRS SUBROUTINE inifrs.f 503
INIFRT SUBROUTINE inifrt.f 263
CROSS FUNCTION cross.f 18
CROSSD FUNCTION crossd.f 31
DIETOT SUBROUTINE dietot.f 28
RADPRE SUBROUTINE radpre.f 223
LINSEL SUBROUTINE linsel.f 343
PRINC SUBROUTINE princ.f 156
LUCY SUBROUTINE lucy.f 268
IROSET SUBROUTINE iroset.f 203
LEVCD SUBROUTINE levcd.f 249
INKUL SUBROUTINE inkul.f 168
OPACFL SUBROUTINE opacfl.f 280
RDATAX SUBROUTINE rdatax.f 120
BKHSGO SUBROUTINE bkhsgo.f 66
CION FUNCTION cion.f 93
DIELRC SUBROUTINE dielrc.f 379
EXPO FUNCTION expo.f 10
IRC SUBROUTINE irc.f 48
SZIRC SUBROUTINE szirc.f 41
EXPINX SUBROUTINE expinx.f 38
EINT SUBROUTINE eint.f 18
COMSET SUBROUTINE comset.f 164
ANGSET SUBROUTINE angset.f 44
GAULEG SUBROUTINE gauleg.f 34
RTE_SC SUBROUTINE rte_sc.f 53
RTESOL SUBROUTINE rtesol.f 87
RTEFE2 SUBROUTINE rtefe2.f 75
RTECF0 SUBROUTINE rtecf0.f 171
INICOM SUBROUTINE inicom.f 29
RTECOM SUBROUTINE rtecom.f 171
RTECF1 SUBROUTINE rtecf1.f 451
RTECMC SUBROUTINE rtecmc.f 178
COMPT0 SUBROUTINE compt0.f 107
TAUFR1 SUBROUTINE taufr1.f 90
RTECMU SUBROUTINE rtecmu.f 206
RTEANG SUBROUTINE rteang.f 64
PRD SUBROUTINE prd.f 144
PRDINI SUBROUTINE prdini.f 54
GAMI FUNCTION gami.f 45
INPDIS SUBROUTINE inpdis.f 189
COLUMN SUBROUTINE column.f 50
GRCOR SUBROUTINE grcor.f 123
DMDER SUBROUTINE dmder.f 39
SIGMAR FUNCTION sigmar.f 91
LAGUER SUBROUTINE laguer.f 58
LTEGRD SUBROUTINE ltegrd.f 513
TEMPER SUBROUTINE temper.f 164
TLOCAL SUBROUTINE tlocal.f 52
QUARTC SUBROUTINE quartc.f 35
NEWDM SUBROUTINE newdm.f 205
NEWDMT SUBROUTINE newdmt.f 115
GRIDP SUBROUTINE gridp.f 54
HESOLV SUBROUTINE hesolv.f 212
HESOL6 SUBROUTINE hesol6.f 378
PSOLVE SUBROUTINE psolve.f 45
ZMRHO SUBROUTINE zmrho.f 107
BETAH FUNCTION betah.f 33
ERFCIN FUNCTION erfcin.f 20
RADTOT SUBROUTINE radtot.f 105
COOLRT SUBROUTINE coolrt.f 103
OPACFA SUBROUTINE opacfa.f 323
VISINI SUBROUTINE visini.f 107
DMEVAL SUBROUTINE dmeval.f 69
GREYD SUBROUTINE greyd.f 66
RHONEN SUBROUTINE rhonen.f 42
QUASIM SUBROUTINE quasim.f 57
GETLAL SUBROUTINE getlal.f 107
ALLARD SUBROUTINE allard.f 217
ALLARDT SUBROUTINE allardt.f 158
HEDIF SUBROUTINE hedif.f 92
RAPH FUNCTION raph.f 17
TABINI SUBROUTINE tabini.f 326
RAYINI SUBROUTINE rayini.f 42
TABINT SUBROUTINE tabint.f 89
CHCTAB SUBROUTINE chctab.f 171
RAYSET SUBROUTINE rayset.f 68
RAYLEIGH SUBROUTINE rayleigh.f 46
OPCTAB SUBROUTINE opctab.f 116
OPACT1 SUBROUTINE opact1.f 39
OPACTD SUBROUTINE opactd.f 95
SETTRM SUBROUTINE settrm.f 84
RHOEOS FUNCTION rhoeos.f 38
SETDRT SUBROUTINE setdrt.f 18
TRMDRT SUBROUTINE trmdrt.f 65
PRSENT SUBROUTINE prsent.f 59
MOLEQ SUBROUTINE moleq.f 318
RUSSEL SUBROUTINE russel.f 217
MPARTF SUBROUTINE mpartf.f 138
TIOPF SUBROUTINE tiopf.f 148
RYBSOL SUBROUTINE rybsol.f 202
RYBMAT SUBROUTINE rybmat.f 390
RYBENE SUBROUTINE rybene.f 203
RYBCHN SUBROUTINE rybchn.f 161
TRIDAG SUBROUTINE tridag.f 22
OPACTR SUBROUTINE opactr.f 180
RYBHEQ SUBROUTINE rybheq.f 142
PGSET SUBROUTINE pgset.f 92
LOCATE SUBROUTINE locate.f 26
XENINI SUBROUTINE xenini.f 104
INTXEN SUBROUTINE intxen.f 51
GOMINI SUBROUTINE gomini.f 104
GHYDOP SUBROUTINE ghydop.f 56
SBFCH FUNCTION sbfch.f 278
SBFOH FUNCTION sbfoh.f 327
ELDENC SUBROUTINE eldenc.f 150
SFFHMI_ADD FUNCTION sffhmi_add.f 72
CIA_H2H2 SUBROUTINE cia_h2h2.f 89
CIA_H2HE SUBROUTINE cia_h2he.f 90
CIA_H2H SUBROUTINE cia_h2h.f 89
CIA_HHE SUBROUTINE cia_hhe.f 89
H2MINUS SUBROUTINE h2minus.f 100
PRNT SUBROUTINE prnt.f 73
RECHCK SUBROUTINE rechck.f 35
LYMLIN SUBROUTINE lymlin.f 115
按类型统计:
PROGRAM: 1
BLOCK DATA: 2
SUBROUTINE: 251
FUNCTION: 50
tlusty/extracted/_unnamed_block_data_.f
+40
View File
@@ -0,0 +1,40 @@
BLOCK DATA
C ==========
C
C Hydrogenic oscillator strentghs
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
C
DATA ((OSH(I,J),I=1,20),J=1,16)/20*0.,
* 0.4162,19*0.,7.910D-2,0.6407,18*0.,2.899D-2,0.1193,
* 0.8421,17*0.,1.394D-2,4.467D-2,0.1506,1.038,16*0.,7.799D-3,
* 2.209D-2,5.584D-2,0.1793,1.231,15*0.,4.814D-3,1.270D-2,2.768D-2,
* 6.549D-2,0.2069,1.424,14*0.,3.183D-3,8.036D-3,1.604D-2,3.23D-2,
* 7.448D-2,0.234,1.616,13*0.,2.216D-3,5.429D-3,1.023D-2,1.87D-2,
* 3.645D-2,8.315D-2,0.2609,1.807,12*0.,1.605D-3,3.851D-3,6.98D-3,
* 1.196D-2,2.104D-2,4.038D-2,9.163D-2,0.2876,1.999,11*0.,1.201D-3,
* 2.835D-3,4.996D-3,8.187D-3,1.344D-2,2.32D-2,4.416D-2,0.1,0.3143,
* 2.19,10*0.,9.214D-4,2.151D-3,3.711D-3,5.886D-3,9.209D-3,1.479D-2,
* 2.525D-2,4.787D-2,0.1083,0.3408,2.381,9*0.,7.227D-4,1.672D-3,
* 2.839D-3,4.393D-3,6.631D-3,1.012D-2,1.605D-2,2.724D-2,5.152D-2,
* 0.1166,0.3673,2.572,8*0.,5.744D-4,1.326D-3,2.224D-3,3.375D-3,
* 4.959D-3,7.289D-3,1.097D-2,1.726D-2,2.918D-2,5.513D-2,0.1248,
* 0.3938,2.763,7*0.,4.686D-4,1.07D-3,1.776D-3,2.656D-3,3.821D-3,
* 5.455D-3,7.891D-3,1.177D-2,1.843D-2,3.109D-2,5.872D-2,0.133,
* 0.4202,2.954,6*0.,3.856D-4,8.764D-4,1.443D-3,2.131D-3,3.014D-3,
* 4.207D-3,5.905D-3,8.456D-3,1.254D-2,1.958D-2,3.298D-2,6.228D-2,
* 0.1412,0.4467,3.145,5*0./
DATA ((OSH(I,J),I=1,20),J=17,20)/3.211D-4,
* 7.270D-4,1.188D-3,1.739D-3,
* 2.425D-3,3.324D-3,4.556D-3,6.323D-3,8.995D-3,.01328,.0207,.03486,
* .06584,.1494,0.4731,3.336,4*0.,2.702D-4,6.099D-4,9.916D-4,
* 1.439D-3,1.984D-3,2.679D-3,3.602D-3,4.877D-3,6.719D-3,9.515D-3,
* 0.01402,.02182,.03672,.06938,.1575,.4995,3.527,3*0.,2.296D-4,
* 5.167D-4,8.361D-4,1.204D-3,1.646D-3,2.196D-3,2.905D-3,3.856D-3,
* 5.180D-3,7.099D-3,.01002,.01474,.02292,.03858,.07292,.1657,.5259,
* 3.718,2*0.,1.967D-4,4.416D-4,7.118D-4,1.019D-3,1.382D-3,1.825D-3,
* 2.383D-3,3.112D-3,4.094D-3,5.468D-3,7.468D-3,.01052,.01545,
* .02402,.04043,.07644,0.1738,.5523,3.909,0./
END
tlusty/extracted/accel2.f
+110
View File
@@ -0,0 +1,110 @@
SUBROUTINE ACCEL2
C =================
C
C Acceleration of convergence (from Auer 1987, in Numerical
C Radiative Transfer p. 101)
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ITERAT.FOR'
INCLUDE 'MODELQ.FOR'
C
IF(NITER.LT.IACC .OR. ITER.LT.IACC0) RETURN
ipng=1
if(iacd.gt.0) ipng=mod((iter-iacc),iacd)
if(.not.lac2) then
IPT=MOD(ITER,3)
IPT0=MOD(IACC,3)
IPT1=MOD((IACC+1),3)
IPT2=MOD((IACC+2),3)
IF(ITER.EQ.IACC0) THEN
DO ID=1,ND
DO IX=1,NN
PSY3(IX,ID)=PSY0(IX,ID)
END DO
END DO
ELSE IF(IPT.EQ.IPT1) THEN
DO ID=1,ND
DO IX=1,NN
PSY2(IX,ID)=PSY0(IX,ID)
END DO
END DO
ELSE IF(IPT.EQ.IPT2) THEN
DO ID=1,ND
DO IX=1,NN
PSY1(IX,ID)=PSY0(IX,ID)
END DO
END DO
END IF
else if (ipng.ne.0) then
DO ID=1,ND
DO IX=1,NN
PSY3(IX,ID)=PSY2(IX,ID)
END DO
END DO
DO ID=1,ND
DO IX=1,NN
PSY2(IX,ID)=PSY1(IX,ID)
END DO
END DO
DO ID=1,ND
DO IX=1,NN
PSY1(IX,ID)=PSY0(IX,ID)
END DO
END DO
RETURN
end if
IF(ITER.LT.IACC) RETURN
C
A1=0.
B1=0.
B2=0.
C1=0.
C2=0.
DO IX=1,NN
IF(LSNG(IX)) THEN
DO ID=1,ND
WT=0.
IF(PSY0(IX,ID).NE.0.) WT=1./ABS(PSY0(IX,ID))
D0=PSY0(IX,ID)-PSY1(IX,ID)
D1=D0-PSY1(IX,ID)+PSY2(IX,ID)
D2=D0-PSY2(IX,ID)+PSY3(IX,ID)
A1=A1+WT*D1*D1
B1=B1+WT*D1*D2
B2=B2+WT*D2*D2
C1=C1+WT*D0*D1
C2=C2+WT*D0*D2
END DO
END IF
END DO
AB=B2*A1-B1*B1
IF(AB.EQ.0.) THEN
WRITE(6,601) ITER,AB
WRITE(10,601) ITER,AB
IACC=IACC+IACD
IACC0=IACC-3
RETURN
ENDIF
A=(B2*C1-B1*C2)/AB
B=(A1*C2-B1*C1)/AB
C
DO ID=1,ND
DO IX=1,NN
PSY0(IX,ID)=(1.-A-B)*PSY0(IX,ID)+A*PSY1(IX,ID)+
* B*PSY2(IX,ID)
END DO
END DO
WRITE(6,600) ITER
WRITE(10,600) ITER
LAC2=.TRUE.
LRES2=.FALSE.
c
c call RESOLV after evaluating the accelerated estimate
c
CALL RESOLV
LRES2=.TRUE.
RETURN
600 FORMAT(' **** ACCEL2, ITER=',I4)
601 FORMAT(' **** ACCEL2, ITER=',I4,' AB = ',F7.3)
END
tlusty/extracted/accelp.f
+103
View File
@@ -0,0 +1,103 @@
SUBROUTINE ACCELP
C =================
C
C Acceleration of convergence for populations
C (from Auer 1987, in Numerical Radiative Transfer p. 101)
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ITERAT.FOR'
COMMON/POPULS/POPUL1(MLEVEL,MDEPTH),
* POPUL2(MLEVEL,MDEPTH),POPUL3(MLEVEL,MDEPTH)
C
IF(NLAMBD.LT.IACPP.OR. ILAM.LT.IACC0P) RETURN
ipng=1
if(iacdp.gt.0) ipng=mod((ILAM-IACPP),IACDP)
if(.not.lac2p) then
IPT=MOD(ILAM,3)
IPT0=MOD(IACPP,3)
IPT1=MOD((IACPP+1),3)
IPT2=MOD((IACPP+2),3)
IF(ILAM.EQ.IACC0P) THEN
DO ID=1,ND
DO IX=1,NLEVEL
POPUL3(IX,ID)=POPUL(IX,ID)
END DO
END DO
ELSE IF(IPT.EQ.IPT1) THEN
DO ID=1,ND
DO IX=1,NLEVEL
POPUL2(IX,ID)=POPUL(IX,ID)
END DO
END DO
ELSE IF(IPT.EQ.IPT2) THEN
DO ID=1,ND
DO IX=1,NLEVEL
POPUL1(IX,ID)=POPUL(IX,ID)
END DO
END DO
END IF
else if (ipng.ne.0) then
DO ID=1,ND
DO IX=1,NLEVEL
POPUL3(IX,ID)=POPUL2(IX,ID)
END DO
END DO
DO ID=1,ND
DO IX=1,NLEVEL
POPUL2(IX,ID)=POPUL1(IX,ID)
END DO
END DO
DO ID=1,ND
DO IX=1,NLEVEL
POPUL1(IX,ID)=POPUL(IX,ID)
END DO
END DO
RETURN
end if
IF(ILAM.LT.IACPP) RETURN
C
A1=0.
B1=0.
B2=0.
C1=0.
C2=0.
DO ID=1,ND
DO IX=1,NLEVEL
IF(POPUL(IX,ID).NE.0.) WT=1./ABS(POPUL(IX,ID))
D0=POPUL(IX,ID)-POPUL1(IX,ID)
D1=D0-POPUL1(IX,ID)+POPUL2(IX,ID)
D2=D0-POPUL2(IX,ID)+POPUL3(IX,ID)
A1=A1+WT*D1*D1
B1=B1+WT*D1*D2
B2=B2+WT*D2*D2
C1=C1+WT*D0*D1
C2=C2+WT*D0*D2
END DO
END DO
AB=B2*A1-B1*B1
IF(AB.EQ.0.) THEN
WRITE(6,601) ILAM,AB
WRITE(10,601) ILAM,AB
IACPP=IACPP+IACDP
IACC0P=IACPP-3
RETURN
ENDIF
A=(B2*C1-B1*C2)/AB
B=(A1*C2-B1*C1)/AB
C
DO ID=1,ND
DO IX=1,NLEVEL
POPUL(IX,ID)=(1.-A-B)*POPUL(IX,ID)+A*POPUL1(IX,ID)+
* B*POPUL2(IX,ID)
END DO
END DO
WRITE(6,600) ILAM
WRITE(10,600) ILAM
LAC2P=.TRUE.
600 FORMAT(' **** ACCELP, ITER=',I4)
601 FORMAT(' **** ACCELP, ITER=',I4,' AB = ',F7.3)
RETURN
END
tlusty/extracted/alifr1.f
+1134
View File
File diff suppressed because it is too large Load Diff
tlusty/extracted/alifr3.f
+1127
View File
File diff suppressed because it is too large Load Diff
tlusty/extracted/alifr6.f
+653
View File
@@ -0,0 +1,653 @@
SUBROUTINE ALIFR6(IJ)
C =====================
C
C hydrostatic and radiative equilibrium quantities -
C derivatives of the total heating and cooling rates in the
C ALI points with respect to the
C temperature, electron density, and populations
C a variant for consistent tridiagonal operator
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
PARAMETER (T23=TWO/3.D0, T43=4.D0/3.D0)
DIMENSION DSFP1(MLVEXP),DSFP1M(MLVEXP),DSFP1D(MLVEXP),
* DSFP1P(MLVEXP),DSFPMM(MLVEXP)
C
WW=WC(IJ)
C
DSFT1M=0.
DSFN1M=0.
DO II=1,NLVEXP
DSFP1M(II)=0.
END DO
c
c ****1. Special expressions for the first depth - id=1
c
ID=1
LNSKIP=.NOT.LSKIP(ID,IJ)
c
c Basic auxliliary quantities - derivatives of the source function
c
EMISIV=UN/EMIS1(ID)
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABST=UN/(ABSO1(ID)-ELSCAT(ID))
S0=EMIS1(ID)*ABST
DSFN1=S0*(DEMN1(ID)*EMISIV-(DABN1(ID)-SIGEC(IJ))*ABST)
else
ABST=UN/ABSO1(ID)
S0=EMIS1(ID)*ABST
DSFN1=S0*(DEMN1(ID)*EMISIV-DABN1(ID)*ABST)
end if
DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST)
DO II=1,NLVEXP
DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST)
END DO
C
c correction for electron scattering source function contribution
c
else
abst=un/abso1(id)
s0=emis1(id)*abst
sc=elec(id)*sigeC(IJ)
sct=sc*abst
st=s0+sct*rad1(id)
corr=un/(un-ali1(id)*sct)
dsft1=corr*(s0*demt1(id)*emisiv-st*dabt1(id)*abst)
dsfn1=corr*(s0*demn1(id)*emisiv+sigeC(IJ)*rad1(id)*abst-
* st*dabn1(id)*abst)
do ii=1,nlvexp
dsfp1(ii)=corr*(s0*demp1(ii,id)*emisiv-
* st*dabp1(ii,id)*abst)
end do
end if
EMISIP=UN/EMIS1(ID+1)
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1))
S0P=EMIS1(ID+1)*ABSTP
DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP)
else
ABSTP=UN/ABSO1(ID+1)
S0P=EMIS1(ID+1)*ABSTP
DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP)
end if
DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP)
DO II=1,NLVEXP
DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP)
END DO
else
abstp=un/abso1(id+1)
s0p=emis1(id+1)*abstp
scp=elec(id+1)*sigeC(IJ)
sctp=scp*abstp
stp=s0p+sctp*rad1(id+1)
corrp=un/(un-ali1(id+1)*sctp)
dsft1p=corrp*(s0p*demt1(id+1)*emisip-stp*dabt1(id+1)*abstp)
dsfn1p=corrp*(s0p*demn1(id+1)*emisip+sigeC(IJ)*rad1(id+1)*abstp-
* stp*dabn1(id+1)*abstp)
do ii=1,nlvexp
dsfp1p(ii)=corrp*(s0p*demp1(ii,id+1)*emisip-
* stp*dabp1(ii,id+1)*abstp)
end do
end if
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDT(ID)=DSFT1*ALI1(ID)
DSFDN(ID)=DSFN1*ALI1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDP(II,ID)=DSFP1(II)*ALI1(ID)
END DO
END IF
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDTM(ID)=DSFT1M*ALIM1(ID)
DSFDNM(ID)=DSFN1M*ALIM1(ID)
DSFDTP(ID)=DSFT1P*ALIP1(ID)
DSFDNP(ID)=DSFN1P*ALIP1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID)
DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID)
END DO
END IF
c
c Hydrostatic equilibrium quantities
c
WF=WW*FH(IJ)
IF(LNSKIP) THEN
FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)-
* WW*HEXTRD(IJ)*ABSO1(ID)
E0=WF*RAD1(ID)
D0=WF*ABSO1(ID)*ALI1(ID)
HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID)
HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID)
DO II=1,NLVEXP
HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID)
END DO
IF(IFALI.GE.7) THEN
D0P=WF*ABSO1(ID)*ALIP1(ID)
HEITP(ID)=HEITP(ID)+D0P*DSFT1P
HEINP(ID)=HEINP(ID)+D0P*DSFN1P
DO II=1,NLVEXP
HEIPP(II,ID)=HEIPP(II,ID)+D0P*DSFP1P(II)
END DO
END IF
END IF
c
c Differential equation part of radiative equilibrium
c
FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ)
IF(REDIF(ID).GT.0.) THEN
WF=WF*ALI1(ID)
REDT(ID)=REDT(ID)+WF*DSFT1
REDN(ID)=REDN(ID)+WF*DSFN1
DO II=1,NLVEXP
REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II)
END DO
END IF
c
C Integral equation part of the radiative equilibrium
C
IF(REINT(ID).GT.0) THEN
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABST=ABSO1(ID)-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID))
D0=WW*(ALI1(ID)-UN)*ABST
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ))
else
SRH=SIGE*DENS1(ID)
ABST=ABSO1(ID)
ABSTE=ABST-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID))
D0=WW*(ABSTE*ALI1(ID)-ABST)
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID)
end if
REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID)
DO II=1,NLVEXP
REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID)
END DO
else
abst=abso1(id)-elscat(id)
d0=abst*ali1(id)
fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id))
rein(id)=rein(id)+ww*(d0*dsfn1+
* rad1(id)*(dabn1(id)-sigeC(IJ))-demn1(id))
do ii=1,nlvexp
reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+
* rad1(id)*dabp1(ii,id)-demp1(ii,id))
end do
reit(id)=reit(id)+ww*(d0*dsft1+
* rad1(id)*dabt1(id)-demt1(id))
end if
c
c the following are needed only for tridiagonal Lambda^star
C
C Upper sub-diagonal band
C
WWKC=WWK*ALIP1(ID)
CREIT(ID)=CREIT(ID)+WWKC*DSFT1P
CREIN(ID)=CREIN(ID)+WWKC*DSFN1P
DO II=1,NLVEXP
CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II)
END DO
END IF
C
c ****2. loop over depths
c
DO ID=2,ND-1
LNSKIP=.NOT.LSKIP(ID,IJ)
DSFTMM=DSFT1M
DSFNMM=DSFN1M
DO II=1,NLVEXP
DSFPMM(II)=DSFP1M(II)
END DO
DSFT1M=DSFT1
DSFN1M=DSFN1
DO II=1,NLVEXP
DSFP1M(II)=DSFP1(II)
END DO
S0=S0P
DSFT1=DSFT1P
DSFN1=DSFN1P
DO II=1,NLVEXP
DSFP1(II)=DSFP1P(II)
END DO
EMISIP=UN/EMIS1(ID+1)
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1))
S0P=EMIS1(ID+1)*ABSTP
DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP)
else
ABSTP=UN/ABSO1(ID+1)
S0P=EMIS1(ID+1)*ABSTP
DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP)
end if
DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP)
DO II=1,NLVEXP
DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP)
END DO
else
abstp=un/abso1(id+1)
s0p=emis1(id+1)*abstp
scp=elec(id+1)*sigeC(IJ)
sctp=scp*abstp
stp=s0p+sctp*rad1(id+1)
corrp=un/(un-ali1(id+1)*sctp)
dsft1p=corrp*(s0p*demt1(id+1)*emisip-stp*dabt1(id+1)*abstp)
dsfn1p=corrp*(s0p*demn1(id+1)*emisip+sigeC(IJ)*rad1(id+1)*abstp-
* stp*dabn1(id+1)*abstp)
do ii=1,nlvexp
dsfp1p(ii)=corrp*(s0p*demp1(ii,id+1)*emisip-
* stp*dabp1(ii,id+1)*abstp)
end do
end if
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDT(ID)=DSFT1*ALI1(ID)
DSFDN(ID)=DSFN1*ALI1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDP(II,ID)=DSFP1(II)*ALI1(ID)
END DO
END IF
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDTM(ID)=DSFT1M*ALIM1(ID)
DSFDNM(ID)=DSFN1M*ALIM1(ID)
DSFDTP(ID)=DSFT1P*ALIP1(ID)
DSFDNP(ID)=DSFN1P*ALIP1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID)
DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID)
END DO
END IF
c
c Hydrostatic equilibrium equation
c
IF(LNSKIP) THEN
D0=WW*FAK1(ID)
A0=WW*FAK1(ID-1)
FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1)
F0=D0*ALIP1(ID)
E0=D0*ALIM1(ID)-A0*ALI1(ID-1)
D0=D0*ALI1(ID)-A0*ALIP1(ID-1)
HEIT(ID)=HEIT(ID)+D0*DSFT1
HEIN(ID)=HEIN(ID)+D0*DSFN1
HEITM(ID)=HEITM(ID)+E0*DSFT1M
HEINM(ID)=HEINM(ID)+E0*DSFN1M
DO II=1,NLVEXP
HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)
HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II)
END DO
IF(IFALI.GE.7) THEN
HEITP(ID)=HEITP(ID)+F0*DSFT1P
HEINP(ID)=HEINP(ID)+F0*DSFN1P
DO II=1,NLVEXP
HEIPP(II,ID)=HEIPP(II,ID)+F0*DSFP1P(II)
END DO
A0M=A0*ALIM1(ID-1)
EHET(ID)=EHET(ID)-A0M*DSFTMM
EHEN(ID)=EHEN(ID)-A0M*DSFNMM
DO II=1,NLVEXP
EHEP(II,ID)=EHEP(II,ID)-A0M*DSFPMM(II)
END DO
END IF
END IF
C
C Differential equation part of radiative equilibrium
C
DDT=UN/(ABSOT(ID)+ABSOT(ID-1))
DT=DDT/DELDMZ(ID-1)
FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT
FLFIX(ID)=FLFIX(ID)+WW*FL
IF(REDIF(ID).GT.0) THEN
D0=WW*FAK1(ID)*DT
A0=WW*FAK1(ID-1)*DT
D0M=D0*ALIM1(ID)-A0*ALI1(ID-1)
D0P=D0*ALIP1(ID)
D0=D0*ALI1(ID)-A0*ALIP1(ID-1)
E0=WW*FL*DDT
REDX(ID)=REDX(ID)+E0*ABSO1(ID)
REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1)
E0M=E0*DENSI(ID-1)
E0=E0*DENSI(ID)
REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID)
REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1)
REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID)
REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1)
DO II=1,NLVEXP
REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID)
REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)-
* E0M*DABP1(II,ID-1)
END DO
IF(IFALI.GE.7) THEN
REDTP(ID)=REDTP(ID)+D0P*DSFT1M
REDNP(ID)=REDNP(ID)+D0P*DSFN1M
DO II=1,NLVEXP
REDPP(II,ID)=REDPP(II,ID)+D0P*DSFP1P(II)
END DO
A0M=A0*ALIM1(ID-1)
ERET(ID)=ERET(ID)-A0M*DSFTMM
EREN(ID)=EREN(ID)-A0M*DSFNMM
DO II=1,NLVEXP
EREP(II,ID)=EREP(II,ID)-A0M*DSFPMM(II)
END DO
END IF
END IF
c
C Integral equation part of the radiative equilibrium
C
IF(REINT(ID).GT.0) THEN
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABST=ABSO1(ID)-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID))
D0=WW*(ALI1(ID)-UN)*ABST
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ))
else
SRH=SIGE*DENS1(ID)
ABST=ABSO1(ID)
ABSTE=ABST-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID))
D0=WW*(ABSTE*ALI1(ID)-ABST)
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-
* WW*SIGE*RAD1(ID)
end if
REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID)
DO II=1,NLVEXP
REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID)
END DO
else
abst=abso1(id)-elscat(id)
d0=abst*ali1(id)
fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id))
rein(id)=rein(id)+ww*(d0*dsfn1+
* rad1(id)*(dabn1(id)-sige)-demn1(id))
do ii=1,nlvexp
reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+
* rad1(id)*dabp1(ii,id)-demp1(ii,id))
end do
reit(id)=reit(id)+ww*(d0*dsft1+
* rad1(id)*dabt1(id)-demt1(id))
end if
c
c the following are needed only for tridiagonal Lambda^star
C
C Lower sub-diagonal band
C
WWKA=WWK*ALIM1(ID)
AREIT(ID)=AREIT(ID)+WWKA*DSFT1M
AREIN(ID)=AREIN(ID)+WWKA*DSFN1M
DO II=1,NLVEXP
AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II)
END DO
C
C Upper sub-diagonal band
C
WWKC=WWK*ALIP1(ID)
CREIT(ID)=CREIT(ID)+WWKC*DSFT1P
CREIN(ID)=CREIN(ID)+WWKC*DSFN1P
DO II=1,NLVEXP
CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II)
END DO
END IF
END DO
C
c ****3. deepest point - ID=ND
c
ID=ND
LNSKIP=.NOT.LSKIP(ID,IJ)
DSFTMM=DSFT1M
DSFNMM=DSFN1M
DO II=1,NLVEXP
DSFPMM(II)=DSFP1M(II)
END DO
DSFT1M=DSFT1
DSFN1M=DSFN1
DO II=1,NLVEXP
DSFP1M(II)=DSFP1(II)
END DO
S0=S0P
DSFT1=DSFT1P
DSFN1=DSFN1P
DO II=1,NLVEXP
DSFP1(II)=DSFP1P(II)
END DO
C
C Improved lower boundary condition
C
IF(IBC.GT.0.AND.IDISK.EQ.0) THEN
DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1)))
PLAD=XKFB(ID)/XKF1(ID)
DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT
IF(IBC.EQ.1) THEN
DSFT1=DSFT1+DBDT
ELSE IF(IBC.GE.2) THEN
PLAM=XKFB(ID-1)/XKF1(ID-1)
TAU23=T23*DT
TAU43=T43*DT
D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT
RHD=DELDMZ(ID-1)*DENSI(ID)
E0=D0*RHD
DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID)
DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID))
DO II=1,NLVEXP
DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID)
END DO
IF(IBC.GE.3) THEN
DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT
RHD=DELDMZ(ID-1)*DENSI(ID-1)
E0=D0*RHD
DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1)
DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1))
DO II=1,NLVEXP
DSFP1D(II)=-E0*DABP1(II,ID-1)
END DO
END IF
END IF
END IF
C
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDT(ID)=DSFT1*ALI1(ID)
DSFDN(ID)=DSFN1*ALI1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDP(II,ID)=DSFP1(II)*ALI1(ID)
END DO
END IF
IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN
DSFDTM(ID)=DSFT1M*ALIM1(ID)
DSFDNM(ID)=DSFN1M*ALIM1(ID)
DSFDTP(ID)=DSFT1P*ALIP1(ID)
DSFDNP(ID)=DSFN1P*ALIP1(ID)
END IF
IF(IRDER.GT.1) THEN
DO II=1,NLVEXP
DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID)
DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID)
END DO
END IF
c
c Hydrostatic equilibrium equation
c
IF(LNSKIP) THEN
D0=WW*FAK1(ID)
A0=WW*FAK1(ID-1)
FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1)
F0=D0*ALIP1(ID)
E0=D0*ALIM1(ID)-A0*ALI1(ID-1)
D0=D0*ALI1(ID)-A0*ALIP1(ID-1)
HEIT(ID)=HEIT(ID)+D0*DSFT1
HEIN(ID)=HEIN(ID)+D0*DSFN1
HEITM(ID)=HEITM(ID)+E0*DSFT1M
HEINM(ID)=HEINM(ID)+E0*DSFN1M
DO II=1,NLVEXP
HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)
HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II)
END DO
IF(IFALI.GE.7) THEN
HEITP(ID)=HEITP(ID)+F0*DSFT1P
HEINP(ID)=HEINP(ID)+F0*DSFN1P
DO II=1,NLVEXP
HEIPP(II,ID)=HEIPP(II,ID)+F0*DSFP1P(II)
END DO
A0M=A0*ALIM1(ID-1)
EHET(ID)=EHET(ID)-A0M*DSFTMM
EHEN(ID)=EHEN(ID)-A0M*DSFNMM
DO II=1,NLVEXP
EHEP(II,ID)=EHEP(II,ID)-A0M*DSFPMM(II)
END DO
END IF
IF(IBC.GE.3) THEN
HEITM(ID)=HEITM(ID)-D0*DSFT1D
HEINM(ID)=HEINM(ID)-D0*DSFN1D
DO II=1,NLVEXP
HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II)
END DO
END IF
END IF
C
C Differential equation part of radiative equilibrium
C
DDT=UN/(ABSOT(ID)+ABSOT(ID-1))
DT=DDT/DELDMZ(ID-1)
FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT
FLFIX(ID)=FLFIX(ID)+WW*FL
IF(REDIF(ID).GT.0) THEN
D0=WW*FAK1(ID)*DT
A0=WW*FAK1(ID-1)*DT
D0M=D0*ALIM1(ID)-A0*ALI1(ID-1)
D0P=D0*ALIP1(ID)
D0=D0*ALI1(ID)-A0*ALIP1(ID-1)
E0=WW*FL*DDT
REDX(ID)=REDX(ID)+E0*ABSO1(ID)
REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1)
E0M=E0*DENSI(ID-1)
E0=E0*DENSI(ID)
REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID)
REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1)
REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID)
REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1)
DO II=1,NLVEXP
REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID)
REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)-
* E0M*DABP1(II,ID-1)
END DO
IF(IFALI.GE.7) THEN
REDTP(ID)=REDTP(ID)+D0P*DSFT1M
REDNP(ID)=REDNP(ID)+D0P*DSFN1M
DO II=1,NLVEXP
REDPP(II,ID)=REDPP(II,ID)+D0P*DSFP1P(II)
END DO
A0M=A0*ALIM1(ID-1)
ERET(ID)=ERET(ID)-A0M*DSFTMM
EREN(ID)=EREN(ID)-A0M*DSFNMM
DO II=1,NLVEXP
EREP(II,ID)=EREP(II,ID)-A0M*DSFPMM(II)
END DO
END IF
IF(IBC.GE.3) THEN
REDTM(ID)=REDTM(ID)+D0*DSFT1D
REDNM(ID)=REDNM(ID)+D0*DSFN1D
DO II=1,NLVEXP
REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II)
END DO
END IF
END IF
c
C Integral equation part of the radiative equilibrium
C
IF(REINT(ID).GT.0) THEN
if(ilmcor.ne.3) then
if(ilasct.eq.0) then
ABST=ABSO1(ID)-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID))
D0=WW*(ALI1(ID)-UN)*ABST
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ))
else
SRH=SIGE*DENS1(ID)
ABST=ABSO1(ID)
ABSTE=ABST-ELSCAT(ID)
WWK=WW*ABST
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID))
D0=WW*(ABSTE*ALI1(ID)-ABST)
E0=WW*(RAD1(ID)-S0)
REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID)
end if
IF(IBC.EQ.0) THEN
REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID)
ELSE
REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+
* ALI1(ID)/ABST*DBDT
END IF
DO II=1,NLVEXP
REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID)
END DO
else
abst=abso1(id)-elscat(id)
d0=abst*ali1(id)
fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id))
rein(id)=rein(id)+ww*(d0*dsfn1+
* rad1(id)*(dabn1(id)-sigeC(IJ))-demn1(id))
do ii=1,nlvexp
reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+
* rad1(id)*dabp1(ii,id)-demp1(ii,id))
end do
if(ibc.eq.0) then
reit(id)=reit(id)+ww*(d0*dsft1+
* rad1(id)*dabt1(id)-demt1(id))
else
reit(id)=reit(id)+ww*(d0*(dsft1-dbdt)+e0*dabt1(id)+
* rad1(id)*dabt1(id)-demt1(id)+
* ali1(id)/abst*dbdt)
end if
end if
c
c the following are needed only for tridiagonal Lambda^star
C
C Lower sub-diagonal band
C
WWKA=WWK*ALIM1(ID)
AREIT(ID)=AREIT(ID)+WWKA*DSFT1M
AREIN(ID)=AREIN(ID)+WWKA*DSFN1M
DO II=1,NLVEXP
AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II)
END DO
END IF
RETURN
END
tlusty/extracted/alifrk.f
+51
View File
@@ -0,0 +1,51 @@
SUBROUTINE ALIFRK(IJ)
C =====================
C
C Simplified routine ALIFR1 for a Kantorovich iteration
C
C hydrostatic and radiative equilibrium quantities -
C derivatives of the total heating and cooling rates in the
C ALI points with respect to the
C temperature, electron density, and populations
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
DIMENSION WFL(MDEPTH)
C
if(ifali.le.1) return
WW=WC(IJ)
c **** Special expressions for the first depth - id=1
ID=1
LNSKIP=.NOT.LSKIP(ID,IJ)
WF=WW*(FH(IJ)*RAD1(ID)-HEXTRD(IJ))
IF(LNSKIP) FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)
FLFIX(ID)=FLFIX(ID)+WF
FLRD(ID)=FLRD(ID)+W(IJ)*(FH(IJ)*RAD1(ID)-HALF*EXTRAD(IJ))
IF(REINT(ID).GT.0) THEN
ABST=ABSO1(ID)-SCAT1(ID)
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID))
END IF
c Loop over depths
DO ID=2,ND
LNSKIP=.NOT.LSKIP(ID,IJ)
DT=UN/((ABSOT(ID)+ABSOT(ID-1))*DELDMZ(ID-1))
FL=RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1)
WFL(ID)=WW*FL
IF(LNSKIP) FPRD(ID)=FPRD(ID)+WFL(ID)
FLFIX(ID)=FLFIX(ID)+WFL(ID)*DT
FLRD(ID)=FLRD(ID)+FL*W(IJ)*DT
IF(REINT(ID).GT.0) THEN
ABST=ABSO1(ID)-SCAT1(ID)
FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID))
END IF
END DO
RETURN
END
tlusty/extracted/alisk1.f
+162
View File
@@ -0,0 +1,162 @@
SUBROUTINE ALISK1
C =================
C
C Simplified routine ALIST1 for Kantorovich iteration
C
C Evaluation of all nexcessary ALI parameters + radiative rates
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ITERAT.FOR'
DIMENSION RBNU(MDEPTH)
C DIMENSION EHKL(MFREQL)
C
C zero the rates and other quantities (subr. NULL)
C
DO ID=1,ND
FCOOLI(ID)=0.
FLFIX(ID)=0.
FPRD(ID)=0.
FLRD(ID)=0.
PRADT(ID)=0.
PRADA(ID)=0.
DO ITR=1,NTRANS
RRU(ITR,ID)=0.
RRD(ITR,ID)=0.
END DO
END DO
PRD0=0.
C
LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN
IF(HMIX0.GT.0.) LROSS=.TRUE.
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=0.
SUMDPL(ID)=0.
END DO
END IF
C
DO 100 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 100
FR=FREQ(IJ)
W0=W0E(IJ)
CALL OPACF1(IJ)
IF(IJEX(IJ).GT.0) THEN
IJE=IJEX(IJ)
DO ID=1,ND
ABSOEX(IJE,ID)=ABSO1(ID)
EMISEX(IJE,ID)=EMIS1(ID)
SCATEX(IJE,ID)=SCAT1(ID)
END DO
END IF
CALL RTEFR1(IJ)
CALL ALIFRK(IJ)
IF(LROSS) CALL ROSSTD(IJ)
if(ioptab.lt.0) go to 100
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO ID=1,ND
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR)
DO 10 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 10
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10
JC=ITRA(JJ,II)
ICDW=MCDW(ITR)
IMER=IMRG(II)
IF(IFWOP(II).GE.0) THEN
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
10 CONTINUE
END DO
C
C ----------------
C Line transitions
C ----------------
C
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
DO ID=1,ND
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
END DO
END IF
IF(NLINES(IJ).LE.0) GO TO 100
C
C the "overlapping" lines at the given frequency
C
DO 90 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) goto 90
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 70
END IF
END DO
70 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
DO ID=1,ND
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
END DO
90 CONTINUE
100 CONTINUE
C
C multiply some quantities by frequency-independent constants
C
DO ID=1,ND
FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID)
IF(CRSW(ID).NE.UN) THEN
DO ITR=1,NTRANS
RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID)
RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID)
END DO
END IF
END DO
C
C radiation pressure
C
PRDX=1.
DO ID=1,ND
PRADT(ID)=PRADT(ID)*PCK
PRADA(ID)=PRADA(ID)*PCK
if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID)
IF(PRDR.LT.PRDX) PRDX=PRDR
END DO
PRD0=PRD0/DENS1(1)*DM(1)*PCK
IF(LFIN) WRITE(10,1100) PRDX,ITER
1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4)
C
C Rosseland mean opacity
C
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
END DO
END IF
RETURN
END
tlusty/extracted/alisk2.f
+204
View File
@@ -0,0 +1,204 @@
SUBROUTINE ALISK2
C =================
C
C Simplified routine ALISET for Kantorovich iteration
C
C Evaluation of all nexcessary ALI parameters + radiative rates
C (the routine is analogous to RATES)
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ITERAT.FOR'
DIMENSION RBNU(MDEPTH)
C DIMENSION EHKL(MFREQL)
C
C zero the rates and other quantities
C
DO ID=1,ND
FCOOLI(ID)=0.
FLFIX(ID)=0.
FLEXP(ID)=0.
FPRD(ID)=0.
FLRD(ID)=0.
PRADT(ID)=0.
PRADA(ID)=0.
DO ITR=1,NTRANS
RRU(ITR,ID)=0.
RRD(ITR,ID)=0.
END DO
END DO
PRD0=0.
C
LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN
IF(HMIX0.GT.0.) LROSS=.TRUE.
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=0.
SUMDPL(ID)=0.
END DO
END IF
C
DO 100 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 100
FR=FREQ(IJ)
W0=W0E(IJ)
CALL OPACF1(IJ)
CALL RTEFR1(IJ)
CALL ALIFRK(IJ)
IF(LROSS) CALL ROSSTD(IJ)
if(ioptab.lt.0) go to 100
IF(IJEX(IJ).GT.0) THEN
IJE=IJEX(IJ)
DO ID=1,ND
ABSOEX(IJE,ID)=ABSO1(ID)
EMISEX(IJE,ID)=EMIS1(ID)
SCATEX(IJE,ID)=SCAT1(ID)
END DO
END IF
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO ID=1,ND
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR)
DO 10 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 10
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10
JC=ITRA(JJ,II)
IF(IFWOP(II).GE.0) THEN
ICDW=MCDW(ITR)
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
IMER=IMRG(II)
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
10 CONTINUE
END DO
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
DO 50 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
50 CONTINUE
END IF
IF(NLINES(IJ).LE.0) GO TO 100
C
C the "overlapping" lines at the given frequency
C
DO 90 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) go to 90
II=ILOW(ITR)
JJ=IUP(ITR)
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 70
END IF
END DO
70 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
DO 80 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
80 CONTINUE
90 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 100
DO 190 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
II=ILOW(ITR)
JJ=IUP(ITR)
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO 150 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150
SGW0=PRFLIN(ID,KJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
150 CONTINUE
ELSE
DO 160 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.
* IPZERO(JJ,ID).NE.0) GO TO 160
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))*
* SIGFE(KJD+1,KJ))
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
160 CONTINUE
END IF
190 CONTINUE
END IF
100 CONTINUE
C
C multiply some quantities by frequency-independent constants
C
DO ID=1,ND
FCO OL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID)
IF(CRSW(ID).NE.UN) THEN
DO ITR=1,NTRANS
RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID)
RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID)
END DO
END IF
END DO
C
C radiation pressure
C
PRDX=1.
DO ID=1,ND
PRADT(ID)=PRADT(ID)*PCK
PRADA(ID)=PRADA(ID)*PCK
if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID)
IF(PRDR.LT.PRDX) PRDX=PRDR
END DO
PRD0=PRD0/DENS1(1)*DM(1)*PCK
IF(LFIN) WRITE(10,1100) PRDX,ITER
1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4)
C
C Rosseland mean opacity
C
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
END DO
END IF
RETURN
END
tlusty/extracted/alist1.f
+253
View File
@@ -0,0 +1,253 @@
SUBROUTINE ALIST1
C =================
C
C Evaluation of all nexcessary ALI parameters + radiative rates
C (the routine is analogous to RATES1)
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ITERAT.FOR'
DIMENSION EXX(MDEPTH),RBNU(MDEPTH),RBNUF(MDEPTH)
C DIMENSION EHKL(MFREQL),EHKLF(MFREQL)
C
C zero the rates and other quantities
C
DO ID=1,ND
REIT(ID)=0.
REIN(ID)=0.
REIX(ID)=0.
AREIT(ID)=0.
AREIN(ID)=0.
CREIT(ID)=0.
CREIN(ID)=0.
CREIX(ID)=0.
REDT(ID)=0.
REDTM(ID)=0.
REDTP(ID)=0.
REDN(ID)=0.
REDNM(ID)=0.
REDNP(ID)=0.
REDX(ID)=0.
REDXM(ID)=0.
REDXP(ID)=0.
HEIT(ID)=0.
HEITM(ID)=0.
HEITP(ID)=0.
HEIN(ID)=0.
HEINM(ID)=0.
HEINP(ID)=0.
EHET(ID)=0.
EHEN(ID)=0.
ERET(ID)=0.
EREN(ID)=0.
FCOOLI(ID)=0.
FLFIX(ID)=0.
FLEXP(ID)=0.
FLRD(ID)=0.
FPRD(ID)=0.
PRADT(ID)=0.
PRADA(ID)=0.
DO II=1,NLVEXP
HEIP(II,ID)=0.
REIP(II,ID)=0.
AREIP(II,ID)=0.
CREIP(II,ID)=0.
REDP(II,ID)=0.
REDPM(II,ID)=0.
HEIPM(II,ID)=0.
REDPP(II,ID)=0.
HEIPP(II,ID)=0.
EHEP(II,ID)=0.
EREP(II,ID)=0.
END DO
DO ITR=1,NTRANS
RRU(ITR,ID)=0.
RRD(ITR,ID)=0.
DRDT(ITR,ID)=0.
END DO
END DO
PRD0=0.
C
LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN
IF(HMIX0.GT.0.) LROSS=.TRUE.
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=0.
SUMDPL(ID)=0.
END DO
END IF
C
DO 100 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 100
FR=FREQ(IJ)
W0=W0E(IJ)
CALL OPACFD(IJ)
CALL RTEFR1(IJ)
CALL ALIFR1(IJ)
IF(LROSS) CALL ROSSTD(IJ)
if(ioptab.lt.0) go to 100
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO ID=1,ND
EXX(ID)=EXP(-HKT1(ID)*FR)
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
DO 10 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 10
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10
JC=ITRA(JJ,II)
IF(IFWOP(II).GE.0) THEN
ICDW=MCDW(ITR)
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
IMER=IMRG(II)
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
10 CONTINUE
END DO
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
DO 50 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
50 CONTINUE
ENDIF
IF(NLINES(IJ).LE.0) GO TO 100
C
C the "overlapping" lines at the given frequency
C
DO 90 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) goto 90
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 70
END IF
END DO
70 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
II=ILOW(ITR)
JJ=IUP(ITR)
DO 80 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
80 CONTINUE
90 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 100
DO 95 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO 210 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 210
SGW0=PRFLIN(ID,KJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
210 CONTINUE
ELSE
DO 220 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 220
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
220 CONTINUE
END IF
95 CONTINUE
END IF
100 CONTINUE
C
C multiply some quantities by frequency-independent constants
C
DO ID=1,ND
REDX(ID)=REDX(ID)*WMM(ID)*DENS1(ID)*DENS1(ID)
IF(ID.GT.1) REDXM(ID)=REDXM(ID)*WMM(ID)*
* DENS1(ID-1)*DENS1(ID-1)
FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID)
IF(CRSW(ID).NE.UN) THEN
DO ITR=1,NTRANS
RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID)
RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)*CRSW(ID)
END DO
END IF
END DO
C
C radiation pressure
C
PRDX=1.
DO ID=1,ND
PRADT(ID)=PRADT(ID)*PCK
PRADA(ID)=PRADA(ID)*PCK
if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID)
IF(PRDR.LT.PRDX) PRDX=PRDR
END DO
PRD0=PRD0/DENS1(1)*DM(1)*PCK
IF(LFIN) WRITE(10,1100) PRDX,ITER
1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4)
C
C Rosseland mean opacity
C
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
END DO
if(ioptab.lt.0.and.ifryb.gt.0) then
do id=1,nd
abrosd(id)=abrosd(id)*dens(id)
end do
end if
call rosstd(0)
END IF
c
RETURN
END
tlusty/extracted/alist2.f
+785
View File
@@ -0,0 +1,785 @@
SUBROUTINE ALIST2
C =================
C
C Evaluation of all nexcessary ALI parameters + radiative rates
C (the routine is analogous to RATES1)
C a variant for derivatives of the rate matrix w.r.t. populations
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ITERAT.FOR'
DIMENSION EXX(MDEPTH),RBNU(MDEPTH),RBNUF(MDEPTH)
C DIMENSION EHKL(MFREQL),EHKLF(MFREQL)
C
C zero the rates and other quantities
C
DO ID=1,ND
REIT(ID)=0.
REIN(ID)=0.
REIX(ID)=0.
AREIT(ID)=0.
AREIN(ID)=0.
CREIT(ID)=0.
CREIN(ID)=0.
CREIX(ID)=0.
REDT(ID)=0.
REDTM(ID)=0.
REDTP(ID)=0.
REDN(ID)=0.
REDNM(ID)=0.
REDNP(ID)=0.
REDX(ID)=0.
REDXM(ID)=0.
REDXP(ID)=0.
HEIT(ID)=0.
HEITM(ID)=0.
HEITP(ID)=0.
HEIN(ID)=0.
HEINM(ID)=0.
HEINP(ID)=0.
EHET(ID)=0.
EHEN(ID)=0.
ERET(ID)=0.
EREN(ID)=0.
FCOOLI(ID)=0.
FLFIX(ID)=0.
FLEXP(ID)=0.
FLRD(ID)=0.
FPRD(ID)=0.
PRADT(ID)=0.
PRADA(ID)=0.
DO II=1,NLVEXP
HEIP(II,ID)=0.
REIP(II,ID)=0.
AREIP(II,ID)=0.
CREIP(II,ID)=0.
REDP(II,ID)=0.
REDPM(II,ID)=0.
HEIPM(II,ID)=0.
REDPP(II,ID)=0.
HEIPP(II,ID)=0.
APT(II,ID)=0.
APN(II,ID)=0.
DO JJ=1,NLVEXP
APP(JJ,II,ID)=0.
END DO
END DO
DO ITR=1,NTRANS
RRU(ITR,ID)=0.
RRD(ITR,ID)=0.
DRDT(ITR,ID)=0.
END DO
END DO
PRD0=0.
C
dedm1=dm(1)/dens(1)
IF (IRDER.EQ.3) THEN
C
LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN
IF(HMIX0.GT.0.) LROSS=.TRUE.
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=0.
SUMDPL(ID)=0.
END DO
END IF
C
DO 100 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 100
FR=FREQ(IJ)
W0=W0E(IJ)
LRDER=IJALI(IJ).GT.0
CALL OPACFD(IJ)
CALL RTEFR1(IJ)
CALL ALIFR1(IJ)
IF(LROSS) CALL ROSSTD(IJ)
if(ioptab.lt.0) go to 100
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO ID=1,ND
EXX(ID)=EXP(-HKT1(ID)*FR)
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
DO 10 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 10
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10
JC=ITRA(JJ,II)
IF(IFWOP(II).GE.0) THEN
ICDW=MCDW(ITR)
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
IMER=IMRG(II)
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
IE=IABS(IIEXP(II))
JJ=IUP(ITR)
JE=IABS(IIEXP(JJ))
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
10 CONTINUE
END DO
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
DO 50 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
50 CONTINUE
c 55 CONTINUE
ENDIF
IF(NLINES(IJ).LE.0) GO TO 100
C
C the "overlapping" lines at the given frequency
C
DO 90 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) goto 90
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 70
END IF
END DO
70 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
DO 80 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
80 CONTINUE
90 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 100
DO 95 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO 510 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 510
SGW0=PRFLIN(ID,KJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
510 CONTINUE
ELSE
DO 520 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 520
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
520 CONTINUE
END IF
95 CONTINUE
END IF
100 CONTINUE
C
ELSE IF (IRDER.EQ.1) THEN
C
DO 200 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 200
FR=FREQ(IJ)
W0=W0E(IJ)
LRDER=IJALI(IJ).GT.0
CALL OPACFD(IJ)
CALL RTEFR1(IJ)
CALL ALIFR1(IJ)
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO 120 ID=1,ND
EXX(ID)=EXP(-HKT1(ID)*FR)
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
DO 110 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 110
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 110
JC=ITRA(JJ,II)
ICDW=MCDW(ITR)
IMER=IMRG(II)
IF(IFWOP(II).GE.0) THEN
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
IE=IABS(IIEXP(II))
JJ=IUP(ITR)
JE=IABS(IIEXP(JJ))
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
END IF
END IF
110 CONTINUE
120 CONTINUE
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
DO 150 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
END IF
END IF
150 CONTINUE
c 155 CONTINUE
ENDIF
IF(NLINES(IJ).LE.0) GO TO 200
C
C the "overlapping" lines at the given frequency
C
DO 190 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) goto 190
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
IJ0=IFR0(ITR)
DO 160 IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 170
END IF
160 CONTINUE
170 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
DO 180 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 180
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
END IF
END IF
180 CONTINUE
190 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 200
DO 195 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO 610 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 610
SGW0=PRFLIN(ID,KJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
END IF
END IF
610 CONTINUE
ELSE
DO 620 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 620
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID)
APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID)
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID)
APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID)
END IF
END IF
620 CONTINUE
END IF
195 CONTINUE
END IF
200 CONTINUE
C
ELSE IF (IRDER.EQ.2) THEN
C
DO 300 IJ=1,NFREQ
IF(IJX(IJ).EQ.-1) GO TO 300
FR=FREQ(IJ)
W0=W0E(IJ)
LRDER=IJALI(IJ).GT.0
CALL OPACFD(IJ)
CALL RTEFR1(IJ)
CALL ALIFR1(IJ)
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO ID=1,ND
EXX(ID)=EXP(-HKT1(ID)*FR)
RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID)
RBNUF(ID)=RBNU(ID)*FR*HKT21(ID)
DO 210 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 210
II=ILOW(ITR)
JJ=IUP(ITR)
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 210
JC=ITRA(JJ,II)
ICDW=MCDW(ITR)
IMER=IMRG(II)
IF(IFWOP(II).GE.0) THEN
IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID)
ELSE
SG=SGMG(IMER,ID)
ENDIF
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
IE=IABS(IIEXP(II))
JJ=IUP(ITR)
JE=IABS(IIEXP(JJ))
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
210 CONTINUE
END DO
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
DO 250 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 250
SGW0=PRFLIN(ID,IJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
250 CONTINUE
ENDIF
IF(NLINES(IJ).LE.0) GO TO 300
C
C the "overlapping" lines at the given frequency
C
DO 290 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
if(linexp(itr)) goto 290
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 270
END IF
END DO
270 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0
A2=W0-A1
DO 280 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 280
SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0.
* AND.IABS(IMODL(II)).NE.4) THEN
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
280 CONTINUE
290 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 300
DO 295 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
II=ILOW(ITR)
JJ=IUP(ITR)
IE=IABS(IIEXP(II))
JE=IABS(IIEXP(JJ))
KJ=IJ-IFR0(ITR)+KFR0(ITR)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
DO 710 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 710
SGW0=PRFLIN(ID,KJ)*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
710 CONTINUE
ELSE
DO 720 ID=1,ND
IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 720
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
SGW0=SG*W0
RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID)
RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID)
IF(LRDER) THEN
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0
NREFI=NREFS(IATM(II),ID)
IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN
DO KK=1,NLVEXP
APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID)
END DO
END IF
IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0
* .AND.IABS(IMODL(II)).NE.4) THEN
DO KK=1,NLVEXP
APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID)
END DO
END IF
END IF
720 CONTINUE
END IF
295 CONTINUE
END IF
300 CONTINUE
C
ELSE
CALL QUIT(' Invalid IRDER - ALIST2',irder,irder)
END IF
C
C multiply some quantities by frequency-independent constants
C
DO ID=1,ND
REDX(ID)=REDX(ID)*WMM(ID)*DENS1(ID)*DENS1(ID)
IF(ID.GT.1) REDXM(ID)=REDXM(ID)*WMM(ID)*
* DENS1(ID-1)*DENS1(ID-1)
FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID)
IF(CRSW(ID).NE.UN) THEN
DO ITR=1,NTRANS
RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID)
RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID)
DRDT(ITR,ID)=DRDT(ITR,ID)*CRSW(ID)
END DO
C IF(LRDER) THEN
IF(IRDER.GT.0) THEN
DO II=1,NLVEXP
APT(II,ID)=APT(II,ID)*CRSW(ID)
APN(II,ID)=APN(II,ID)*CRSW(ID)
DO JJ=1,NLVEXP
APP(JJ,II,ID)=APP(JJ,II,ID)*CRSW(ID)
END DO
END DO
END IF
END IF
END DO
C
C radiation pressure
C
PRDX=1.
DO ID=1,ND
PRADT(ID)=PRADT(ID)*PCK
PRADA(ID)=PRADA(ID)*PCK
if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID)
IF(PRDR.LT.PRDX) PRDX=PRDR
END DO
PRD0=PRD0/DENS1(1)*DM(1)*PCK
IF(LFIN) WRITE(10,1100) PRDX,ITER
1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4)
C
C Rosseland mean opacity
C
IF(LROSS) THEN
DO ID=1,ND
ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID))
END DO
if(ioptab.lt.0.and.ifryb.gt.0) then
do id=1,nd
abrosd(id)=abrosd(id)*dens(id)
end do
end if
call rosstd(0)
END IF
c
RETURN
END
tlusty/extracted/allard.f
+217
View File
@@ -0,0 +1,217 @@
subroutine allard(xl,t,hneutr,hcharg,prof,iq,jq)
c ================================================
c
c quasi-molecular opacity for Lyman alpha, beta, and Balmer alpha
c modified routine provided originally by D. Koester
c
c Input: xl: wavelength in [A]
c hneutr: neutral H particle density [cm-3]
c hcharg: ionized H particle density [cm-3]
c iq: quantum number of the lower level
c jq: quantum number of the upper level;
c =2 - Lyman alpha
c =3 - Lyman beta
c Output: prof: Lyman alpha line profile, normalized to 1.0e8
c if integrated over A;
c It then renormalized by multiplying by
c 8.853e-29*lambda_0^2*f_ij
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
parameter (NXMAX=1400,NNMAX=5,NTAMAX=6)
parameter (xnorma=8.8528e-29*1215.6*1215.6*0.41618,
* xnormb=8.8528e-29*1025.73*1025.7*0.0791,
* xnormg=8.8528e-29*972.53*972.53*0.0290,
* xnormc=8.8528e-29*6562.*6562.*0.6407)
common /callarda/xlalp(NXMAX),plalp(NXMAX,NNMAX),stnnea,stncha,
* vneua,vchaa,nxalp,iwarna
common /callardb/xlbet(NXMAX),plbet(NXMAX,NNMAX),stnneb,stnchb,
* vneub,vchab,nxbet,iwarnb
common /callardg/xlgam(NXMAX),plgam(NXMAX,NNMAX),stnneg,stnchg,
* vneug,vchag,nxgam,iwarng
common /callardc/xlbal(NXMAX),plbal(NXMAX,NNMAX),stnnec,stnchc,
* vneuc,vchac,nxbal,iwarnc
common /calphatd/xlalpd(NXMAX,NTAMAX),plalpd(NXMAX,NNMAX,NTAMAX),
* stnead(ntamax),stnchd(ntamax),
* vneuad(ntamax),vchaad(ntamax),
* talpd(ntamax),nxalpd(ntamax),ntalpd
common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal
c
prof=0.
c
c Lyman alpha
c
if(iq.eq.1.and.jq.eq.2) then
if(nunalp.lt.0) then
call allardt(xl,t,hneutr,hcharg,prof)
else
if(xl.lt.xlalp(1).or.xl.gt.xlalp(nxalp)) return
vn1=hneutr/stnnea
vn2=hcharg/stncha
vns=vn1*vneua+vn2*vchaa
if(iwarna.eq.0) then
if(vn1*vneua.gt.0.3.or.vn2*vchaa.gt.0.3) then
write(*,*) ' warning: density too high for',
* ' Lyman alpha expansion'
iwarna=1
endif
endif
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
c
jl=0
ju=nxalp+1
10 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((xlalp(nxalp).gt.xlalp(1)).eqv.(xl.gt.xlalp(jm))) then
jl=jm
else
ju=jm
endif
go to 10
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxalp) j=j-1
a1=(xl-xlalp(j))/(xlalp(j+1)-xlalp(j))
p1= vn1*((1.0-a1)*plalp(j,1)+a1*plalp(j+1,1))
p11=vn11*((1.0-a1)*plalp(j,2)+a1*plalp(j+1,2))
p2= vn2*((1.0-a1)*plalp(j,3)+a1*plalp(j+1,3))
p22=vn22*((1.0-a1)*plalp(j,4)+a1*plalp(j+1,4))
p12=vn12*((1.0-a1)*plalp(j,5)+a1*plalp(j+1,5))
prof=(p1+p2+p11+p22+p12)*xnorm*xnorma
return
end if
end if
c
c Lyman beta
c
if(iq.eq.1.and.jq.eq.3) then
if(nxbet.eq.0) return
if(xl.lt.xlbet(1).or.xl.gt.xlbet(nxbet)) return
vn1=hneutr/stnneb
vn2=hcharg/stnchb
vns=vn1*vneub+vn2*vchab
if(iwarnb.eq.0) then
if(vn1*vneub.gt.0.3.or.vn2*vchab.gt.0.3) then
write(*,*) ' warning: density too high for',
* ' Lyman beta expansion'
iwarnb=1
endif
endif
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
c
jl=0
ju=nxbet+1
20 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((xlbet(nxbet).gt.xlbet(1)).eqv.(xl.gt.xlbet(jm))) then
jl=jm
else
ju=jm
endif
go to 20
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxbet) j=j-1
a1=(xl-xlbet(j))/(xlbet(j+1)-xlbet(j))
p1= vn1*((1.0-a1)*plbet(j,1)+a1*plbet(j+1,1))
p11=vn11*((1.0-a1)*plbet(j,2)+a1*plbet(j+1,2))
p2= vn2*((1.0-a1)*plbet(j,3)+a1*plbet(j+1,3))
p22=vn22*((1.0-a1)*plbet(j,4)+a1*plbet(j+1,4))
p12=vn12*((1.0-a1)*plbet(j,5)+a1*plbet(j+1,5))
prof=(p1+p2+p11+p22+p12)*xnorm*xnormb
return
end if
c
c Lyman gamma
c
if(iq.eq.1.and.jq.eq.4) then
if(nxgam.eq.0) return
if(xl.lt.xlgam(1).or.xl.gt.xlgam(nxgam)) return
vn1=hneutr/stnneg
vn2=hcharg/stnchg
vns=vn1*vneug+vn2*vchag
if(iwarng.eq.0) then
if(vn1*vneug.gt.0.3.or.vn2*vchag.gt.0.3) then
write(*,*) ' warning: density too high for',
* ' Lyman gamma expansion'
iwarng=1
endif
endif
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
c
jl=0
ju=nxgam+1
30 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((xlgam(nxgam).gt.xlgam(1)).eqv.(xl.gt.xlgam(jm))) then
jl=jm
else
ju=jm
endif
go to 30
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxgam) j=j-1
a1=(xl-xlgam(j))/(xlgam(j+1)-xlgam(j))
p1= vn1*((1.0-a1)*plgam(j,1)+a1*plgam(j+1,1))
p11=vn11*((1.0-a1)*plgam(j,2)+a1*plgam(j+1,2))
p2= vn2*((1.0-a1)*plgam(j,3)+a1*plgam(j+1,3))
p22=vn22*((1.0-a1)*plgam(j,4)+a1*plgam(j+1,4))
p12=vn12*((1.0-a1)*plgam(j,5)+a1*plgam(j+1,5))
prof=(p1+p2+p11+p22+p12)*xnorm*xnormg
return
end if
c
c Balmer alpha
c
if(iq.eq.2.and.jq.eq.3) then
if(xl.lt.xlbal(1).or.xl.gt.xlbal(nxbal)) return
vn1=0.
vn2=hcharg/stnchc
vns=vn1*vneuc+vn2*vchac
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
c
jl=0
ju=nxbal+1
40 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((xlbal(nxbal).gt.xlbal(1)).eqv.(xl.gt.xlbal(jm))) then
jl=jm
else
ju=jm
endif
go to 40
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxbal) j=j-1
a1=(xl-xlbal(j))/(xlbal(j+1)-xlbal(j))
p1= vn1*((1.0-a1)*plbal(j,1)+a1*plbal(j+1,1))
p11=vn11*((1.0-a1)*plbal(j,2)+a1*plbal(j+1,2))
p2= vn2*((1.0-a1)*plbal(j,3)+a1*plbal(j+1,3))
p22=vn22*((1.0-a1)*plbal(j,4)+a1*plbal(j+1,4))
p12=vn12*((1.0-a1)*plbal(j,5)+a1*plbal(j+1,5))
prof=(p1+p2+p11+p22+p12)*xnorm*xnormc
end if
c
return
end
tlusty/extracted/allardt.f
+158
View File
@@ -0,0 +1,158 @@
subroutine allardt(xl,t,hneutr,hcharg,prof)
c ===========================================
c
c quasi-molecular opacity for Lyman alpha, with T-dependent
c profile
c
c Input: xl: wavelength in [A]
c hneutr: neutral H particle density [cm-3]
c hcharg: ionized H particle density [cm-3]
c Output: prof: Lyman alpha line profile, normalized to 1.0e8
c if integrated over A;
c It then renormalized by multiplying by
c 8.853e-29*lambda_0^2*f_ij
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
parameter (NXMAX=1400,NNMAX=5,NTAMAX=6)
parameter (xnorma=8.8528e-29*1215.6*1215.6*0.41618)
common /calphatd/xlalpd(NXMAX,NTAMAX),plalpd(NXMAX,NNMAX,NTAMAX),
* stnead(ntamax),stnchd(ntamax),
* vneuad(ntamax),vchaad(ntamax),
* talpd(ntamax),nxalpd(ntamax),ntalpd
c
prof=0.
c
c find the two partial tables close to actual T
c
it0=0
do it=1,ntalpd
it0=it
if(t.lt.talpd(it)) then
it0=it-1
go to 10
end if
end do
10 continue
if(it0.eq.0) then
it0=1
go to 20
end if
if(it0.ge.ntalpd) then
it0=ntalpd
go to 20
end if
go to 30
20 continue
c
if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return
vn1=hneutr/stnead(it0)
vn2=hcharg/stnchd(it0)
vns=vn1*vneuad(it0)+vn2*vchaad(it0)
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
c
jl=0
ju=nxalpd(it0)+1
110 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if(xl.gt.xlalpd(jm,it0)) then
jl=jm
else
ju=jm
endif
go to 110
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxalpd(it0)) j=j-1
a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0))
p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0))
p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0))
p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0))
p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0))
p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0))
prof=(p1+p2+p11+p22+p12)*xnorm*xnorma
return
c
30 continue
c
c interpolate in the tables for different T
c
c the lower T
c
if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return
vn1=hneutr/stnead(it0)
vn2=hcharg/stnchd(it0)
vns=vn1*vneuad(it0)+vn2*vchaad(it0)
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
jl=0
ju=nxalpd(it0)+1
120 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if(xl.gt.xlalpd(jm,it0)) then
jl=jm
else
ju=jm
endif
go to 120
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxalpd(it0)) j=j-1
a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0))
p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0))
p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0))
p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0))
p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0))
p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0))
prof0=(p1+p2+p11+p22+p12)*xnorm*xnorma
c
c the higher T
c
it0=it0+1
if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return
vn1=hneutr/stnead(it0)
vn2=hcharg/stnchd(it0)
vns=vn1*vneuad(it0)+vn2*vchaad(it0)
vn11=vn1*vn1
vn22=vn2*vn2
vn12=vn1*vn2
xnorm=1.0/(1.0+vns+0.5*vns*vns)
jl=0
ju=nxalpd(it0)+1
130 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if(xl.gt.xlalpd(jm,it0)) then
jl=jm
else
ju=jm
endif
go to 130
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxalpd(it0)) j=j-1
a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0))
p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0))
p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0))
p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0))
p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0))
p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0))
prof1=(p1+p2+p11+p22+p12)*xnorm*xnorma
c
c final profile coefficient
c
dt=talpd(it0)-talpd(it0-1)
prof=(prof0*(talpd(it0)-t)+prof1*(t-talpd(it0-1)))/dt
c
return
end
tlusty/extracted/angset.f
+44
View File
@@ -0,0 +1,44 @@
subroutine angset
c =================
c
c sets up angles points and angle-dependent quantities for treating
c the Compton scattering
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
parameter(three=3.d0, five=5.d0, zero=0.d0, tr16=3.d0/16.d0)
dimension amu0(mmuc),wtmu0(mmuc)
c
c amu=cos(angle between line of sight and normal to slab) grid and
c gauss-legendre integration weights for the interval mu=[0,1]
c
call gauleg(zero,un,amu0,wtmu0,nmuc,mmuc)
c
do i=1,nmuc
amuc(i)=-amu0(nmuc-i+1)
amuc(i+nmuc)=amu0(i)
wtmuc(i)=wtmu0(nmuc-i+1)
wtmuc(i+nmuc)=wtmu0(i)
end do
nmuc=2*nmuc
c
do i=1,nmuc
amuc1(i)=amuc(i)*wtmuc(i)
amuc2(i)=amuc(i)*amuc(i)*wtmuc(i)
amuc3(i)=amuc(i)*amuc(i)*amuc(i)*wtmuc(i)
a1=amuc(i)
a2=a1*a1
a3=a1*a2
do i1=1,nmuc
b1=amuc(i1)
b2=b1*b1
b3=b1*b2
trw=tr16*wtmuc(i1)
calph(i,i1)=(three*a2*b2-a2-b2+three)*trw
cbeta(i,i1)=(five*(a1*b1+a3*b3)-three*(a3*b1+a1*b3))*trw
cgamm(i,i1)=a1*b1*trw
end do
end do
c
return
end
tlusty/extracted/betah.f
+33
View File
@@ -0,0 +1,33 @@
FUNCTION BETAH(R)
C =================
C
C Determination of the total pressure scale height
C Solution of the transcendental equation by the Newton-Raphson method
C
INCLUDE 'IMPLIC.FOR'
PARAMETER (UN=1.D0,
* PISQ=1.77245385090551D0)
IF(R.LT.0.88) THEN
BET0=PISQ/2.D0/R
ELSE
BET0=UN+UN/3.D0/R/R
END IF
C
ITER=0
BETA=BET0
10 ITER=ITER+1
B1=BETA-UN
RB1=R*B1
BSQ=SQRT(BETA*B1)
ERF1=ERFCX(R*BSQ)
ERF2=ERFCX(RB1)
RHS=BSQ/B1*(UN-ERF1)+EXP(-R*RB1)*ERF2
DP=R/PISQ*(2.D0-EXP(-R*BETA*RB1))+(UN-ERF1)/2.D0/B1/BSQ+
* R*R*EXP(-R*RB1)*ERF2
DBETA=(RHS-2.D0/PISQ*BETA*R)/DP
DEL=DBETA/BETA
BETA=BETA+DBETA
IF(ABS(DEL).GT.1.D-5.AND.ITER.LE.10) GO TO 10
BETAH=BETA
RETURN
END
tlusty/extracted/bhe.f
+174
View File
@@ -0,0 +1,174 @@
SUBROUTINE BHE(ID)
C ==================
C
C The part of matrices A and B corresponding to the hydrostatic
C equilibrium equation,
C i.e. the (NFREQE+INHE)-th row;
C and, if desired (INMP > 0), the part corresponding to the
C definition equation for the fictitious massive particle density,
C ie. the (NFREQE+INMP)-th row.
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
C
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NSE=NFREQE+INSE-1
c
c the case of fixed mass density
c
if(ifixde.gt.0) then
b(nhe,nhe)=un
b(nhe,npc)=-un
vecl(nhe)=dens(id)/wmm(id)+elec(id)-totn(id)
return
end if
C
C *********** Linearized equation for the fictitious massive particle
C density
C
IF(INMP.GT.0) THEN
NMP=NFREQE+INMP
B(NMP,NMP)=-UN
B(NMP,NHE)=UN
IF(INPC.GT.0) B(NMP,NPC)=-UN
END IF
C
C *********** Linearized hydrostatic equilibrium
C
HEXT=0.
HEXN=0.
GRD=0.
FLUXW=0.
IF(ID.GT.1) GO TO 50
C
C *** Upper boundary condition (ID=1)
C Basically, linearized eq. (7-10) of Mihalas (1978)
C
DO I=1,NLVEXP
HEX(I)=0.
END DO
x1=0.
IF(NFREQE.GT.0.AND.IFPRAD.GT.0) THEN
X1=PCK/DENS(ID)
DO IJ=1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
HEXN=HEXN+FLUXW*DABN0(IJ)
HEXT=HEXT+FLUXW*DABT0(IJ)
DO I=1,NLVEXP
HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ)
END DO
C
C Columns corresponding to mean intensities
C
B(NHE,IJ)=X1*W(IJT)*FH(IJT)*ABSO0(IJ)
END IF
END DO
END IF
C
RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID))
VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID)
C
C columns corresponding to total particle density, fictitious
C massive particle density, temperature, and electron density,
C respectively
C
B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0)
IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN)
IF(INRE.GT.0) THEN
B(NHE,NRE)=BOLK*TOTN(ID)/DM(1)+X1*(HEXT+HEIT(ID))
C(NHE,NRE)=X1*HEITP(ID)
END IF
IF(INPC.GT.0) THEN
B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0)
C(NHE,NPC)=X1*HEINP(ID)
END IF
C
C Columns corresponding to populations
C
DO II=1,NLVEXP
B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID))
C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID)
END DO
C
C The rhs vector also accounts for the total radiation pressure in
C the fixed-option transitions (array FPRD, generated by FIXLIN)
C
VECL(NHE)=GRAV-BOLK*TEMP(ID)*TOTN(ID)/DM(ID)-
* X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID)
RETURN
C
C *** Normal depth point (ID > 1)
C
C Columns (for matrices A and B) corresponding to mean intensities
C
50 CONTINUE
IF(NFREQE.GT.0.and.ifprad.gt.0) THEN
DO IJ=1,NFREQE
IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN
GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ))
A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ)
B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ)
END IF
END DO
END IF
C
VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID)
VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID-1)
C
C columns corresponding to total particle density
C
A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*VTM
B(NHE,NHE)=BOLK*TEMP(ID)+GN*VT0
C
C columns corresponding to temperature
C
IF(INRE.GT.0) THEN
A(NHE,NRE)=-BOLK*TOTN(ID-1)+PCK*HEITM(ID)
B(NHE,NRE)=BOLK*TOTN(ID)+PCK*HEIT(ID)
C(NHE,NRE)=PCK*HEITP(ID)
END IF
C
C columns corresponding to electron density
C
IF(INPC.GT.0) THEN
A(NHE,NPC)=GN*VTM+PCK*HEINM(ID)
B(NHE,NPC)=-GN*VT0+PCK*HEIN(ID)
C(NHE,NPC)=PCK*HEINP(ID)
END IF
C
C columns corresponding to NMP
C
IF(INMP.GT.0) THEN
A(NHE,NFREQE+INMP)=-GP*VTM
B(NHE,NFREQE+INMP)=GP*VT0
END IF
C
C columns corresponding to populations
C
DO II=1,NLVEXP
A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID)
B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID)
C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID)
END DO
C
C the rhs vector
C again, which accounts for the total radiation pressure in the
C fixed-option transitions (array FPRD)
C
VECL(NHE)=GRAV*(DM(ID)-DM(ID-1))-
* BOLK*(TEMP(ID)*TOTN(ID)-TEMP(ID-1)*TOTN(ID-1))-
* PCK*(GRD+FPRD(ID))-
* VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID-1)*DENS(ID-1)
RETURN
END
tlusty/extracted/bhed.f
+342
View File
@@ -0,0 +1,342 @@
SUBROUTINE BHED(ID)
C ==================
C
C The part of matrices A and B corresponding to the hydrostatic
C equilibrium equation,
C i.e. the (NFREQE+INHE)-th row;
C ii) if desired (INMP > 0), the part corresponding to the
C definition equation for the fictitious massive particle density,
C ie. the (NFREQE+INMP)-th row;
C iii) the part of matrices B and C corresponding to the
C z-m (z-distance versus mass-depth coordinate) relation,
C ie. the (NFREQE+INZD)-th row of matrices B and C, however, the
C elements of C are treated separately
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ)
COMMON/CMATZD/CZZ,CZN,CZE,CZM
C
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NSE=NFREQE+INSE-1
c
if(inhe.le.0) go to 100
IJ1=1
C
C *********** Linearized equation for the fictitious massive particle
C density
C
IF(INMP.GT.0) THEN
NMP=NFREQE+INMP
B(NMP,NMP)=-UN
B(NMP,NHE)=UN
IF(INPC.GT.0) B(NMP,NPC)=-UN
END IF
C
C *********** Linearized hydrostatic equilibrium
C
HEXT=0.
HEXN=0.
GRD=0.
FLUXW=0.
DO I=1,NLVEXP
HEX(I)=0.
END DO
C
IF(ID.GT.1) GO TO 50
C
C *** Upper boundary condition (ID=1)
C
C 1. possibility - the same as in stellar atmospheres
C Basically, linearized eq. (7-10) of Mihalas (1978)
C
IF(IBCHE.LE.0) THEN
X1=PCK/DENS(ID)
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
HEXN=HEXN+FLUXW*DABN0(IJ)
HEXT=HEXT+FLUXW*DABT0(IJ)
DO I=1,NLVEXP
HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ)
END DO
C
C Columns corresponding to mean intensities
C
B(NHE,IJ)=X1*WDEP0(IJ)*FH(IJT)*ABSO0(IJ)
END IF
END DO
END IF
C
RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID))
VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID)
C
C columns corresponding to total particle density, fictitious
C massive particle density, temperature, and electron density,
C respectively
C
B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0)
IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN)
IF(INRE.GT.0) THEN
B(NHE,NRE)=BOLK*PSI0(NHE)/DM(1)+X1*(HEXT+HEIT(ID))
C(NHE,NRE)=X1*HEITP(ID)
END IF
IF(INPC.GT.0) THEN
B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0)
C(NHE,NPC)=X1*HEINP(ID)
END IF
C
C Columns corresponding to populations
C
DO II=1,NLVEXP
B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID))
C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID)
END DO
C
C The rhs vector also accounts for the total radiation pressure in
C the fixed-option transitions (array FPRD)
C
GRAV=QGRAV*ZD(1)
VECL(NHE)=GRAV-BOLK*TEMP(ID)*PSI0(NHE)/DM(ID)-
* X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID)
GO TO 100
ELSE IF(IBCHE.EQ.1) THEN
C
C 2. possibility - specifically disk - Hubeny (1990), Eq. (4.19)
C newer variant
C
C
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
HEXN=HEXN+FLUXW*DABN0(IJ)
HEXT=HEXT+FLUXW*DABT0(IJ)
DO I=1,NLVEXP
HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ)
END DO
END IF
END DO
END IF
C
CCC=PCK/QGRAV
HR1=CCC*(GRD+FPRD(1))/DENS(1)
PG1=BOLK*PSI0(NHE)*TEMP(1)
HG1=SQRT(TWO*PG1/DENS(1)/QGRAV)
X=(ZD(1)-HR1)/HG1
IF(X.LT.3.) THEN
IF(X.LT.0.) X=0.
F1=8.86226925D-1*EXP(X*X)*ERFCX(X)
ELSE
F1=HALF*(UN-HALF/X/X)/X
END IF
X1=X*1.01
F1D=0.
IF(X1.LT.3.) THEN
F1D=8.86226925D-1*EXP(X1*X1)*ERFCX(X1)
ELSE
F1D=HALF*(UN-HALF/X1/X1)/X1
END IF
IF(X.GT.0.) F1D=(F1D-F1)*100./X
GGG=DENS(1)*HG1*F1
RF1=DENS(1)*F1D
CCD=CCC*F1D
C
DO IJ=1,NFREQE
B(NHE,IJ)=-CCD*WDEP0(IJ)*FH(IJFR(IJ))*ABSO0(IJ)
END DO
C
C columns corresponding to total particle density and temperature
C
B(NHE,NHE)=B(NHE,NHE)+(GGG+HR1*RF1)/PSI0(NHE)
IF(INRE.GT.0) B(NHE,NRE)=
* (GGG-RF1*ZD(1)+RF1*HR1)*HALF/TEMP(1)-CCD*(HEXT+HEIT(ID))
IF(INZD.GT.0) B(NHE,NZD)=RF1
IF(INPC.GT.0) B(NHE,NPC)=-CCD*(HEXN+HEIN(ID))
DO II=1,NLVEXP
B(NHE,NSE+II)=-CCD*(HEX(II)+HEIP(II,ID))
END DO
C
C The rhs vector
C
VECL(NHE)=DM(1)-GGG
GO TO 100
ELSE IF(IBCHE.EQ.2) THEN
C
C 3. possibility - specifically disk - Hubeny (1990), Eq. (4.19)
C older variant
C
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
END IF
END DO
END IF
CCC=PCK/QGRAV
PR1=CCC*(GRD+FPRD(1))/DENS(1)
PG1=BOLK*PSI0(NHE)*TEMP(1)
HG1=SQRT(TWO*PG1/DENS(1)/QGRAV)
X=(ZD(1)-PR1)/HG1
IF(X.LT.3.) THEN
IF(X.LT.0.) X=0.
F1=8.86226925D-1*EXP(X*X)*ERFCX(X)
ELSE
F1=HALF*(UN-HALF/X/X)/X
END IF
GGG=HG1*QGRAV*HALF/F1
C
C columns corresponding to total particle density and temperature
C
B(NHE,NHE)=BOLK*TEMP(1)
IF(INRE.GT.0) B(NHE,NFREQE+INRE)=PG1/TEMP(1)
C
C The rhs vector
C
VECL(NHE)=DM(1)*GGG-PG1
GO TO 100
END IF
C
C *** Normal depth point (ID > 1)
C
C Columns (for matrices A and B) corresponding to mean intensities
C
50 IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN
GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ))
A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ)
B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ)
END IF
END DO
END IF
C
VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID)
VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID)
C
C columns corresponding to total particle density
C
A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*VTM
B(NHE,NHE)=BOLK*TEMP(ID)+GN*VT0
C
C columns corresponding to temperature
C
IF(INRE.GT.0) THEN
A(NHE,NRE)=-BOLK*PSIM(NHE)+PCK*HEITM(ID)
B(NHE,NRE)=BOLK*PSI0(NHE)+PCK*HEIT(ID)
C(NHE,NRE)=PCK*HEITP(ID)
END IF
C
C columns corresponding to electron density
C
IF(INPC.GT.0) THEN
A(NHE,NPC)=GN*VTM+PCK*HEINM(ID)
B(NHE,NPC)=-GN*VT0+PCK*HEIN(ID)
C(NHE,NPC)=PCK*HEINP(ID)
END IF
C
C columns corresponding to NMP
C
IF(INMP.GT.0) THEN
A(NHE,NFREQE+INMP)=-GP*VTM
B(NHE,NFREQE+INMP)=GP*VT0
END IF
C
C column corresponding to ZD (z-distance)
C
IF(INZD.GT.0) THEN
A(NHE,NFREQE+INZD)=-QGRAV*(DM(ID)-DM(ID-1))*HALF
B(NHE,NFREQE+INZD)=-QGRAV*(DM(ID)-DM(ID-1))*HALF
END IF
C
C columns corresponding to populations
C
DO II=1,NLVEXP
A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID)
B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID)
C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID)
END DO
C
C the rhs vector
C again, which accounts for the total radiation pressure in the
C fixed-option transitions (array FPRD)
C
C Since ZD(ID) is in fact z-distance corresponding to a midpoint
C between depth points ID and ID+1 (as follows from the numerical
C representation of the relation between DM and ZD), and ZD(ID-1)
C corresponds to a midpoint between ID and ID-1, z-distance for
C the point ID is better approximated by the mean value of ZD(ID)
C and ZD(ID-1)
C
GRAV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF
VECL(NHE)=GRAV*(DM(ID)-DM(ID-1))-
* BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))-
* PCK*(GRD+FPRD(ID))-
* VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID)*DENS(ID-1)
C
C *********** Linearized z-m (z-distance vers. mass-depth) relation
C
C Note: since there are only at most four non-zero elements of
C matrix C, they are stored separately in CZZ,CZN,CZE,CZM;
C when multiplying any matrix by matrix C, these terms must be
C treated separately - see SOLVE
C
100 IF(INZD.LE.0) RETURN
NZD=NFREQE+INZD
C
C *** lower boundary condition [ie. z(ND)=0 ]
C
B(NZD,NZD)=UN
IF(ID.EQ.ND) RETURN
C
C *** normal depth point
C
DDP=(DM(ID+1)-DM(ID))*HALF
C
C column corresponding to ZD
C
B(NZD,NZD)=UN
CZZ=-UN
C
C column corresponding to total particle density
C
X1=GN*WMM(ID)*DDP
IF(INHE.GT.0) THEN
B(NZD,NFREQE+INHE)=X1/DENS(ID)/DENS(ID)
CZN=X1/DENS(ID+1)/DENS(ID+1)
END IF
C
C column corresponding to electron density
C
IF(INPC.GT.0) THEN
B(NZD,NFREQE+INPC)=-X1/DENS(ID)/DENS(ID)
CZE=-X1/DENS(ID+1)/DENS(ID+1)
END IF
C
C column corresponding to NMP
C
IF(INMP.GT.0) THEN
B(NZD,NFREQE+INMP)=DDP/DENS(ID)/PSI0(NFREQE+INMP)
CZM=DDP/DENS(ID+1)/PSIP(NFREQE+INMP)
END IF
C
C the element of the rhs vector
C
VECL(NZD)=ZD(ID+1)-ZD(ID)+DDP/DENS(ID)+DDP/DENS(ID+1)
RETURN
END
tlusty/extracted/bhez.f
+283
View File
@@ -0,0 +1,283 @@
SUBROUTINE BHEZ(ID)
C ==================
C
C The part of matrices A and B corresponding to the hydrostatic
C equilibrium equation,
C i.e. the (NFREQE+INHE)-th row;
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ)
C
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NZD=NFREQE+INZD
NSE=NFREQE+INSE-1
c
if(inhe.le.0) return
IJ1=1
C
C *********** Linearized equation for the fictitious massive particle
C density
C
IF(INMP.GT.0) THEN
NMP=NFREQE+INMP
B(NMP,NMP)=-UN
B(NMP,NHE)=UN
IF(INPC.GT.0) B(NMP,NPC)=-UN
END IF
C
C *********** Linearized hydrostatic equilibrium
C
HEXT=0.
HEXN=0.
GRD=0.
FLUXW=0.
DO I=1,NLVEXP
HEX(I)=0.
END DO
C
IF(ID.GT.1) GO TO 50
C
C *** Upper boundary condition (ID=1)
C
C 1. possibility - the same as in stellar atmospheres
C Basically, linearized eq. (7-10) of Mihalas (1978)
C
IF(IBCHE.EQ.0) THEN
X1=PCK/DENS(ID)
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
HEXN=HEXN+FLUXW*DABN0(IJ)
HEXT=HEXT+FLUXW*DABT0(IJ)
DO I=1,NLVEXP
HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ)
END DO
C
C Columns corresponding to mean intensities
C
B(NHE,IJ)=X1*WDEP0(IJ)*FH(IJT)*ABSO0(IJ)
END IF
END DO
END IF
C
RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID))
VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID)
C
C columns corresponding to total particle density, fictitious
C massive particle density, temperature, and electron density,
C respectively
C
B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0)
IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN)
IF(INRE.GT.0) THEN
B(NHE,NRE)=BOLK*PSI0(NHE)/DM(1)+X1*(HEXT+HEIT(ID))
C(NHE,NRE)=X1*HEITP(ID)
END IF
IF(INPC.GT.0) THEN
B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0)
C(NHE,NPC)=X1*HEINP(ID)
END IF
C
C Columns corresponding to populations
C
DO II=1,NLVEXP
B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID))
C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID)
END DO
C
C The rhs vector also accounts for the total radiation pressure in
C the fixed-option transitions (array FPRD)
C
GRAV=QGRAV*ZD(1)
VECL(NHE)=GRAV-BOLK*TEMP(ID)*PSI0(NHE)/DM(ID)-
* X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID)
C
RETURN
ELSE IF(IBCHE.EQ.1) THEN
C
C 2. possibility - specifically disk - Hubeny (1990), Eq. (4.19)
C newer variant
C
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
HEXN=HEXN+FLUXW*DABN0(IJ)
HEXT=HEXT+FLUXW*DABT0(IJ)
DO I=1,NLVEXP
HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ)
END DO
END IF
END DO
END IF
c
CCC=PCK/QGRAV
HR1=CCC*(GRD+FPRD(1))/DENS(1)
PG1=BOLK*PSI0(NHE)*TEMP(1)
HG1=SQRT(TWO*PG1/DENS(1)/QGRAV)
X=(ZD(1)-HR1)/HG1
IF(X.LT.3.) THEN
IF(X.LT.0.) X=0.
F1=8.86226925D-1*EXP(X*X)*ERFCX(X)
ELSE
F1=HALF*(UN-HALF/X/X)/X
END IF
X1=X*1.01
F1D=0.
IF(X1.LT.3.) THEN
F1D=8.86226925D-1*EXP(X1*X1)*ERFCX(X1)
ELSE
F1D=HALF*(UN-HALF/X1/X1)/X1
END IF
IF(X.GT.0.) F1D=(F1D-F1)*100./X
GGG=DENS(1)*HG1*F1
RF1=DENS(1)*F1D
CCD=CCC*F1D
C
DO IJ=1,NFREQE
B(NHE,IJ)=-CCD*WDEP0(IJ)*FH(IJFR(IJ))*ABSO0(IJ)
END DO
C
C columns corresponding to total particle density and temperature
C
B(NHE,NHE)=B(NHE,NHE)+(GGG+HR1*RF1)/PSI0(NHE)
IF(INRE.GT.0) B(NHE,NRE)=
* (GGG-RF1*ZD(1)+RF1*HR1)*HALF/TEMP(1)-CCD*(HEXT+HEIT(ID))
IF(INZD.GT.0) B(NHE,NZD)=RF1
IF(INPC.GT.0) B(NHE,NPC)=-CCD*(HEXN+HEIN(ID))
DO II=1,NLVEXP
B(NHE,NSE+II)=-CCD*(HEX(II)+HEIP(II,ID))
END DO
C
C The rhs vector
C
VECL(NHE)=DM(1)-GGG
RETURN
ELSE IF(IBCHE.EQ.2) THEN
C
C 3. possibility - specifically disk - Hubeny (1990), Eq. (4.19)
C older variant
C
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
IF(.NOT.LSKIP(ID,IJT)) THEN
FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT))
GRD=GRD+FLUXW*ABSO0(IJ)
END IF
END DO
END IF
CCC=PCK/QGRAV
PR1=CCC*(GRD+FPRD(1))/DENS(1)
PG1=BOLK*PSI0(NHE)*TEMP(1)
HG1=SQRT(TWO*PG1/DENS(1)/QGRAV)
X=(ZD(1)-PR1)/HG1
IF(X.LT.3.) THEN
IF(X.LT.0.) X=0.
F1=8.86226925D-1*EXP(X*X)*ERFCX(X)
ELSE
F1=HALF*(UN-HALF/X/X)/X
END IF
GGG=HG1*QGRAV*HALF/F1
C
C columns corresponding to total particle density and temperature
C
B(NHE,NHE)=BOLK*TEMP(1)
IF(INRE.GT.0) B(NHE,NFREQE+INRE)=PG1/TEMP(1)
C
C The rhs vector
C
VECL(NHE)=DM(1)*GGG-PG1
RETURN
ELSE
C
C 4. a simple form of the bounary condition P_gas(ID=1)=PGAS0,
C where PGAS0 is an input parameter
C
B(NHE,NHE)=BOLK*TEMP(1)
IF(INRE.GT.0) B(NHE,NRE)=BOLK*PSI0(NHE)
VECL(NHE)=PGAS0-BOLK*TEMP(1)*PSI0(NHE)
RETURN
END IF
C
C *** Normal depth point (ID > 1)
C
C Columns (for matrices A and B) corresponding to mean intensities
C
50 CONTINUE
GRAV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF
GRAVZ=GRAV*(ZD(ID)-ZD(ID-1))
DGRV=GRAVZ*HALF*WMM(ID)
GRD=0.
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN
GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ))
A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ)
B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ)
END IF
END DO
END IF
C
VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID)
VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID)
C
C columns corresponding to total particle density
C
A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*(VTM+DGRV)
B(NHE,NHE)=BOLK*TEMP(ID)+GN*(VT0+DGRV)
C
C columns corresponding to temperature
C
IF(INRE.GT.0) THEN
A(NHE,NRE)=-BOLK*PSIM(NHE)+PCK*HEITM(ID)
B(NHE,NRE)=BOLK*PSI0(NHE)+PCK*HEIT(ID)
C(NHE,NRE)=PCK*HEITP(ID)
END IF
C
C columns corresponding to electron density
C
IF(INPC.GT.0) THEN
A(NHE,NPC)=GN*(VTM+DGRV)+PCK*HEINM(ID)
B(NHE,NPC)=-GN*(VT0+DGRV)+PCK*HEIN(ID)
C(NHE,NPC)=PCK*HEINP(ID)
END IF
C
C columns corresponding to NMP
C
IF(INMP.GT.0) THEN
A(NHE,NFREQE+INMP)=-GP*(VTM+DGRV)
B(NHE,NFREQE+INMP)=GP*(VT0+DGRV)
END IF
C
C columns corresponding to populations
C
DO II=1,NLVEXP
A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID)
B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID)
C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID)
END DO
C
C the rhs vector
C
VECL(NHE)=-GRAVZ*(DENS(ID)+DENS(ID-1))*HALF-
* BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))-
* PCK*(GRD+FPRD(ID))-
* VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID)*DENS(ID-1)
C
RETURN
END
tlusty/extracted/bkhsgo.f
+66
View File
@@ -0,0 +1,66 @@
subroutine bkhsgo(freq,et,d,b,na,a,ss,nmax,iz,nsh,sg)
c =====================================================
c
c
c subroutine to calculate K and L shell photoionization cross-sections
c -based on Tim Kallman's bkhsgo subroutine from XSTAR, modified
c by Omer Blaes 5-7-98.
c -na.ne.2 bug corrected on 2/24/00 by Omer Blaes
c
c freq is photon frequency in Hz (note that this subroutine immediately
c converts it into eV)
c
c et is threshold energy in eV
c
c iz is the ionization stage of the species being photoionized (1=neutral etc.)
c
c ss is the iz'th element of the array ss(nmax) in Tim's original version
c
c sg is returned as the contribution to the photoionization cross-section
c in cm^2 due to whatever process is being considered.
c
c this routine does the work in computing cross sections by the
c method of barfield, et. al.
c
c
c
INCLUDE 'IMPLIC.FOR'
dimension b(5),a(11,5)
c
data sigth/1.e-34/
c
tmp1 = 0.
jj = 1
epii = 4.1357e-15*freq
sg=0.
if ( epii.gt.et ) then
xx = epii*(1.e-3) - d
if ( xx.le.0. ) return
do nna=1,na
if ( xx.ge.b(nna) ) jj = jj + 1
enddo
if ( jj.le.na ) then
if(xx.lt.0.) xx=0.
yy = log10(xx)
tmp = 0.
do kkk = 1,11
kk = 12 - kkk
tmp = a(kk,jj) + yy*tmp
end do
if(tmp.lt.-50.) tmp=-50.
if(tmp.gt.24.) tmp=24.
sgtmp = 10.**(tmp-24.)
nelec=nmax+1-iz
if(nelec.gt.nsh) nelec=nsh
enelec = float(nelec)
tmp1o = tmp1
tmp1=sgtmp*ss
if(tmp1.lt.sigth*enelec) tmp1=sigth*enelec
if ( epii.ge.5.e+4 ) then
if(tmp1.gt.tmp1o) tmp1 = tmp1o
end if
sg = sg + tmp1
endif
endif
return
end
tlusty/extracted/bpop.f
+79
View File
@@ -0,0 +1,79 @@
SUBROUTINE BPOP(ID)
C ===================
C
C The part of matrix B corresponding to the statistical
C equilibrium equations
C i.e. the (NFREQE+INSE)-th thru (NFREQE+INSE+NLVEXP-1)-th rows;
C and to the charge conservation equation, ie. the (NFREQE+INPC)-th
C row
C
C The formalism is similar to that described in Mihalas, Stellar
C Atmospheres, 1978, pp. 143-145
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ITERAT.FOR'
dimension sbw(mlevel)
dimension popp(mlevel)
C
if(ioptab.lt.0) return
DO I=1,NLVEXP
ATT(I)=0.
ANN(I)=0.
END DO
C
IF(.NOT.LTE .AND. IFPOPR.EQ.5.AND.IPSLTE.EQ.0) THEN
CALL RATMAT(ID,IIFOR,0,ESEMAT,BESE)
CALL LEVSOL(ESEMAT,BESE,POPP,IIFOR,NLVFOR,0)
DO I=1,NLEVEL
II=IIEXP(I)
IF(II.EQ.0.AND.IMODL(I).EQ.6) THEN
III=ILTREF(I,ID)
SBPSI(I,ID)=POPP(I)/POPP(III)
END IF
END DO
DO ION=1,NION
DO I=NFIRST(ION),NLAST(ION)
SBW(I)=ELEC(ID)*SBF(I)*WOP(I,ID)
IF(POPUL(NNEXT(ION),ID).GT.0..AND.IPZERO(I,ID).EQ.0)
* BFAC(I,ID)=POPP(I)/(POPP(NNEXT(ION))*SBW(I))
END DO
END DO
END IF
C
CALL LEVGRP(ID,IIEXP,0,POPP)
CALL RATMAT(ID,IIEXP,0,ESEMAT,BESE)
C
IF(IFPOPR.LE.3) CALL MATINV(ESEMAT,NLVEXP,MLEVEL)
C
C Split BPOP in separate subroutines
C
if(ipslte.eq.0) then
IF(.NOT.LTE.AND.IBPOPE.GT.0.AND.ID.LT.IDLTE) THEN
CALL BPOPE(ID)
CALL BPOPF(ID)
END IF
end if
CALL BPOPT(ID)
IF(INPC.GT.0) CALL BPOPC(ID)
C
C reset matrix elements for "small" populations
C
DO I=1,NLVEXP
IF(IGZERO(I,ID).NE.0) THEN
DO J=1,NLVEXP
B(NFREQE+INSE-1+I,NFREQE+INSE-1+J)=0.
END DO
B(NFREQE+INSE-1+I,NFREQE+INSE-1+I)=1.
VECL(NFREQE+INSE-1+I)=0.
END IF
END DO
RETURN
END
tlusty/extracted/bpopc.f
+109
View File
@@ -0,0 +1,109 @@
SUBROUTINE BPOPC(ID)
C ====================
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ODFPAR.FOR'
COMMON/ADCHAR/QADD(MDEPTH)
DIMENSION AJ(MLEVEL)
C
NSE=NFREQE+INSE-1
NPC=NFREQE+INPC
IF(IELH.GT.0) N0HN=NFIRST(IELH)
NKH=NREFS(IATREF,ID)
NKH=IABS(IIEXP(NKH))
T=TEMP(ID)
ANE=ELEC(ID)
HKT=HK/T
TK=HKT/H
ANMNE1=WMM(ID)*DENS1(ID)
DO I=1,NLEVEL
AJ(I)=0.
END DO
C
C *************************
C remaining equation - (NFREQE+INPC)-th row
C linearized charge conservation equation
C *************************
C
C This part is very similar to procedure ELCOR (obviously);
C array AJ has the meaning of coefficients of the charge conserv.
C ie. charge conservation is written
C AJ * (vector of populations) = electron density
C then
C APTT = (vector of populations) * (derivative AJ wrt temp)
C APNN = (vector of populations) * (derivative AJ wrt n(el))
C APM = (vector of populations) * (derivative AJ wrt N)
C
IF(INPC.EQ.0) RETURN
QQ=0.
if(ifmol.eq.0.or.t.gt.tmolim) then
CALL STATE(3,ID,T,ANE)
QQ=Q*ABUND(IATREF,ID)/YTOT(ID)
if(ioptab.gt.0) QQ=Q/YTOT(ID)
else
qq=qadd(id)*anmne1
dqt=0.
dqn=0.
end if
C
APTT=0.
APNN=0.
APM=0.
VPC=QFIX(ID)+QQ/ANMNE1
DO IAT=1,NATOM
IF(IIFIX(IAT).NE.1) THEN
DO I=N0A(IAT),NKA(IAT)
IF(IPZERO(I,ID).EQ.0) THEN
IL=ILK(I)
II=IIEXP(I)
IF(IL.EQ.0) THEN
CH=IZ(IEL(I))-1
DCHT=0.
DCHN=0.
ELSE
CH=IZ(IL)+(IZ(IL)-1)*USUM(IL)*ANE
DCHT=(IZ(IL)-1)*ANE*DUSUMT(IL)*POPUL(I,ID)
DCHN=(IZ(IL)-1)*(ANE*DUSUMN(IL)+USUM(IL))*POPUL(I,ID)
END IF
IF(IMODL(I).GE.0) VPC=VPC+CH*POPUL(I,ID)
IF(II.GT.0) THEN
AJ(II)=AJ(II)+CH
APTT=APTT+DCHT
APNN=APNN+DCHN
ELSE IF(II.LT.0) THEN
AJ(-II)=AJ(-II)+CH*SBPSI(I,ID)
APTT=APTT+DCHT*SBPSI(I,ID)
APNN=APNN+DCHN*SBPSI(I,ID)
ELSE
III=IIEXP(ILTREF(I,ID))
AJ(III)=AJ(III)+CH*SBPSI(I,ID)
APTT=APTT+CH*POPUL(I,ID)*DSBPST(I,ID)
APNN=APNN+CH*POPUL(I,ID)*DSBPSN(I,ID)
END IF
END IF
END DO
END IF
END DO
C
C (NFREQE+INPC)-th row of matrix B
C
NPC=NFREQE+INPC
QQQ=ABUND(IATREF,ID)/YTOT(ID)/ANMNE1
if(ioptab.gt.0) QQQ=UN/YTOT(ID)/ANMNE1
IF(INHE.NE.0) B(NPC,NFREQE+INHE)=APM+QQ
IF(INRE.NE.0) B(NPC,NFREQE+INRE)=APTT+QQQ*DQT
B(NPC,NPC)=APNN-QQ-UN+QQQ*DQN
DO II=1,NLVEXP
B(NPC,NSE+II)=AJ(II)
END DO
C
C (NFREQE+INPC)-th element of the rhs vector VECL
C
VECL(NPC)=ANE-VPC
RETURN
END
tlusty/extracted/bpope.f
+187
View File
@@ -0,0 +1,187 @@
SUBROUTINE BPOPE(ID)
C ====================
C
C the part of B-matrix corresponding to the population rows and
C the explicit frequency columns
C -- a variant for the full overlap case
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ITERAT.FOR'
INCLUDE 'ARRAY1.FOR'
DIMENSION AJIJ(MFREX,MLVEXP),EHKE(MFREX)
C
IF(NFREQE.LE.0) RETURN
NSE=NFREQE+INSE-1
DO I=1,NLVEXP
DO IJE=1,NFREQE
AJIJ(IJE,I)=0.
END DO
END DO
HKT=HK/TEMP(ID)
DO IJE=1,NFREQE
EHKE(IJE)=EXP(-HKT1(ID)*FREQ(IJFR(IJE)))
END DO
C
DO 100 IJ=1,NFREQ
IF(IJEX(IJ).LE.0) GO TO 100
IF(IJX(IJ).EQ.-1) GOTO 100
IJE=IJEX(IJ)
FR=FREQ(IJ)
FRINV=UN/FR
FR3INV=FRINV*FRINV*FRINV
C
C ---------------------
C Continuum transitions
C ---------------------
C
DO 10 IBFT=1,NTRANC
ITR=ITRBF(IBFT)
SG=CROSS(IBFT,IJ)
IF(SG.LE.0.) GO TO 10
I=ILOW(ITR)
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 10
ICDW=MCDW(ITR)
IMER=IMRG(I)
II=IABS(IIEXP(I))
J=IUP(ITR)
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 10
JJ=IABS(IIEXP(J))
NREFI=NREFS(IATM(I),ID)
IF(IFWOP(I).GE.0) THEN
IF(ICDW.GE.1) THEN
IZZ=IZ(IEL(I))
CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1)
SG=SG*DW1
END IF
ELSE
CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1)
SG=SGME1
ENDIF
W0=W0E(IJ)
SGW0=SG*W0
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW0
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
* and.iabs(imodl(i)).ne.4)
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
10 CONTINUE
C
C ----------------
C Line transitions
C ----------------
C
IF(ISPODF.EQ.0) THEN
IF(IJLIN(IJ).GT.0) THEN
C
C the "primary" line at the given frequency
C
ITR=IJLIN(IJ)
IF(LINEXP(ITR)) GO TO 20
IF(.NOT.LEXP(ITR)) GO TO 20
I=ILOW(ITR)
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 20
J=IUP(ITR)
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 20
II=IABS(IIEXP(I))
JJ=IABS(IIEXP(J))
IF(II.LE.0.AND.JJ.LE.0) GO TO 20
NREFI=NREFS(IATM(I),ID)
SGW=PRFLIN(ID,IJ)*W0E(IJ)
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
* and.iabs(imodl(i)).ne.4)
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
END IF
C
C the "overlapping" lines at the given frequency
C
20 IF(NLINES(IJ).LE.0) GO TO 100
DO 50 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
IF(LINEXP(ITR)) GO TO 50
I=ILOW(ITR)
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 50
J=IUP(ITR)
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 50
II=IABS(IIEXP(I))
JJ=IABS(IIEXP(J))
IF(II.LE.0.AND.JJ.LE.0) GO TO 50
NREFI=NREFS(IATM(I),ID)
IJ0=IFR0(ITR)
DO IJT=IJ0,IFR1(ITR)
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 40
END IF
END DO
40 IJ1=IJ0-1
X=W0E(IJ)/(FREQ(IJ1)-FREQ(IJ0))
A1=(FR-FREQ(IJ0))*X
A2=(FREQ(IJ1)-FR)*X
SGW=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
* and.iabs(imodl(i)).ne.4)
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
50 CONTINUE
C
C Opacity sampling option
C
ELSE
IF(NLINES(IJ).LE.0) GO TO 100
DO 150 ILINT=1,NLINES(IJ)
ITR=ITRLIN(ILINT,IJ)
I=ILOW(ITR)
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 150
J=IUP(ITR)
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 150
KJ=IJ-IFR0(ITR)+KFR0(ITR)
II=IABS(IIEXP(I))
JJ=IABS(IIEXP(J))
IF(II.LE.0.AND.JJ.LE.0) GO TO 150
NREFI=NREFS(IATM(I),ID)
INDXPA=IABS(INDEXP(ITR))
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
SG=PRFLIN(ID,KJ)
ELSE
KJD=JIDI(ID)
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
END IF
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SG*W0E(IJ)
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
* and.iabs(imodl(i)).ne.4)
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
150 CONTINUE
END IF
100 CONTINUE
C
C elements of the B-matrix
C
DO I=1,NLVEXP
DO IJE=1,NFREQE
IF(IFPOPR.LE.3) THEN
SUM=0.
DO J=1,NLVEXP
SUM=SUM-ESEMAT(I,J)*AJIJ(IJE,J)
END DO
ELSE
SUM=AJIJ(IJE,I)
END IF
B(NSE+I,IJE)=SUM*CRSW(ID)
END DO
END DO
RETURN
END
tlusty/extracted/bpopf.f
+106
View File
@@ -0,0 +1,106 @@
SUBROUTINE BPOPF(ID)
C =====================
C
C the part of B-matrix corresponding to the population rows and
C populations - i.e. derivatives of the ALI points intensities
C wrt. populations
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ODFPAR.FOR'
C
NSE=NFREQE+INSE-1
NRE=NFREQE+INRE
NPC=NFREQE+INPC
C
C matrix B of complete linearization
C
DO I=1,NLVEXP
SUMT=0.
SUMN=0.
DO II=1,NLVEXP
IF(IFPOPR.LE.3) THEN
SUMT=SUMT-ESEMAT(I,II)*APT(II,ID)
SUMN=SUMN-ESEMAT(I,II)*APN(II,ID)
SUM=0.
DO J=1,NLVEXP
SUM=SUM-ESEMAT(I,J)*APP(II,J,ID)
END DO
ELSE
SUM=APP(II,I,ID)
END IF
B(NSE+I,NSE+II)=B(NSE+I,NSE+II)+SUM
END DO
IF(IFPOPR.GT.3) THEN
SUMT=APT(I,ID)
SUMN=APN(I,ID)
END IF
IF(INRE.NE.0) B(NSE+I,NRE)=B(NSE+I,NRE)+SUMT
IF(INPC.NE.0) B(NSE+I,NPC)=B(NSE+I,NPC)+SUMN
END DO
IF(CRSW(ID).NE.UN) THEN
DO I=1,NLVEXP
DO II=1,NLVEXP
B(NSE+I,NSE+II)=B(NSE+I,NSE+II)*CRSW(ID)
END DO
END DO
END IF
C
C matrix A and C of complete linearization
C
IF(IFALI.GE.6) THEN
DO I=1,NLVEXP
ASUMT=0.
ASUMN=0.
CSUMT=0.
CSUMN=0.
DO II=1,NLVEXP
IF(IFPOPR.LE.3) THEN
ASUMT=ASUMT-ESEMAT(I,II)*AAPT(II,ID)
ASUMN=ASUMN-ESEMAT(I,II)*AAPN(II,ID)
CSUMT=CSUMT-ESEMAT(I,II)*CAPT(II,ID)
CSUMN=CSUMN-ESEMAT(I,II)*CAPN(II,ID)
ASUM=0.
CSUM=0.
DO J=1,NLVEXP
ASUM=ASUM-ESEMAT(I,J)*AAPP(II,J,ID)
CSUM=CSUM-ESEMAT(I,J)*CAPP(II,J,ID)
END DO
ELSE
ASUM=AAPP(II,I,ID)
CSUM=CAPP(II,I,ID)
END IF
A(NSE+I,NSE+II)=ASUM
C(NSE+I,NSE+II)=CSUM
END DO
IF(IFPOPR.GT.3) THEN
ASUMT=AAPT(I,ID)
ASUMN=AAPN(I,ID)
CSUMT=CAPT(I,ID)
CSUMN=CAPN(I,ID)
END IF
IF(INRE.NE.0) THEN
A(NSE+I,NRE)=A(NSE+I,NRE)+ASUMT
C(NSE+I,NRE)=C(NSE+I,NRE)+CSUMT
END IF
IF(INPC.NE.0) THEN
A(NSE+I,NPC)=A(NSE+I,NPC)+ASUMN
C(NSE+I,NPC)=C(NSE+I,NPC)+CSUMN
END IF
END DO
C
IF(CRSW(ID).NE.UN) THEN
DO I=1,NLVEXP
DO II=1,NLVEXP
A(NSE+I,NSE+II)=A(NSE+I,NSE+II)*CRSW(ID)
C(NSE+I,NSE+II)=C(NSE+I,NSE+II)*CRSW(ID)
END DO
END DO
END IF
END IF
RETURN
END
tlusty/extracted/bpopt.f
+200
View File
@@ -0,0 +1,200 @@
SUBROUTINE BPOPT(ID)
C ====================
C
C the part of B-matrix corresponding to the population rows
C and T and ne columns
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ODFPAR.FOR'
PARAMETER (TRHA=1.5D0)
PARAMETER (CCOR=0.09,SIXTH=UN/6.)
DIMENSION DCOL(MTRANS),DLOC(MTRANS),AM(MLEVEL)
C
NSE=NFREQE+INSE-1
IF(INRE.EQ.0.AND.INPC.EQ.0) GO TO 400
IF(IELH.GT.0) N0HN=NFIRST(IELH)
NKH=IABS(IIEXP(NREFS(IATREF,ID)))
T=TEMP(ID)
ANE=ELEC(ID)
HKT=HK/T
TK=HKT/H
ANMNE1=WMM(ID)*DENS1(ID)
DO I=1,NTRANS
DCOL(I)=0.
END DO
DO I=1,NLEVEL
AM(I)=0.
END DO
C
C Derivatives of collisional rates wrt temperature - DCOL
C Note that these derivatives are calculated numerically
C
IF(.NOT.LTE.AND.INRE.GT.0.AND.ID.LT.IDLTE) THEN
DELTAT=T*1.D-4
CALL COLIS(ID,T+DELTAT,DCOL,DLOC)
DO ITR=1,NTRANS
DCOL(ITR)=(DCOL(ITR)-COLRAT(ITR,ID))/DELTAT
end do
END IF
C
C Column corresponding to temperature and electron density, ie. the
C (NFREQE+INRE)-th and (NFREQE+INPC)-t resach columns
C
C ATT(I) - auxiliary vector = (derivative of rate matrix wrt
C temperature) times (vector of populations)
C
C ANN(I) - auxiliary vector = (derivative of rate matrix wrt
C electron density) times (vector of populations)
C
C
C a) contribution to AT and AN from true statistical equilibrium
C equations (arising due to dependence of transition rates on
C temperature and electron density);
C derivatives contain the collisional-radiative switching
C parameter CRSW
C
IF(.NOT.LTE.AND.ID.LT.IDLTE) THEN
DO 230 ITR=1,NTRANS
I=ILOW(ITR)
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 230
J=IUP(ITR)
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 230
II=IABS(IIEXP(I))
JJ=IABS(IIEXP(J))
NREFI=NREFS(IATM(I),ID)
IF(.NOT.LINE(ITR)) THEN
DLGT=-(TRHA+HKT*FR0(ITR))/T
DLGN=ELEC1(ID)
ELSE
DLGT=-HKT*FR0(ITR)/T
DLGN=0.
END IF
POPI=ABTRA(ITR,ID)
POPJ=EMTRA(ITR,ID)
PJI=POPJ*(RRD(ITR,ID)+COLRAT(ITR,ID))
AVT=(POPI-POPJ)*DCOL(ITR)-PJI*DLGT-
* POPJ*DRDT(ITR,ID)
AVN=(POPI-POPJ)*COLRAT(ITR,ID)/ane-PJI*DLGN
C
IF(I.NE.NREFI.AND.II.GT.0.AND.ILTLEV(I).LE.0) THEN
ATT(II)=ATT(II)+AVT
ANN(II)=ANN(II)+AVN
IF(JJ.EQ.0) THEN
ATT(II)=ATT(II)-PJI*DSBPST(J,ID)
ANN(II)=ANN(II)-PJI*DSBPSN(J,ID)
END IF
END IF
IF(J.NE.NREFI.AND.JJ.GT.0.AND.ILTLEV(J).LE.0.
* and.iabs(imodl(i)).ne.4) THEN
ATT(JJ)=ATT(JJ)-AVT
ANN(JJ)=ANN(JJ)-AVN
IF(II.EQ.0) THEN
PIJ=POPI*(RRU(ITR,ID)+COLRAT(ITR,ID))
ATT(JJ)=ATT(JJ)-PIJ*DSBPST(I,ID)
ANN(JJ)=ANN(JJ)-PIJ*DSBPSN(I,ID)
END IF
END IF
230 CONTINUE
END IF
C
C simple expressions in the case of LTE
C
LLT=LTE.OR.ID.GE.IDLTE
DO IAT=1,NATOM
DO I=N0A(IAT),NKA(IAT)
II=IABS(IIEXP(I))
IF(II.NE.0.AND.I.NE.NREFS(IAT,ID)) THEN
IF(LLT.OR.ILTION(IEL(I)).GE.1.OR.ILTLEV(I).GE.1) THEN
ATT(II)=ATT(II)-POPUL(I,ID)*DSBPST(I,ID)
ANN(II)=ANN(II)-POPUL(I,ID)*DSBPSN(I,ID)
END IF
END IF
END DO
END DO
C
C
C b) contribution to AT and AN (and AM - for total particle density)
C from the abundance definition equations
C
DO IAT=1,NATOM
IF(IIFIX(IAT).NE.1) THEN
NREFII=IABS(IIEXP(NREFS(IAT,ID)))
IF(NREFII.NE.0) THEN
DO I=N0A(IAT),NKA(IAT)
IL=ILK(I)
II=IIEXP(I)
IF(IL.EQ.0) THEN
IF(II.EQ.0) THEN
ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DSBPST(I,ID)
ANN(NREFII)=ANN(NREFII)+POPUL(I,ID)*DSBPSN(I,ID)
END IF
ELSE
ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DUSUMT(IL)*ANE
ANN(NREFII)=ANN(NREFII)+
* POPUL(I,ID)*(USUM(IL)+ANE*DUSUMN(IL))
END IF
END DO
if(ifmol.eq.0.or.t.gt.tmolim) then
ANN(NREFII)=ANN(NREFII)+UN/YTOT(ID)*ABUND(IAT,ID)
AM(NREFII)=AM(NREFII)-UN/YTOT(ID)*ABUND(IAT,ID)
end if
END IF
END IF
END DO
C
C -----------------------
C Having evaluated auxiliary vectors AT, AN, AM, we may now set up
C the columns corresponding to temperature, el.density, and total
C particle number density
C
DO I=1,NLVEXP
IF(IFPOPR.LE.3) THEN
AVT=0.
AVN=0.
AVM=0.
DO J=1,NLVEXP
AVT=AVT-ESEMAT(I,J)*ATT(J)
AVN=AVN-ESEMAT(I,J)*ANN(J)
AVM=AVM-ESEMAT(I,J)*AM(J)
END DO
ELSE
AVT=ATT(I)
AVN=ANN(I)
AVM=AM(I)
END IF
IF(INHE.NE.0) B(NSE+I,NFREQE+INHE)=B(NSE+I,NFREQE+INHE)+AVM
IF(INRE.NE.0) B(NSE+I,NFREQE+INRE)=B(NSE+I,NFREQE+INRE)+AVT
IF(INPC.NE.0) B(NSE+I,NFREQE+INPC)=B(NSE+I,NFREQE+INPC)+AVN
END DO
C
C Columns corresponding to populations
C
400 CONTINUE
IF(IFPOPR.LE.3) THEN
DO I=1,NLVEXP
B(NSE+I,NSE+I)=B(NSE+I,NSE+I)-UN
IF(IABS(IFPOPR).GE.3) THEN
SUM=0.
DO J=1,NLVEXP
SUM=SUM+ESEMAT(I,J)*BESE(J)
END DO
VECL(NSE+I)=POPGRP(I)-SUM
END IF
END DO
ELSE IF(IFPOPR.LE.5) THEN
DO I=1,NLVEXP
SUM=0.
DO J=1,NLVEXP
SUM=SUM+ESEMAT(I,J)*POPGRP(J)
B(NSE+I,NSE+J)=B(NSE+I,NSE+J)+ESEMAT(I,J)
END DO
VECL(NSE+I)=BESE(I)-SUM
END DO
END IF
RETURN
END
tlusty/extracted/bre.f
+301
View File
@@ -0,0 +1,301 @@
SUBROUTINE BRE(ID)
C ==================
C
C The part of matrices A and B corresponding to the radiative
C equilibrium equation
C i.e. the (NFREQE+INRE)-th row
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
DIMENSION REXB(MLEVEL)
EQUIVALENCE (REX(1),REXB(1))
C
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NMP=NFREQE+INMP
NSE=NFREQE+INSE-1
IJ1=1
if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) IJ1=2
C
ittc=abs(nretc)/100
if(iter.gt.ittc) then
if(id.le.mod(abs(nretc),100)) then
b(nre,nre)=1.
if(nretc.lt.0) then
c(nre,nre)=-1.
vecl(nre)=temp(id+1)-temp(id)
end if
return
end if
end if
C
C the rhs vector accounts for total net cooling in ALI
C transitions (FCOOL)
C
VECL(NRE)=FCOOL(ID)
IF(IDISK.EQ.1) VECL(NRE)=FCOOL(ID)-reint(id)*TVISC(ID)
if(reint(id).le.0) go to 100
C
C ********* integral equation part of the radiative
C equilibrium equation
C
BREPC=0.
BREMP=0.
DO I=1,NLVEXP
REXB(I)=0.
END DO
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
BREPC=BREPC+((DABN0(IJ)-SIGEC(IJT))*RAD0(IJ)-
* DEMN0(IJ))*WDEP0(IJ)
BREMP=BREMP+(DABM0(IJ)*RAD0(IJ)-DEMM0(IJ))*WDEP0(IJ)
DO I=1,NLVEXP
REXB(I)=REXB(I)+(DRCH0(I,IJ)*RAD0(IJ)-
* DRET0(I,IJ))*WDEP0(IJ)
END DO
B(NRE,NRE)=B(NRE,NRE)+(DABT0(IJ)*RAD0(IJ)-
* DEMT0(IJ))*WDEP0(IJ)*reint(id)
HEAT=ABSO0(IJ)-SCAT0(IJ)
B(NRE,IJ)=WDEP0(IJ)*HEAT*reint(id)
VECL(NRE)=VECL(NRE)-(HEAT*RAD0(IJ)-EMIS0(IJ))*WDEP0(IJ)*
* reint(id)
c
c additional terms for Compton scattering
c
if(icompt.gt.5) then
ijt=ijfr(ij)
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
vecl(nre)=vecl(nre)+abso0(ij)*cms*wdep0(ij)*reint(id)
if(icompt.gt.6) then
if(icmdra.gt.0) then
b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*wdep0(ij)*reint(id)
else
b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*reint(id)
end if
iji=nfreq-kij(ijt)+1
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) then
if(icmdra.gt.0) then
b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*wdep0(ij)*reint(id)
else
b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*reint(id)
end if
end if
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) then
if(icmdra.gt.0) then
b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*wdep0(ij)*reint(id)
else
b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*reint(id)
end if
end if
end if
b(nre,nre)=b(nre,nre)-cmd*abso0(ij)*wdep0(ij)*reint(id)
b(nre,npc)=b(nre,npc)-cms*abso0(ij)/elec(id)*wdep0(ij)*
* reint(id)
end if
end if
C
END DO
END IF
C
C corrections for ALI frequency points
C
B(NRE,NRE)=B(NRE,NRE)+REIT(ID)*reint(id)
IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id)
IF(INMP.GT.0) B(NRE,NMP)=B(NRE,NMP)+(BREMP+REIM(ID))*reint(id)
IF(INHE.GT.0) B(NRE,NHE)=REIX(ID)*reint(id)
IF(IFALI.GT.5) THEN
A(NRE,NRE)=AREIT(ID)*reint(id)
IF(INPC.GT.0) A(NRE,NPC)=AREIN(ID)*reint(id)
IF(INMP.GT.0) A(NRE,NMP)=AREIM(ID)*reint(id)
C(NRE,NRE)=CREIT(ID)*reint(id)
IF(INPC.GT.0) C(NRE,NPC)=CREIN(ID)*reint(id)
IF(INMP.GT.0) C(NRE,NMP)=CREIM(ID)*reint(id)
IF(INHE.GT.0) C(NRE,NHE)=CREIX(ID)*reint(id)
END IF
C
C additional terms for disks because of viscosity
C
IF(IDISK.EQ.1) THEN
B(NRE,NRE)=B(NRE,NRE)+DTVIST(ID)*reint(id)
IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)-DTVISR(ID)*reint(id)
IF(INHE.GT.0) B(NRE,NFREQE+INHE)=
* (DTVISR(ID)+DTVISN(ID))*reint(id)
IF(INMP.GT.0) B(NRE,NFREQE+INMP)=
* DTVISR(ID)*HMASS/WMM(ID)*reint(id)
END IF
C
DO II=1,NLVEXP
B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REIP(II,ID))*reint(id)
END DO
IF(IFALI.GT.5.AND.ID.GT.1) THEN
DO II=1,NLVEXP
A(NRE,NSE+II)=A(NRE,NSE+II)+AREIP(II,ID)*reint(id)
END DO
END IF
IF(IFALI.GT.5.AND.ID.LT.ND) THEN
DO II=1,NLVEXP
C(NRE,NSE+II)=C(NRE,NSE+II)+CREIP(II,ID)*reint(id)
END DO
END IF
C
C ********* differential equation part of the
C radiative equilibrium equation
C
100 CONTINUE
if(redif(id).eq.0) return
C
TEFFD=TEFF**4
IF(IDISK.EQ.1) TEFFD=TEFF**4*(UN-THETAV(ID))
VECL(NRE)=VECL(NRE)+SIG4P*TEFFD*redif(id)
c
if(id.eq.1) go to 200
C
DDM=(DM(ID)-DM(ID-1))*HALF
AREN=0.
BREN=0.
AREPC=0.
BREPC=0.
C
GP=0.
GN=UN
IF(INMP.GT.0) THEN
GP=UN
GN=0.
END IF
C
DO I=1,NLVEXP
REXB(I)=0.
REXA(I)=0.
END DO
C
IF(NFREQE.GT.0) THEN
DO IJ=1,NFREQE
OMEG0=ABSO0(IJ)*DENS1(ID)
OMEGM=ABSOM(IJ)*DENS1(ID-1)
DTAUM=(OMEG0+OMEGM)*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAMR=FRD/DTAUM
A1=GAMR/(OMEG0+OMEGM)
A3R=A1*DENS1(ID-1)*WDEP0(IJ)
B3R=A1*DENS1(ID)*WDEP0(IJ)
C
C Corresponding elements of matrix A
C
A(NRE,IJ)=-WDEP0(IJ)*FKM(IJ)/DTAUM*redif(id)
RTR=OMEGM*WMM(ID-1)*A3R
AREN=AREN+RTR*GN
AREPC=AREPC-A3R*DABNM(IJ)-RTR*GN
IF(INMP.NE.0) A(NRE,NFREQE+INMP)=A(NRE,NFREQE+INMP)+RTR*GP*
* redif(id)
A(NRE,NRE)=A(NRE,NRE)-A3R*DABTM(IJ)*redif(id)
C
C Corresponding elements of matrix B
C Columns corresponding to mean intensities
C
B(NRE,IJ)=B(NRE,IJ)+WDEP0(IJ)*FK0(IJ)/DTAUM*redif(id)
RTR=OMEG0*WMM(ID)*B3R
BREN=BREN+RTR*GN
BREPC=BREPC-B3R*DABN0(IJ)-RTR*GN
IF(INMP.NE.0) B(NRE,NFREQE+INMP)=B(NRE,NFREQE+INMP)+
* (RTR+REDX(ID))*GP*redif(id)
C
C Column corresponding to temperature
C
B(NRE,NRE)=B(NRE,NRE)-B3R*DABT0(IJ)*redif(id)
C
C auxiliary vectors for columns corresponding to populations
C
DO I=1,NLVEXP
REXA(I)=REXA(I)-A3R*DRCHM(I,IJ)
REXB(I)=REXB(I)-B3R*DRCH0(I,IJ)
END DO
C
C The rhs vector
C
VECL(NRE)=VECL(NRE)-WDEP0(IJ)*GAMR*redif(id)
END DO
END IF
C
C Column corresponding to N (total particle number density)
C for both A and B matrices
C
IF(INHE.NE.0) THEN
A(NRE,NFREQE+INHE)=(AREN+REDXM(ID))*redif(id)
B(NRE,NFREQE+INHE)=B(NRE,NFREQE+INHE)+(BREN+REDX(ID))*redif(id)
END IF
C
C Column corresponding to temperature
C
A(NRE,NRE)=A(NRE,NRE)+REDTM(ID)*REDIF(ID)
B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID)
C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID)
C
C Column corresponding to electron density (for matrices A and B)
C
IF(INPC.NE.0) THEN
A(NRE,NPC)=A(NRE,NPC)+(AREPC+REDNM(ID)-REDXM(ID))*redif(id)
B(NRE,NPC)=B(NRE,NPC)+(BREPC+REDN(ID)-REDX(ID))*redif(id)
C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id)
END IF
C
C Columns corresponding to populations (for matrices A and B)
C Note that auxiliary arrays REXA and REX, which contain derivatives
C of the absorption and emission coefficients wrt populations, have
C been generated by BRTE
C
DO II=1,NLVEXP
A(NRE,NSE+II)=A(NRE,NSE+II)+(REXA(II)+REDPM(II,ID))*redif(id)
B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REDP(II,ID))*redif(id)
C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id)
END DO
RETURN
c
C upper boundary condition for the differential form
c
200 CONTINUE
C
C Columns corresponding to mean intensities; rhs vector
C
IF(NFREQE.GT.0) THEN
DO IJ=1,NFREQE
IJT=IJFR(IJ)
WF=WDEP0(IJ)*FH(IJT)*REDIF(ID)
B(NRE,IJ)=B(NRE,IJ)+WF
VECL(NRE)=VECL(NRE)-WF*RAD0(IJ)-WDEP0(IJ)*HEXTRD(IJT)*
* REDIF(ID)
END DO
END IF
C
C Column corresponding to temperature
C
B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID)
C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID)
C
C Column corresponding to N and electron density
C
IF(INHE.NE.0) B(NRE,NHE)=B(NRE,NHE)+REDX(ID)*redif(id)
IF(INPC.NE.0) B(NRE,NPC)=B(NRE,NPC)+REDN(ID)*redif(id)
IF(INHE.NE.0) C(NRE,NHE)=C(NRE,NHE)+REDXP(ID)*redif(id)
IF(INPC.NE.0) C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id)
C
C Columns corresponding to populations
C
DO II=1,NLVEXP
B(NRE,NSE+II)=B(NRE,NSE+II)+REDP(II,ID)*redif(id)
C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id)
END DO
RETURN
END
tlusty/extracted/brez.f
+273
View File
@@ -0,0 +1,273 @@
SUBROUTINE BREZ(ID)
C ===================
C
C The part of matrices A and B corresponding to the radiative
C equilibrium equation
C i.e. the (NFREQE+INRE)-th row
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
DIMENSION REXB(MLEVEL)
EQUIVALENCE (REX(1),REXB(1))
C
NRE=NFREQE+INRE
NHE=NFREQE+INHE
NPC=NFREQE+INPC
NMP=NFREQE+INMP
NSE=NFREQE+INSE-1
IJ1=1
if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) IJ1=2
C
ittc=abs(nretc)/100
if(iter.gt.ittc) then
if(id.le.mod(abs(nretc),100)) then
b(nre,nre)=1.
if(nretc.lt.0) then
c(nre,nre)=-1.
vecl(nre)=temp(id+1)-temp(id)
end if
return
end if
end if
C
C the rhs vector accounts for total net cooling in ALI
C transitions (FCOOL)
C
VECL(NRE)=FCOOL(ID)-reint(id)*TVISC(ID)
if(reint(id).le.0) go to 100
C
C ********* integral equation part of the radiative
C equilibrium equation
C
BREPC=0.
BREMP=0.
DO I=1,NLVEXP
REXB(I)=0.
END DO
IF(NFREQE.GT.0) THEN
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
BREPC=BREPC+((DABN0(IJ)-SIGEC(IJT))*RAD0(IJ)-
* DEMN0(IJ))*WDEP0(IJ)
BREMP=BREMP+(DABM0(IJ)*RAD0(IJ)-DEMM0(IJ))*WDEP0(IJ)
DO I=1,NLVEXP
REXB(I)=REXB(I)+(DRCH0(I,IJ)*RAD0(IJ)-
* DRET0(I,IJ))*WDEP0(IJ)
END DO
B(NRE,NRE)=B(NRE,NRE)+(DABT0(IJ)*RAD0(IJ)-
* DEMT0(IJ))*WDEP0(IJ)*reint(id)
HEAT=ABSO0(IJ)-SCAT0(IJ)
B(NRE,IJ)=WDEP0(IJ)*HEAT*reint(id)
VECL(NRE)=VECL(NRE)-(HEAT*RAD0(IJ)-EMIS0(IJ))*WDEP0(IJ)*
* reint(id)
c
c additional terms for Compton scattering
c
if(icompt.gt.5) then
ijt=ijfr(ij)
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
vecl(nre)=vecl(nre)+abso0(ij)*cms*wdep0(ij)*reint(id)
if(icompt.gt.6) then
if(icmdra.gt.0) then
b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*wdep0(ij)*reint(id)
else
b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*reint(id)
end if
iji=nfreq-kij(ijt)+1
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) then
if(icmdra.gt.0) then
b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*wdep0(ij)*reint(id)
else
b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*reint(id)
end if
end if
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) then
if(icmdra.gt.0) then
b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*wdep0(ij)*reint(id)
else
b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*reint(id)
end if
end if
end if
b(nre,nre)=b(nre,nre)-cmd*abso0(ij)*wdep0(ij)*reint(id)
b(nre,npc)=b(nre,npc)-cms*abso0(ij)/elec(id)*wdep0(ij)*
* reint(id)
end if
end if
C
END DO
END IF
C
C corrections for ALI frequency points
C
B(NRE,NRE)=B(NRE,NRE)+REIT(ID)*reint(id)
IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id)
IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id)
IF(INMP.GT.0) B(NRE,NMP)=B(NRE,NMP)+(BREMP+REIM(ID))*reint(id)
IF(INHE.GT.0) B(NRE,NHE)=REIX(ID)*reint(id)
A(NRE,NRE)=AREIT(ID)*reint(id)
IF(INPC.GT.0) A(NRE,NPC)=AREIN(ID)*reint(id)
C(NRE,NRE)=CREIT(ID)*reint(id)
IF(INPC.GT.0) C(NRE,NPC)=CREIN(ID)*reint(id)
IF(INMP.GT.0) C(NRE,NMP)=CREIM(ID)*reint(id)
IF(INHE.GT.0) C(NRE,NHE)=CREIX(ID)*reint(id)
c END IF
C
C terms arising because of viscosity
C
B(NRE,NRE)=B(NRE,NRE)+DTVIST(ID)*reint(id)
IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)-DTVISR(ID)*reint(id)
IF(INHE.GT.0) B(NRE,NFREQE+INHE)=
* (DTVISR(ID)+DTVISN(ID))*reint(id)
IF(INMP.GT.0) B(NRE,NFREQE+INMP)=
* DTVISR(ID)*HMASS/WMM(ID)*reint(id)
C
DO II=1,NLVEXP
B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REIP(II,ID))*reint(id)
END DO
IF(IFALI.GT.5.AND.ID.GT.1) THEN
DO II=1,NLVEXP
A(NRE,NSE+II)=A(NRE,NSE+II)+AREIP(II,ID)*reint(id)
END DO
END IF
IF(IFALI.GT.5.AND.ID.LT.ND) THEN
DO II=1,NLVEXP
C(NRE,NSE+II)=C(NRE,NSE+II)+CREIP(II,ID)*reint(id)
END DO
END IF
C
C ********* differential equation part of the
C radiative equilibrium equation
C
100 CONTINUE
if(redif(id).eq.0) return
C
TEFFD=TEFF**4*(UN-THETAV(ID))
VECL(NRE)=VECL(NRE)+SIG4P*TEFFD*redif(id)
if(id.eq.1) go to 200
C
DDM=(ZD(ID-1)-ZD(ID))*HALF
AREN=0.
BREN=0.
AREPC=0.
BREPC=0.
C
GP=0.
GN=UN
IF(INMP.GT.0) THEN
GP=UN
GN=0.
END IF
C
DO I=1,NLVEXP
REXB(I)=0.
REXA(I)=0.
END DO
C
IF(NFREQE.GT.0) THEN
DO IJ=1,NFREQE
OMEG0=ABSO0(IJ)
OMEGM=ABSOM(IJ)
DTAUM=(OMEG0+OMEGM)*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAMR=FRD/DTAUM
A1=GAMR/(OMEG0+OMEGM)*WDEP0(IJ)
C
C Corresponding elements of matrix A
C
A(NRE,IJ)=-WDEP0(IJ)*FKM(IJ)/DTAUM*redif(id)
AREPC=AREPC-A1*DABNM(IJ)
A(NRE,NRE)=A(NRE,NRE)-A1*DABTM(IJ)*redif(id)
C
C Corresponding elements of matrix B
C Columns corresponding to mean intensities
C
B(NRE,IJ)=B(NRE,IJ)+WDEP0(IJ)*FK0(IJ)/DTAUM*redif(id)
BREPC=BREPC-A1*DABN0(IJ)
C
C Column corresponding to temperature
C
B(NRE,NRE)=B(NRE,NRE)-A1*DABT0(IJ)*redif(id)
C
C auxiliary vectors for columns corresponding to populations
C
DO I=1,NLVEXP
REXA(I)=REXA(I)-A1*DRCHM(I,IJ)
REXB(I)=REXB(I)-A1*DRCH0(I,IJ)
END DO
C
C The rhs vector
C
VECL(NRE)=VECL(NRE)-WDEP0(IJ)*GAMR*redif(id)
END DO
END IF
C
C Column corresponding to temperature
C
A(NRE,NRE)=A(NRE,NRE)+REDTM(ID)*REDIF(ID)
B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID)
C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID)
C
C Column corresponding to electron density (for matrices A and B)
C
IF(INPC.NE.0) THEN
A(NRE,NPC)=A(NRE,NPC)+(AREPC+REDNM(ID))*redif(id)
B(NRE,NPC)=B(NRE,NPC)+(BREPC+REDN(ID))*redif(id)
C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id)
END IF
C
C Columns corresponding to populations (for matrices A and B)
C Note that auxiliary arrays REXA and REX, which contain derivatives
C of the absorption and emission coefficients wrt populations, have
C been generated by BRTE
C
DO II=1,NLVEXP
A(NRE,NSE+II)=A(NRE,NSE+II)+(REXA(II)+REDPM(II,ID))*redif(id)
B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REDP(II,ID))*redif(id)
C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id)
END DO
RETURN
c
C upper boundary condition for the differential form
c
200 CONTINUE
C
C Columns corresponding to mean intensities; rhs vector
C
IF(NFREQE.GT.0) THEN
DO IJ=1,NFREQE
IJT=IJFR(IJ)
WF=WDEP0(IJ)*FH(IJT)*REDIF(ID)
B(NRE,IJ)=B(NRE,IJ)+WF
VECL(NRE)=VECL(NRE)-WF*RAD0(IJ)
END DO
END IF
C
C Column corresponding to temperature
C
B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID)
C
C Column corresponding to electron density
C
IF(INPC.NE.0) THEN
B(NRE,NPC)=B(NRE,NPC)+REDN(ID)*redif(id)
END IF
C
C Columns corresponding to populations
C
DO II=1,NLVEXP
B(NRE,NSE+II)=B(NRE,NSE+II)+REDP(II,ID)*redif(id)
END DO
RETURN
END
tlusty/extracted/brte.f
+618
View File
@@ -0,0 +1,618 @@
SUBROUTINE BRTE(ID)
C ===================
C
C The part of matrices A,B,C corresponding to the linearized
C radiative transfer equation
C i.e. the first NFREQE rows
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10)
PARAMETER (SIXTH=UN/6.D0,
* THIRD=UN/3.D0)
C
IF(NFREQE.LE.0) RETURN
ispl=isplin
if(isplin.ge.5) isplin=isplin-5
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NSE=NFREQE+INSE-1
NMP=NFREQE+INMP
C
GP=0.
GN=UN
IF(INMP.GT.0) THEN
GP=UN
GN=0.
END IF
c
c in the case of Compton scattering - boundary condition
c for the highest frequency
C
IJ1=1
if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) then
IJ1=2
ij=1
iji=nfreq
zj1=exp(-hk*freq(ij)/temp(id))
zj2=exp(-hk*freq(ij+1)/temp(id))
dlt=delj(iji-1,id)
if(ichcoo.eq.0) then
zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id))
zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2
combid=zj0/dlnfr(iji-1)+(un-dlt)*zxx
comaid=-zj0/dlnfr(iji-1)+dlt*zxx
else
e2=ycon*temp(id)
zxx0=xcon*freq(ij)*(un+zj1)-3.*e2
zxxm=xcon*freq(ij+1)*(un+zj2)-3.*e2
zxx=(un-dlt)*zxx0+dlt*zxxm
combid=e2/dlnfr(iji-1)+(un-dlt)*zxx
comaid=-e2/dlnfr(iji-1)+dlt*zxx
end if
b(ij,ij)=combid
b(ij,ij+1)=comaid
vecl(ij)=-b(ij,ij)*rad(iji,id)-b(ij,ij+1)*rad(iji-1,id)
end if
C
C ----------------------------------------
C For ID = 1 - upper boundary condition
C ----------------------------------------
C
IF(ID.GT.1) GO TO 50
DDP=(DM(2)-DM(1))*HALF
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
OMEG0=ABSO0(IJ)/DENS(ID)
OMEGP=ABSOP(IJ)/DENS(ID+1)
DZP=OMEG0+OMEGP
DTAUP=DZP*DDP
ALF1=(FK0(IJ)*RAD0(IJ)-FKP(IJ)*RADP(IJ))/DTAUP
CHIEL0=SCAT0(IJ)
CHIELP=SCATP(IJ)
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
BS=HALF*DTAUP
CS=0.
C2=0.
GAM2=0.
BET2=0.
SP=0.
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
IF(MOD(ISPLIN,3).GT.0) THEN
C
C Spline collocation and/or Hermitian method (ISPLIN=1 or 2) -
C both give the same expression for the boundary conditions
C
BS=DTAUP*THIRD
CS=HALF *BS
SP=(EMISP(IJ)+CHIELP*RADP(IJ))/ABSOP(IJ)
C2=CS/ABSOP(IJ)
GAM2=CS*(RADP(IJ)-SP)
END IF
C
C auxiliary quantities
C
ALF2=BS*(RAD0(IJ)-S0)
BET2=ALF2+GAM2
X1=(ALF1-BET2)/DZP
B2=(BS+Q0(IJT))/ABSO0(IJ)
B1=X1/DENS(1)
B1=B1+UU0(IJT)*S0*DM(1)*HALF/DENS(1)
C1=X1/DENS(2)
C
C *** elements of the IJ-th row of matrices B and C
C
RTN=OMEG0*WMM(1)*B1
B(IJ,NHE)=-GN*RTN
B1=B1-B2*S0
C
RTNC=OMEGP*WMM(2)*C1
C(IJ,NHE)=-GN*RTNC
C1=C1-C2*SP
C
B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
C(IJ,NRE)=C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ))
B(IJ,NPC)=B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+
* GN*RTN
C(IJ,NPC)=C1*DABNP(IJ)+
* C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))+
* GN*RTNC
B(IJ,NMP)=B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
C(IJ,NMP)=C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC
DO II=1,NLVEXP
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
C(IJ,NSE+II)=C(IJ,NSE+II)+
* C1*DRCHP(II,IJ)+C2*DRETP(II,IJ)
END DO
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAUP-FH(IJT)-BS*(UN-CHIEL0/ABSO0(IJ))
* +Q0(IJT)*CHIEL0/ABSO0(IJ)
C(IJ,NFREQE)=0.
C(IJ,IJ)=FKP(IJ)/DTAUP-CS*(UN-CHIELP/ABSOP(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=ALF1+BET2+FH(IJT)*RAD0(IJ)
* -S0*Q0(IJT)
IF(IWINBL.LT.0) VECL(IJ)=VECL(IJ)-HEXTRD(IJT)
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
isplin=ispl
go to 500
C
C ---------------------------------------
C For 1 < ID < ND - normal depth point
C ---------------------------------------
C
50 DDM=(DM(ID)-DM(ID-1))*HALF
IF(ID.EQ.ND) GO TO 150
DDP=(DM(ID+1)-DM(ID))*HALF
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
OMEG0=ABSO0(IJ)/DENS(ID)
OMEGP=ABSOP(IJ)/DENS(ID+1)
OMEGM=ABSOM(IJ)/DENS(ID-1)
DZP=OMEG0+OMEGP
DZM=OMEG0+OMEGM
DTAUP=DZP*DDP
DTAUM=DZM*DDM
DTAU0=HALF *(DTAUP+DTAUM)
FRD=FK0(IJ)*RAD0(IJ)
ALF1=(FRD-FKP(IJ)*RADP(IJ))/DTAUP/DTAU0
GAM1=(FRD-FKM(IJ)*RADM(IJ))/DTAUM/DTAU0
BET1=ALF1+GAM1
X1=HALF *BET1/DTAU0
A1=(GAM1+X1*DTAUM)/DZM
C1=(ALF1+X1*DTAUP)/DZP
B1=(A1+C1)/DENS(ID)
A1=A1/DENS(ID-1)
C1=C1/DENS(ID+1)
BS=UN
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
CHIELP=SCATP(IJ)
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
AS=0.
CS=0.
A2=0.
C2=0.
A3=0.
C3=0.
BET2=0.
SM=0.
SP=0.
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
IF(MOD(ISPLIN,3).EQ.0) GO TO 60
SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ)
SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ)
IF(ISPLIN.EQ.1) THEN
C
C spline collocation (ISPLIN=1)
C
AS=DTAUM/DTAU0*SIXTH
CS=DTAUP/DTAU0*SIXTH
BS=0.666666666666667D0
ALF2=AS*(RADM(IJ)-SM)
GAM2=CS*(RADP(IJ)-SP)
BET2=ALF2+GAM2
X =HALF *BET2/DTAU0
A2=(GAM2-X*DTAUM)/DZM
C2=(ALF2-X*DTAUP)/DZP
ELSE
C
C Hermitian method (ISPLIN=2)
C
AS=DTAUP*DTAUP/DTAUM/DTAU0
CS=DTAUM*DTAUM/DTAUP/DTAU0
AL3=(RADP(IJ)-SP-RAD0(IJ)+S0)*SIXTH
GA3=(RADM(IJ)-SM-RAD0(IJ)+S0)*SIXTH
AV=AL3*CS
CV=GA3*AS
AS=(UN-HALF *AS)*SIXTH
CS=(UN-HALF *CS)*SIXTH
BS=UN-AS-CS
X=(AV+CV)/DTAU0/4.D0
A2=(X*DTAUM+HALF *CV-AV)/DZM
C2=(X*DTAUP+HALF *AV-CV)/DZP
BET2=AS*(RADM(IJ)-SM)+CS*(RADP(IJ)-SP)
END IF
C
C auxiliary quantities
C
B1=B1-(A2+C2)/DENS(ID)
A1=A1-A2/DENS(ID-1)
C1=C1-C2/DENS(ID+1)
A2=AS/ABSOM(IJ)
C2=CS/ABSOP(IJ)
A3=A2*SM
C3=C2*SP
60 B2=BS/ABSO0(IJ)
B3=B2*S0
C
C *** elements of the IJ-th row of matrices A, B, and C
C
RTNA=OMEGM*WMM(ID-1)*A1
A(IJ,NHE)=-GN*RTNA
A1=A1-A3
C
RTN=OMEG0*WMM(ID)*B1
B(IJ,NHE)=-GN*RTN
B1=B1-B3
C
RTNC=OMEGP*WMM(ID+1)*C1
C(IJ,NHE)=-GN*RTNC
C1=C1-C3
C
A(IJ,NRE)= A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))
B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
C(IJ,NRE)= C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ))
A(IJ,NPC)= A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+
* GN*RTNA
B(IJ,NPC)= B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+
* GN*RTN
C(IJ,NPC)= C1*DABNP(IJ)+
* C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))+
* GN*RTNC
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
C(IJ,NMP)= C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC
DO II=1,NLVEXP
A(IJ,NSE+II)=A(IJ,NSE+II)+
* A1*DRCHM(II,IJ)+A2*DRETM(II,IJ)
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
C(IJ,NSE+II)=C(IJ,NSE+II)+
* C1*DRCHP(II,IJ)+C2*DRETP(II,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM/DTAU0-AS*(UN-CHIELM/ABSOM(IJ))
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAU0*(UN/DTAUP+UN/DTAUM)-
* BS*(UN-CHIEL0/ABSO0(IJ))
C(IJ,NFREQE)=0.
C(IJ,IJ)=FKP(IJ)/DTAUP/DTAU0-CS*(UN-CHIELP/ABSOP(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=BET1+BET2+BS*(RAD0(IJ)-S0)
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
isplin=ispl
go to 500
C
C --------------------------------------
C For ID=ND - lower boundary condition
C --------------------------------------
C
150 CONTINUE
IF(IDISK.EQ.0.OR.IFZ0.LT.0) THEN
T=TEMP(ID)
TM=TEMP(ID-1)
IF(TEMPBD.NE.0.) THEN
T=TEMPBD
TM=T
END IF
HKT=HK/T
HKTM=HK/TM
C
C auxiliary quantites
C
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
OMEGM=ABSOM(IJ)/DENS(ID-1)
OMEG0=ABSO0(IJ)/DENS(ID)
DZM=OMEG0+OMEGM
DTAUM=DZM*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAM1=FRD/DTAUM
A1=GAM1/DZM
AS=0.
BS=0.
A2=0.
B2=0.
A3=0.
B3=0.
ALF2=0.
BET2=0.
GAM2=0.
C
C second-order boundary condition
C
IF(IBC.GT.0.AND.IBC.LT.4) THEN
BS=DTAUM*HALF
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
GAM2=BS*(RAD0(IJ)-S0)
BET2=GAM2
X1=BET2/DZM
A1=A1-X1
B2=BS/ABSO0(IJ)
B3=B2*S0
END IF
C
C auxiliary parameters
C
FR=FREQ(IJT)
FR15=FR*1.D-15
X=HKT*FR
EX=EXP(X)
XM=HKTM*FR
EXM=EXP(XM)
PLAN=BN*FR15*FR15*FR15/(EX-UN)*RRDIL
IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN
PLANM=BN*FR15*FR15*FR15/(EXM-UN)*RRDIL
GAM3=(PLAN-PLANM)/DTAUM*THIRD
A1=A1-GAM3/DZM
GAM1=GAM1-GAM3
END IF
C1=A1
A1=C1/DENS(ID-1)
B1=C1/DENS(ID)
C
C *** elements of the IJ-th row of matrices A and B
C
RTNA=OMEGM*WMM(ID-1)*A1
A(IJ,NHE)=-GN*RTNA
A1=A1-A3
C
RTN=OMEG0*WMM(ID)*B1
B(IJ,NHE)=-GN*RTN
B1=B1-B3
C
DPLANM=PLANM*XM/TM/(UN-UN/EXM)
A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))-
* DPLANM/DTAUM*THIRD
A(IJ,NPC)=A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+
* GN*RTNA
BB=HALF+THIRD/DTAUM
DPLAN=PLAN*X/T/(UN-UN/EX)
B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))+
* BB*DPLAN
B(IJ,NPC)= B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+
* GN*RTN
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
DO II=1,NLVEXP
A(IJ,NSE+II)=A(IJ,NSE+II)+
* A1*DRCHM(II,IJ)+A2*DRETM(II,IJ)
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ))
B(IJ,NFREQE)=0.
C
C *** the IJ-th element of the rhs vector
C
IF(IBC.EQ.0.OR.IBC.EQ.4) THEN
B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM-
* BS*(UN-CHIEL0/ABSO0(IJ))-HALF
VECL(IJ)=GAM1+BET2-HALF*(PLAN-RAD0(IJ))
ELSE
B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM-
* BS*(UN-CHIEL0/ABSO0(IJ))-FHD(IJT)
VECL(IJ)=GAM1+BET2-HALF*PLAN+FHD(IJT)*RAD0(IJ)
END IF
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
C
ELSE
C
C --------------------------------------
C For ID=ND - lower boundary condition
C --------------------------------------
C
C for disks -
C lower b.c. expresses just I(taumax,-mu,nu)=I(taumax,+mu,nu)
C
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
OMEGM=ABSOM(IJ)/DENS(ID-1)
OMEG0=ABSO0(IJ)/DENS(ID)
DZM=OMEG0+OMEGM
DTAUM=DZM*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAM1=FRD/DTAUM
A1=GAM1/DZM
AS=0.
A2=0.
A3=0.
ALF2=0.
GAM2=0.
BS=DTAUM*HALF
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
GAM2=BS*(RAD0(IJ)-S0)
BET2=ALF2+GAM2
X1=BET2/DZM
A1=A1-X1
B2=BS/ABSO0(IJ)
B3=B2*S0
C1=A1
A1=C1/DENS(ID-1)
B1=C1/DENS(ID)
C
C *** elements of the IJ-th row of matrix A
C
RTN=OMEGM*WMM(ID)*A1
A(IJ,NHE)=-GN*RTN
A(IJ,NMP)=-GP*RTN
A1=A1-A3
A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))
A(IJ,NPC)=A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+
* GN*RTN
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
DO I=1,NLVEXP
A(IJ,NSE+I)=A1*DRCHM(I,IJ)+A2*DRETM(I,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ))
C
C *** elements of the IJ-th row of matrix B
C
RTN=OMEG0*WMM(ID)*B1
B(IJ,NHE)=-GN*RTN
B(IJ,NMP)=-GP*RTN
B1=B1-B3
B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
B(IJ,NPC)=B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+
* GN*RTN
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
DO I=1,NLVEXP
B(IJ,NSE+I)=B1*DRCH0(I,IJ)+B2*DRET0(I,IJ)
END DO
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAUM-BS*(UN-CHIEL0/ABSO0(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=GAM1+BET2
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
END IF
isplin=ispl
500 CONTINUE
c
c zeroing radiation field for very low intensities (if required)
c
if(radzer.gt.0) then
c
C find the peak in nu*rad_nu:
c
radsum=0.
DO IJ=IJ1,NFREQE
radsum=max(freq(ij)*radex(ij,id),radsum)
END DO
C
C if much smaller than peak in nu*rad_nu, then set to zero:
C
DO IJ=IJ1,NFREQE
if(freq(ij)*radex(ij,id).lt.radzer*radsum) then
do ii=1,nn0
a(ij,ii)=0.
b(ij,ii)=0.
c(ij,ii)=0.
end do
vecl(ij)=0.
b(ij,ij)=un
end if
end do
end if
isplin=ispl
isplin=ispl
c
RETURN
END
tlusty/extracted/brtez.f
+574
View File
@@ -0,0 +1,574 @@
SUBROUTINE BRTEZ(ID)
C ====================
C
C The part of matrices A,B,C corresponding to the linearized
C radiative transfer equation
C i.e. the first NFREQE rows
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10)
PARAMETER (SIXTH=UN/6.D0,
* THIRD=UN/3.D0)
C
IF(NFREQE.LE.0) RETURN
ispl=isplin
if(isplin.ge.5) isplin=isplin-5
NHE=NFREQE+INHE
NRE=NFREQE+INRE
NPC=NFREQE+INPC
NSE=NFREQE+INSE-1
NMP=NFREQE+INMP
C
GP=0.
GN=UN
IF(INMP.GT.0) THEN
GP=UN
GN=0.
END IF
c
c in the case of Compton scattering - boundary condition
c for the highest frequency
C
IJ1=1
if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) then
IJ1=2
ij=1
iji=nfreq
zj1=exp(-hk*freq(ij)/temp(id))
zj2=exp(-hk*freq(ij+1)/temp(id))
dlt=delj(iji-1,id)
if(ichcoo.eq.0) then
zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id))
zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2
combid=zj0/dlnfr(iji-1)+(un-dlt)*zxx
comaid=-zj0/dlnfr(iji-1)+dlt*zxx
else
e2=ycon*temp(id)
zxx0=xcon*freq(ij)*(un+zj1)-3.*e2
zxxm=xcon*freq(ij+1)*(un+zj2)-3.*e2
zxx=(un-dlt)*zxx0+dlt*zxxm
combid=e2/dlnfr(iji-1)+(un-dlt)*zxx
comaid=-e2/dlnfr(iji-1)+dlt*zxx
end if
b(ij,ij)=combid
b(ij,ij+1)=comaid
vecl(ij)=-b(ij,ij)*rad(iji,id)-b(ij,ij+1)*rad(iji-1,id)
end if
C
C
C ----------------------------------------
C For ID = 1 - upper boundary condition
C ----------------------------------------
C
IF(ID.GT.1) GO TO 50
DDP=(ZD(1)-ZD(2))*HALF
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
OMEG0=ABSO0(IJ)
OMEGP=ABSOP(IJ)
DZP=OMEG0+OMEGP
DTAUP=DZP*DDP
ALF1=(FK0(IJ)*RAD0(IJ)-FKP(IJ)*RADP(IJ))/DTAUP
CHIEL0=SCAT0(IJ)
CHIELP=SCATP(IJ)
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
BS=HALF*DTAUP
CS=0.
C2=0.
GAM2=0.
BET2=0.
SP=0.
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
IF(MOD(ISPLIN,3).GT.0) THEN
C
C Spline collocation and/or Hermitian method (ISPLIN=1 or 2) -
C both give the same expression for the boundary conditions
C
BS=DTAUP*THIRD
CS=HALF *BS
SP=(EMISP(IJ)+CHIELP*RADP(IJ))/ABSOP(IJ)
C2=CS/ABSOP(IJ)
GAM2=CS*(RADP(IJ)-SP)
END IF
C
C auxiliary quantities
C
ALF2=BS*(RAD0(IJ)-S0)
BET2=ALF2+GAM2
X1=(ALF1-BET2)/DZP
B2=(BS+Q0(IJ))/ABSO0(IJ)
B1=X1
B1=B1+UU0(IJ)*S0*DM(1)/DENS(1)
C1=X1
B1=B1-B2*S0
C1=C1-C2*SP
C
C *** elements of the IJ-th row of matrices B and C
C
B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
C(IJ,NRE)=C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ))
B(IJ,NPC)=B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))
C(IJ,NPC)=C1*DABNP(IJ)+
* C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))
B(IJ,NMP)=B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
C(IJ,NMP)=C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC
DO II=1,NLVEXP
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
C(IJ,NSE+II)=C(IJ,NSE+II)+
* C1*DRCHP(II,IJ)+C2*DRETP(II,IJ)
END DO
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAUP-FH(IJT)-BS*(UN-CHIEL0/ABSO0(IJ))+
* Q0(IJ)*CHIEL0/ABSO0(IJ)
C(IJ,NFREQE)=0.
C(IJ,IJ)=FKP(IJ)/DTAUP-CS*(UN-CHIELP/ABSOP(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=ALF1+BET2+FH(IJT)*RAD0(IJ)-S0*Q0(IJ)
IF(IWINBL.LT.0) VECL(IJ)=VECL(IJ)-HEXTRD(IJT)
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
isplin=ispl
go to 500
C
C ---------------------------------------
C For 1 < ID < ND - normal depth point
C ---------------------------------------
C
50 DDM=(ZD(ID-1)-ZD(ID))*HALF
IF(ID.EQ.ND) GO TO 150
DDP=(ZD(ID)-ZD(ID+1))*HALF
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
OMEG0=ABSO0(IJ)
OMEGP=ABSOP(IJ)
OMEGM=ABSOM(IJ)
DZP=OMEG0+OMEGP
DZM=OMEG0+OMEGM
DTAUP=DZP*DDP
DTAUM=DZM*DDM
DTAU0=HALF *(DTAUP+DTAUM)
FRD=FK0(IJ)*RAD0(IJ)
ALF1=(FRD-FKP(IJ)*RADP(IJ))/DTAUP/DTAU0
GAM1=(FRD-FKM(IJ)*RADM(IJ))/DTAUM/DTAU0
BET1=ALF1+GAM1
X1=HALF *BET1/DTAU0
A1=(GAM1+X1*DTAUM)/DZM
C1=(ALF1+X1*DTAUP)/DZP
B1=A1+C1
BS=UN
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
CHIELP=SCATP(IJ)
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
AS=0.
CS=0.
A2=0.
C2=0.
A3=0.
C3=0.
BET2=0.
SM=0.
SP=0.
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
IF(MOD(ISPLIN,3).EQ.0) GO TO 60
SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ)
SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ)
IF(ISPLIN.EQ.1) THEN
C
C spline collocation (ISPLIN=1)
C
AS=DTAUM/DTAU0*SIXTH
CS=DTAUP/DTAU0*SIXTH
BS=0.666666666666667D0
ALF2=AS*(RADM(IJ)-SM)
GAM2=CS*(RADP(IJ)-SP)
BET2=ALF2+GAM2
X =HALF *BET2/DTAU0
A2=(GAM2-X*DTAUM)/DZM
C2=(ALF2-X*DTAUP)/DZP
ELSE
C
C Hermitian method (ISPLIN=2)
C
AS=DTAUP*DTAUP/DTAUM/DTAU0
CS=DTAUM*DTAUM/DTAUP/DTAU0
AL3=(RADP(IJ)-SP-RAD0(IJ)+S0)*SIXTH
GA3=(RADM(IJ)-SM-RAD0(IJ)+S0)*SIXTH
AV=AL3*CS
CV=GA3*AS
AS=(UN-HALF *AS)*SIXTH
CS=(UN-HALF *CS)*SIXTH
BS=UN-AS-CS
X=(AV+CV)/DTAU0/4.D0
A2=(X*DTAUM+HALF *CV-AV)/DZM
C2=(X*DTAUP+HALF *AV-CV)/DZP
BET2=AS*(RADM(IJ)-SM)+CS*(RADP(IJ)-SP)
END IF
C
C auxiliary quantities
C
B1=B1-(A2+C2)
A1=A1-A2
C1=C1-C2
A2=AS/ABSOM(IJ)
C2=CS/ABSOP(IJ)
A3=A2*SM
C3=C2*SP
60 B2=BS/ABSO0(IJ)
B3=B2*S0
A1=A1-A3
B1=B1-B3
C1=C1-C3
C
C *** elements of the IJ-th row of matrices A, B, and C
C
A(IJ,NRE)= A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))
B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
C(IJ,NRE)= C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ))
A(IJ,NPC)= A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))
B(IJ,NPC)= B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))
C(IJ,NPC)= C1*DABNP(IJ)+
* C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
C(IJ,NMP)= C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC
DO II=1,NLVEXP
A(IJ,NSE+II)=A(IJ,NSE+II)+
* A1*DRCHM(II,IJ)+A2*DRETM(II,IJ)
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
C(IJ,NSE+II)=C(IJ,NSE+II)+
* C1*DRCHP(II,IJ)+C2*DRETP(II,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM/DTAU0-AS*(UN-CHIELM/ABSOM(IJ))
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAU0*(UN/DTAUP+UN/DTAUM)-
* BS*(UN-CHIEL0/ABSO0(IJ))
C(IJ,NFREQE)=0.
C(IJ,IJ)=FKP(IJ)/DTAUP/DTAU0-CS*(UN-CHIELP/ABSOP(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=BET1+BET2+BS*(RAD0(IJ)-S0)
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
isplin=ispl
go to 500
C
C --------------------------------------
C For ID=ND - lower boundary condition
C --------------------------------------
C
150 CONTINUE
IF(IDISK.EQ.0.OR.IFZ0.LT.0) THEN
T=TEMP(ID)
TM=TEMP(ID-1)
HKT=HK/T
HKTM=HK/TM
C
C auxiliary quantites for both options
C
DO IJ=1,NFREQE
IJT=IJFR(IJ)
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
OMEGM=ABSOM(IJ)
OMEG0=ABSO0(IJ)
DZM=OMEG0+OMEGM
DTAUM=DZM*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAM1=FRD/DTAUM
A1=GAM1/DZM
AS=0.
BS=0.
A2=0.
B2=0.
A3=0.
B3=0.
ALF2=0.
BET2=0.
GAM2=0.
C
C second-order boundary condition
C
IF(IBC.GT.0.AND.IBC.LT.4) THEN
BS=DTAUM*HALF
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
GAM2=BS*(RAD0(IJ)-S0)
BET2=GAM2
X1=BET2/DZM
A1=A1-X1
B2=BS/ABSO0(IJ)
B3=B2*S0
END IF
C
C auxiliary parameters
C
FR=FREQ(IJT)
FR15=FR*1.D-15
X=HKT*FR
EX=EXP(X)
XM=HKTM*FR
EXM=EXP(XM)
PLAN=BN*FR15*FR15*FR15/(EX-UN)
IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN
PLANM=BN*FR15*FR15*FR15/(EXM-UN)
GAM3=(PLAN-PLANM)/DTAUM*THIRD
A1=A1-GAM3/DZM
GAM1=GAM1-GAM3
END IF
C1=A1
B1=C1
A1=A1-A3
B1=B1-B3
C
C *** elements of the IJ-th row of matrices A and B
C
IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN
DPLANM=PLANM*XM/TM/(UN-UN/EXM)
A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))-
* DPLANM/DTAUM*THIRD
A(IJ,NPC)=A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))
BB=HALF+THIRD/DTAUM
DPLAN=PLAN*X/T/(UN-UN/EX)
B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))+
* BB*DPLAN
B(IJ,NPC)= B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
DO II=1,NLVEXP
A(IJ,NSE+II)=A(IJ,NSE+II)+
* A1*DRCHM(II,IJ)+A2*DRETM(II,IJ)
B(IJ,NSE+II)=B(IJ,NSE+II)+
* B1*DRCH0(II,IJ)+B2*DRET0(II,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ))
B(IJ,NFREQE)=0.
END IF
C
C *** the IJ-th element of the rhs vector
C
IF(IBC.EQ.0.OR.IBC.EQ.4) THEN
B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM-
* BS*(UN-CHIEL0/ABSO0(IJ))-HALF
VECL(IJ)=GAM1+BET2-HALF*(PLAN-RAD0(IJ))
ELSE
B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM-
* BS*(UN-CHIEL0/ABSO0(IJ))-FHD(IJT)
VECL(IJ)=GAM1+BET2-HALF*PLAN+FHD(IJT)*RAD0(IJ)
END IF
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
C
ELSE
C
C --------------------------------------
C For ID=ND - lower boundary condition
C --------------------------------------
C
C for disks -
C lower b.c. expresses just I(taumax,-mu,nu)=I(taumax,+mu,nu)
C
DO IJ=IJ1,NFREQE
IJT=IJFR(IJ)
CHIELM=SCATM(IJ)
CHIEL0=SCAT0(IJ)
OMEGM=ABSOM(IJ)
OMEG0=ABSO0(IJ)
DZM=OMEG0+OMEGM
DTAUM=DZM*DDM
FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ)
GAM1=FRD/DTAUM
A1=GAM1/DZM
AS=0.
A2=0.
A3=0.
ALF2=0.
GAM2=0.
BS=DTAUM*HALF
S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ)
c
c additional terms for Compton scattering
c
if(icompt.gt.0) then
call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd)
s0=s0+cms
end if
C
GAM2=BS*(RAD0(IJ)-S0)
BET2=ALF2+GAM2
X1=BET2/DZM
A1=A1-X1
B2=BS/ABSO0(IJ)
B3=B2*S0
B1=A1
A1=A1-A3
B1=B1-B3
C
C *** elements of the IJ-th row of matrix A
C
A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))
A(IJ,NPC)=A1*DABNM(IJ)+
* A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))
A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA
DO I=1,NLVEXP
A(IJ,NSE+I)=A1*DRCHM(I,IJ)+A2*DRETM(I,IJ)
END DO
A(IJ,NFREQE)=0.
A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ))
C
C *** elements of the IJ-th row of matrix B
C
B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))
B(IJ,NPC)=B1*DABN0(IJ)+
* B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))
B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN
DO I=1,NLVEXP
B(IJ,NSE+I)=B1*DRCH0(I,IJ)+B2*DRET0(I,IJ)
END DO
B(IJ,NFREQE)=0.
B(IJ,IJ)=-FK0(IJ)/DTAUM-BS*(UN-CHIEL0/ABSO0(IJ))
C
C *** the IJ-th element of the rhs vector
C
VECL(IJ)=GAM1+BET2
c
c additional terms for Compton scattering
c
if(icompt.gt.4) then
iji=nfreq-kij(ijt)+1
b(ij,ij)=b(ij,ij)+bs*(cmb+cme)
if(iji.gt.1) then
ijm=ijex(ijorig(iji-1))
if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma
end if
if(iji.lt.nfreq) then
ijp=ijex(ijorig(iji+1))
if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc
end if
if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs
if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id)
end if
c
END DO
END IF
isplin=ispl
500 CONTINUE
c
c zeroing radiation field for very low intensities (if required)
c
if(radzer.gt.0) then
c
C find the peak in nu*rad_nu:
c
radsum=0.
DO IJ=IJ1,NFREQE
radsum=max(freq(ij)*radex(ij,id),radsum)
END DO
C
C if much smaller than peak in nu*rad_nu, then set to zero:
C
DO IJ=IJ1,NFREQE
if(freq(ij)*radex(ij,id).lt.radzer*radsum) then
do ii=1,nn0
a(ij,ii)=0.
b(ij,ii)=0.
c(ij,ii)=0.
end do
vecl(ij)=0.
b(ij,ij)=un
end if
end do
end if
isplin=ispl
c
RETURN
END
tlusty/extracted/butler.f
+141
View File
@@ -0,0 +1,141 @@
SUBROUTINE BUTLER (NI,NJ,T,U0,COL,IERR)
C =======================================
C
C Rate coefficients for collisional excitation of hydrogen
C by electrons. Interpolates in Table 3 of Przybilla & Butler
C (2004, ApJ).
C
C
C Input:
C NI Principal quantum number lower level
C NJ "" upper level
C T Temperature
C U0 =h*nu/K/T
C Output:
C COL collisional rate (cm3 s-1)
C IERR error flat (0=ok, 1=T exceeds table range,
C 2=NI higher than 6 or lower than 1
C NJ higher than 7 or lower than 2)
C
INCLUDE 'IMPLIC.FOR'
DIMENSION COLSTR(16,21),TREF(16)
DATA (TREF(I), I=1,16) /
* 2.5d3, 5d3, 7.5d3, 1d4, 1.5d4, 2d4, 2.5d4, 3d4, 4d4, 5d4, 6d4,
* 8d4, 1d5, 1.5d5, 2d5, 2.5d5 /
DATA ((COLSTR(I,J),J=1,21),I=1,16) /
C J=1,21 corresponds to (NI,NJ)={(1,2),(1,3),...,(1,NL),(2,3),...}
C where NL=7 (higher n covered in Table)
C I=1,16 corresponds to T={2.5e3,5e3,7.5e3,1e4,1.5e4,2e4,2.5e4,3e4,
C 4e4,5e4,6e4,8e4,1e5,1.5e5,2e5,2.5e5}
* 6.40d-1, 2.20d-1, 9.93d-2, 4.92d-2, 2.97d-2, 5.03d-2, 2.35d+1,
* 1.07d+1, 5.22d+0, 2.91d+0, 5.25d+0, 1.50d+2, 7.89d+1, 4.13d+1,
* 7.60d+1, 5.90d+2, 2.94d+2, 4.79d+2, 1.93d+3, 1.95d+3, 6.81d+3,
* 6.98d-1, 2.40d-1, 1.02d-1, 5.84d-2, 4.66d-2, 6.72d-2, 2.78d+1,
* 1.15d+1, 5.90d+0, 4.53d+0, 7.26d+0, 1.90d+2, 9.01d+1, 6.11d+1,
* 1.07d+2, 8.17d+2, 4.21d+2, 7.06d+2, 2.91d+3, 3.24d+3, 1.17d+4,
* 7.57d-1, 2.50d-1, 1.10d-1, 7.17d-2, 6.28d-2, 7.86d-2, 3.09d+1,
* 1.23d+1, 6.96d+0, 6.06d+0, 8.47d+0, 2.28d+2, 1.07d+2, 8.21d+1,
* 1.25d+2, 1.07d+3, 5.78d+2, 8.56d+2, 4.00d+3, 4.20d+3, 1.50d+4,
* 8.09d-1, 2.61d-1, 1.22d-1, 8.58d-2, 7.68d-2, 8.74d-2, 3.38d+1,
* 1.34d+1, 8.15d+0, 7.32d+0, 9.27d+0, 2.70d+2, 1.26d+2, 1.01d+2,
* 1.37d+2, 1.35d+3, 7.36d+2, 9.66d+2, 5.04d+3, 4.95d+3, 1.73d+4,
* 8.97d-1, 2.88d-1, 1.51d-1, 1.12d-1, 9.82d-2, 1.00d-1, 4.01d+1,
* 1.62d+1, 1.04d+1, 9.17d+0, 1.03d+1, 3.64d+2, 1.66d+2, 1.31d+2,
* 1.52d+2, 1.93d+3, 1.02d+3, 1.11d+3, 6.81d+3, 6.02d+3, 2.03d+4,
* 9.78d-1, 3.22d-1, 1.80d-1, 1.33d-1, 1.14d-1, 1.10d-1, 4.71d+1,
* 1.90d+1, 1.23d+1, 1.05d+1, 1.08d+1, 4.66d+2, 2.03d+2, 1.54d+2,
* 1.61d+2, 2.47d+3, 1.26d+3, 1.21d+3, 8.20d+3, 6.76d+3, 2.21d+4,
* 1.06d+0, 3.59d-1, 2.06d-1, 1.50d-1, 1.25d-1, 1.16d-1, 5.45d+1,
* 2.18d+1, 1.39d+1, 1.14d+1, 1.12d+1, 5.70d+2, 2.37d+2, 1.72d+2,
* 1.68d+2, 2.96d+3, 1.46d+3, 1.29d+3, 9.29d+3, 7.29d+3, 2.33d+4,
* 1.15d+0, 3.96d-1, 2.28d-1, 1.64d-1, 1.33d-1, 1.21d-1, 6.20d+1,
* 2.44d+1, 1.52d+1, 1.21d+1, 1.14d+1, 6.72d+2, 2.68d+2, 1.86d+2,
* 1.72d+2, 3.40d+3, 1.64d+3, 1.34d+3, 1.02d+4, 7.70d+3, 2.41d+4,
* 1.32d+0, 4.64d-1, 2.66d-1, 1.85d-1, 1.45d-1, 1.27d-1, 7.71d+1,
* 2.89d+1, 1.74d+1, 1.31d+1, 1.17d+1, 8.66d+2, 3.19d+2, 2.08d+2,
* 1.78d+2, 4.14d+3, 1.92d+3, 1.41d+3, 1.15d+4, 8.26d+3, 2.52d+4,
* 1.51d+0, 5.26d-1, 2.95d-1, 2.01d-1, 1.53d-1, 1.31d-1, 9.14d+1,
* 3.27d+1, 1.90d+1, 1.38d+1, 1.18d+1, 1.04d+3, 3.62d+2, 2.24d+2,
* 1.81d+2, 4.75d+3, 2.15d+3, 1.46d+3, 1.26d+4, 8.63d+3, 2.60d+4,
* 1.68d+0, 5.79d-1, 3.18d-1, 2.12d-1, 1.58d-1, 1.34d-1, 1.05d+2,
* 3.60d+1, 2.03d+1, 1.44d+1, 1.19d+1, 1.19d+3, 3.98d+2, 2.36d+2,
* 1.83d+2, 5.25d+3, 2.33d+3, 1.50d+3, 1.34d+4, 8.88d+3, 2.69d+4,
* 2.02d+0, 6.70d-1, 3.55d-1, 2.29d-1, 1.65d-1, 1.35d-1, 1.29d+2,
* 4.14d+1, 2.23d+1, 1.51d+1, 1.19d+1, 1.46d+3, 4.53d+2, 2.53d+2,
* 1.85d+2, 6.08d+3, 2.61d+3, 1.55d+3, 1.49d+4, 9.21d+3, 2.90d+4,
* 2.33d+0, 7.43d-1, 3.83d-1, 2.39d-1, 1.70d-1, 1.37d-1, 1.51d+2,
* 4.56d+1, 2.37d+1, 1.56d+1, 1.20d+1, 1.67d+3, 4.95d+2, 2.65d+2,
* 1.86d+2, 6.76d+3, 2.81d+3, 1.57d+3, 1.63d+4, 9.43d+3, 3.17d+4,
* 2.97d+0, 8.80d-1, 4.30d-1, 2.59d-1, 1.77d-1, 1.39d-1, 1.93d+2,
* 5.31d+1, 2.61d+1, 1.63d+1, 1.19d+1, 2.08d+3, 5.68d+2, 2.83d+2,
* 1.87d+2, 8.08d+3, 3.15d+3, 1.61d+3, 1.97d+4, 9.78d+3, 3.94d+4,
* 3.50d+0, 9.79d-1, 4.63d-1, 2.71d-1, 1.82d-1, 1.39d-1, 2.26d+2,
* 5.83d+1, 2.78d+1, 1.68d+1, 1.19d+1, 2.39d+3, 6.16d+2, 2.94d+2,
* 1.86d+2, 9.13d+3, 3.36d+3, 1.62d+3, 2.27d+4, 1.00d+4, 4.73d+4,
* 3.95d+0, 1.06d+0, 4.88d-1, 2.81d-1, 1.85d-1, 1.40d-1, 2.52d+2,
* 6.23d+1, 2.89d+1, 1.71d+1, 1.19d+1, 2.62d+3, 6.51d+2, 3.02d+2,
* 1.87d+2, 1.00d+4, 3.51d+3, 1.63d+3, 2.54d+4, 1.02d+4, 5.50d+4 /
NL=7
IERR=0
COL=0.0d0
IF (T.LT.2.5d3.OR.T.GE.2.5d5) IERR=1
IF (NI.LT.1.OR.NI.GT.NL-1.OR.NJ.LT.2.OR.NJ.GT.NL) IERR=2
IF (IERR.EQ.0) THEN
J=0
DO I=1,NI-1
J=J+(NL-I)
END DO
DO K=I+1,NJ
J=J+1
END DO
C find out nearest points in TREF
ILOW=1
DO WHILE (T.GE.TREF(ILOW+1))
ILOW=ILOW+1
END DO
IHIG=16
DO WHILE (T.LT.TREF(IHIG-1))
IHIG=IHIG-1
END DO
IF (IHIG.EQ.ILOW) IHIG=IHIG+1
C interpolate linearly (log-log) the collision strength
SL=LOG10(COLSTR(IHIG,J))-LOG10(COLSTR(ILOW,J))
SL=SL/(LOG10(TREF(IHIG))-LOG10(TREF(ILOW)))
OR=LOG10(COLSTR(IHIG,J))-SL*LOG10(TREF(IHIG))
COL=LOG10(T)*SL+OR
COL=10.**COL
C derive the rate
COL=8.631d-6/(2.d0*NI**2)/SQRT(T)*EXP(-U0)*COL
END IF
RETURN
END
tlusty/extracted/carbon.f
+53
View File
@@ -0,0 +1,53 @@
SUBROUTINE CARBON(IB,FR,SG)
C ===========================
C
C Photoionization cross-section for neutral carbon 2p1D and 2p1S
C levels (G.B.Taylor - private communication)
C
INCLUDE 'IMPLIC.FOR'
DIMENSION FR2(34),SG2(34),FR3(45),SG3(45)
PARAMETER (FR0=3.28805D15, NC2=34, NC3=45)
DATA FR2/ 0.74, 0.75, 0.76, 0.77, 0.78, 0.79, 0.80, 0.81, 0.82,
* 0.83, 0.85, 0.86, 0.87, 0.88, 0.89, 0.90,
* 0.91, 0.92, 0.93, 0.94, 0.95, 0.96, 0.97, 0.98, 0.99,
* 1.00, 1.10, 1.20, 1.30, 1.45, 1.50, 1.60, 1.80, 2./
DATA SG2/ 12.04, 12.03, 12.09, 12.26, 12.60, 13.24, 14.36, 16.24,
* 19.28, 23.94, 37.41, 42.88, 44.76, 43.41, 40.46, 37.19,
* 34.26, 31.82, 29.96, 28.57, 27.68, 27.37, 27.84, 29.69,
* 34.45, 46.35, 13.80, 11.54, 10.40, 8.96, 8.54, 7.47,
* 6.53, 5.66/
DATA FR3/ 0.66, 0.68, 0.70, 0.72, 0.74, 0.76, 0.78, 0.80, 0.82,
* 0.84, 0.86, 0.864,0.866,0.868,0.87, 0.874,0.876,0.88,
* 0.882,0.884,0.886,0.888,0.89 ,0.894,0.896,0.898,0.90,
* 0.904,0.908,0.910,0.920,0.94, 0.98, 1.00, 1.10, 1.20,
* 1.26, 1.34, 1.36, 1.40, 1.46, 1.60, 1.70, 1.80, 2./
DATA SG3/ 13.94, 13.29, 12.56, 11.73, 10.82, 10.18, 8.62, 7.27,
* 5.74, 4.14, 4.61, 5.92, 6.94, 8.34, 10.21, 16.12,
* 20.64, 34.56, 44.82, 57.71, 73.09, 89.99,106.38,127.08,
* 128.38,124.44,117.17, 99.32, 82.95, 76.05, 52.65, 33.23,
* 21.29, 18.69, 12.62, 11.44, 9.77, 7.53, 10.47, 9.65,
* 10.19, 7.28, 6.70, 6.11, 4.96/
SAVE FR2,SG2,FR3,SG3
C
F=FR/FR0
IF(IB.NE.-602) GO TO 25
J=2
IF(F.LE.FR2(1)) GO TO 20
DO I=2,NC2
J=I
IF(F.GT.FR2(I-1).AND.F.LE.FR2(I)) GO TO 20
END DO
20 SG=(F-FR2(J-1))/(FR2(J)-FR2(J-1))*(SG2(J)-SG2(J-1))+SG2(J-1)
SG=SG*1.D-18
25 IF(IB.NE.-603) GO TO 50
J=2
IF(F.LE.FR3(1)) GO TO 40
DO I=2,NC3
J=I
IF(F.GT.FR3(I-1).AND.F.LE.FR3(I)) GO TO 40
END DO
40 SG=(F-FR3(J-1))/(FR3(J)-FR3(J-1))*(SG3(J)-SG3(J-1))+SG3(J-1)
SG=SG*1.D-18
50 CONTINUE
RETURN
END
tlusty/extracted/ceh12.f
+25
View File
@@ -0,0 +1,25 @@
FUNCTION CEH12(T)
C =================
C
C Special formula for collisional rate in hydrogen Lyman-alpha
C transition
C After Crandall et al. Ap.J. 191, 789 (1974)
C
INCLUDE 'IMPLIC.FOR'
DIMENSION A(6),B(8)
PARAMETER (C=-118353.41)
DATA A/ 2.579997D-10, -1.629166D-10, 7.713069D-11,
* -2.668768D-11, 6.642513D-12, -9.422885D-13/
SAVE A
c
DO I=1,8
B(I)=0.
END DO
X=LOG10(T)-4.
DO I=1,6
J=7-I
B(J)=2.*X*B(J+1)-B(J+2)+A(J)
END DO
CEH12=2.4*SQRT(T)*(B(1)-B(3))*EXP(C/T)
RETURN
END
tlusty/extracted/change.f
+286
View File
@@ -0,0 +1,286 @@
SUBROUTINE CHANGE
C =================
C
C This procedure controls an evaluation of initial level
C populations in case where the system of explicit levels
C (ie. the choice of explicit level, their numbering, or their
C total number) is not consistent with that for the input level
C populations read by procedure INPMOD.
C Obviously, this procedure need be used only for NLTE input models.
C
C ICHANG < 0 - general change of populations as described below
C > 0 - a simplified change; original data for the input
C model are required to assign the input NLTE populations
C to the levels in the new models; all additional
C levels are assumed having LTE populations.
C ICHANG is the unit number for the data file of old model.
C
C Case ICHANG < 0:
C
C Input from unit 5:
C For each explicit level, II=1,NLEVEL, the following parameters:
C IOLD - NE.0 - means that population of this level is
C contained in the set of input populations;
C IOLD is then its index in the "old" (i.e. input)
C numbering.
C All the subsequent parameters have no meaning
C in this case.
C - EQ.0 - means that this level has no equivalent in the
C set of "old" levels. Population of this level
C has thus to be evaluated.
C MODE - indicates how the population is evaluated:
C = 0 - population is equal to the population of the "old"
C level with index ISIOLD, multiplied by REL;
C = 1 - population assumed to be LTE, with respect to the
C first state of the next ionization degree whose
C population must be contained in the set of "old"
C (ie. input) populations, with index NXTOLD in the
C "old" numbering.
C The population determined of this way may further
C be multiplied by REL.
C = 2 - population determined assuming that the b-factor
C (defined as the ratio between the NLTE and
C LTE population) is the same as the b-factor of
C the level ISINEW (in the present numbering). The
C level ISINEW must have the equivalent in the "old"
C set; its index in the "old" set is ISIOLD, and the
C index of the first state of the next ionization
C degree, in the "old" numbering, is NXTSIO.
C The population determined of this way may further
C be multiplied by REL.
C = 3 - level corresponds to an ion or atom which was not
C explicit in the old system; population is assumed
C to be LTE.
C NXTOLD - see above
C ISINEW - see above
C ISIOLD - see above
C NXTSIO - see above
C REL - population multiplier - see above
C if REL=0, the program sets up REL=1
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
character*20 fnstd
dimension n0old(30,30),n1old(30,30)
dimension katold(2,30),vtbold(mdepth)
COMMON POPUL0(MLEVEL,MDEPTH),POPULL(MLEVEL,MDEPTH),
* ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),POPL(MLEVEL)
C
PARAMETER (S = 2.0706D-16)
IF(ICHANG.LT.0) THEN
IFESE=0
DO 100 II=1,NLEVEL
READ(IBUFF,*) IOLD,MODE,NXTOLD,ISINEW,ISIOLD,NXTSIO,REL
IF(REL.EQ.0.) REL=1.
IF(MODE.GE.3) IFESE=IFESE+1
DO 90 ID=1,ND
IF(IOLD.EQ.0) GO TO 10
POPUL0(II,ID)=POPUL(IOLD,ID)
GO TO 90
10 IF(MODE.NE.0) GO TO 20
POPUL0(II,ID)=POPUL(ISIOLD,ID)*REL
GO TO 90
20 T=TEMP(ID)
ANE=ELEC(ID)
IF(MODE.GE.3) GO TO 40
NXTNEW=NNEXT(IEL(II))
SB=S/T/SQRT(T)*G(II)/G(NXTNEW)*EXP(ENION(II)/T/BOLK)
IF(MODE.GT.1) GO TO 30
POPUL0(II,ID)=SB*ANE*POPUL(NXTOLD,ID)*REL
GO TO 90
30 KK=ISINEW
KNEXT=NNEXT(IEL(KK))
SBK=S/T/SQRT(T)*G(KK)/G(KNEXT)*EXP(ENION(KK)/T/BOLK)
POPUL0(II,ID)=SB/SBK*POPUL(NXTOLD,ID)/POPUL(NXTSIO,ID)*
* POPUL(ISIOLD,ID)*REL
GO TO 90
40 IF(IFESE.EQ.1) THEN
LTE0=LTE
LTE=.TRUE.
do iii=1,nlevel
if(wop(iii,id).eq.0.) wop(iii,id)=1.
end do
CALL STEQEQ(ID,POPL,0)
DO III=1,NLEVEL
POPULL(III,ID)=POPL(III)
END DO
LTE=LTE0
END IF
POPUL0(II,ID)=POPULL(II,ID)
90 CONTINUE
100 CONTINUE
DO I=1,NLEVEL
DO ID=1,ND
POPUL(I,ID)=POPUL0(I,ID)
END DO
END DO
C
C simplified change - no additional input (the case ICHANG > 0)
C
ELSE
LTE0=LTE
LTE=.TRUE.
DO ID=1,ND
do ii=1,nlevel
if(wop(ii,id).eq.0.) wop(ii,id)=1.
end do
CALL STEQEQ(ID,POPL,0)
DO II=1,NLEVEL
POPUL0(II,ID)=POPL(II)
END DO
END DO
C
IF(ICHANG.EQ.1) THEN
DO II=NLEV0+1,NLEVEL
DO ID=1,ND
POPUL(II,ID)=POPUL0(II,ID)
END DO
END DO
C
ELSE
modr=0
rewind 1
read(1,*,err=200,end=200) modr
200 continue
call readbf(ichang)
if(modr.eq.0) then
read(95,*) tfold,grold
read(95,*) ltd1,ltd2
read(95,*) fnstd
read(95,*) nfrd
if(nfrd.lt.0) then
nfrd=-nfrd
do ij=1,nfrd
read(95,*) frold
end do
endif
read(95,*) natold
if(natold.lt.0) natold=-natold
do ia=1,natold
read(95,*) iao,abnold
if(abnold.gt.1.e6) read(95,*) (vtbold(i),i=1,ndold)
end do
nlold=0
read(95,*) iato,izo,nlvo,ilasti,ilvi,instd
if(instd.ne.0) read(95,*) idui
do while (ilasti.ge.0)
n0old(iato,izo+1)=nlold+1
n1old(iato,izo+1)=nlold+nlvo
nlold=nlold+nlvo
read(95,*) iato,izo,nlvo,ilasti,ilvi,instd
if(instd.ne.0) read(95,*) idui
end do
else
read(95,*) tfold,grold,hmold
read(95,*) ltd1,ltd2,lcold,ispold,chmold
if(ispold.lt.0) read(95,*,err=203) iol1,iol2,iol3,iol4,
. iol5,iol6,iol7
if(iol6.ge.2) read(95,*) djmold
203 read(95,*,err=204) nitold,ndold,natold,niold,nlvold,
. iol1,iol2,iarold,iol4
204 continue
if(iol1.gt.10) then
read(95,*,err=205) iol1,iol2,iol3,iol4,iol5
read(95,*,err=205) iol1,iol2
read(95,*,err=205) iol1,iol2
end if
205 continue
if(niold.lt.0) then
niold=-niold
read(95,*,err=206) iol1,iol2,iol3
end if
206 continue
if(iarold.le.-100 .and. iarold.gt.-200) then
iarold=-iarold-100
read(95,*) iol1
endif
read(95,*) nfrd
if(nfrd.gt.0) then
nfrd=-nfrd
do ij=1,nfrd
read(95,*) frold
end do
else
nfrd=-nfrd
read(95,*) frold
end if
read(95,*,err=211) iol1,iol2,iol3
if(iol3.lt.0) read(95,*) pzold
211 continue
read(95,*) iol1,vtbol
if(iol1.ne.0) read(95,*) (vtbold(i),i=1,ndold)
read(95,*) natsold
if(natsold.lt.0) natsold=-natsold
iat=0
do ia=1,natsold
read(95,*) iol1,iol2,iol3,iol4,iol5,abnold
if(abnold.gt.1.e6) read(95,*) (vtbold(i),i=1,ndold)
if(iol1.eq.2) then
iat=iat+1
katold(1,iat)=iol2
katold(2,iat)=iol3
end if
end do
do ii=1,niold
read(95,*) k0old,k1old,k2old,izo
if(k0old.lt.0) then
k0old=-k0old
read(95,*) iol1
end if
do ia=1,iat
if(k0old.ge.katold(1,ia) .and. k1old.ge.katold(2,ia))
. iaol=ia
end do
n0old(iaol,izo)=k0old
n1old(iaol,izo)=k1old
n0old(iaol,izo+1)=k2old
n1old(iaol,izo+1)=k2old
end do
end if
C
WRITE(6,600)
600 FORMAT(' Levels: OLD model -> NEW model',/
. ' ------------------------------')
DO 300 II=1,NION
N0NEW=NFIRST(II)
N1NEW=NLAST(II)
IANEW=NUMAT(IATM(N0NEW))
IZNEW=IZ(IEL(N0NEW))
IF(N1OLD(IANEW,IZNEW).EQ.0) GO TO 300
KOLD=N1OLD(IANEW,IZNEW)-N0OLD(IANEW,IZNEW)
KNEW=NLAST(II)-NFIRST(II)
IF(KOLD.LT.KNEW) KNEW=KOLD
JL=N0OLD(IANEW,IZNEW)-1
DO IL=NFIRST(II),NFIRST(II)+KNEW
JL=JL+1
WRITE(6,601) JL,IL
601 FORMAT(10X,I8,5X,I8)
DO ID=1,ND
POPUL0(IL,ID)=POPUL(JL,ID)
END DO
END DO
300 CONTINUE
DO 310 II=1,NATOM
N0NEW=NKA(II)
IANEW=NUMAT(IATM(N0NEW))
IZNEW=IZ(IEL(N0NEW))+1
IF(N0OLD(IANEW,IZNEW).EQ.0) GO TO 310
WRITE(6,601) N0OLD(IANEW,IZNEW),N0NEW
DO ID=1,ND
POPUL0(N0NEW,ID)=POPUL(N0OLD(IANEW,IZNEW),ID)
END DO
310 CONTINUE
C
DO II=1,NLEVEL
DO ID=1,ND
POPUL(II,ID)=POPUL0(II,ID)
END DO
END DO
END IF
LTE=LTE0
C
END IF
RETURN
END
tlusty/extracted/chckse.f
+86
View File
@@ -0,0 +1,86 @@
SUBROUTINE CHCKSE
C ==================
C
C Auxiliary output routine, which enables printing
C total rates to check statistical equilibrium at each depth.
C
C Output: unit 16: <OUT> and <IN> rates, and relative difference,
C for each level.
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (MLEVES=mlevel)
DIMENSION ROUT(MLEVES,MDEPTH),RIN(MLEVES,MDEPTH)
if(ioptab.lt.0) return
C
DO ID=1,ND
T=TEMP(ID)
HKT=HK/T
TK=HKT/H
ANE=ELEC(ID)
CALL SABOLF(ID)
DO IAT=1,NATOM
N0I=N0A(IAT)
NKI=NKA(IAT)
N1I=NKI-1
DO I=N0I,NKI
OUT=0.
XIN=0.
NKE=NNEXT(IEL(I))
DO IT=1,NTRANS
II=ILOW(IT)
JJ=IUP(IT)
IF(II.EQ.I) THEN
J=JJ
IF(LINE(IT)) THEN
AIJ=COLTAR(IT,ID)*WOP(I,ID)+RRD(IT,ID)*
* G(I)/G(J)*WOP(I,ID)*EXP(HKT*FR0(IT))
ELSE
CORR=UN
NKE=NNEXT(IEL(I))
IF(NKE.NE.J) CORR=G(NKE)/G(J)*
* EXP((ENION(NKE)-ENION(J))*TK)
AIJ=COLTAR(IT,ID)+WOP(I,ID)+RRD(IT,ID)*
* ANE*SBF(I)*CORR*WOP(I,ID)
END IF
AJI=(COLRAT(IT,ID)+RRU(IT,ID))*WOP(J,ID)
XIN=XIN+AIJ*POPUL(J,ID)
OUT=OUT+AJI
ELSE IF(JJ.EQ.I) THEN
J=II
IF(LINE(IT)) THEN
AJI=COLTAR(IT,ID)+WOP(J,ID)+RRD(IT,ID)*
* G(J)/G(I)*WOP(J,ID)*EXP(HKT*FR0(IT))
ELSE
CORR=UN
NKE=NNEXT(IEL(J))
IF(NKE.NE.I) CORR=G(NKE)/G(I)*
* EXP((ENION(NKE)-ENION(I))*TK)
AJI=COLTAR(IT,ID)*WOP(J,ID)+RRD(IT,ID)*
* ANE*SBF(J)*CORR*WOP(J,ID)
END IF
AIJ=(COLRAT(IT,ID)+RRU(IT,ID))*WOP(I,ID)
XIN=XIN+AIJ*POPUL(J,ID)
OUT=OUT+AJI
END IF
END DO
RIN(I,ID)=XIN
ROUT(I,ID)=OUT*POPUL(I,ID)
END DO
END DO
END DO
DO I=1,NLEVEL
IF(RIN(I,ND).GT.0.) THEN
WRITE(16,300) I
DO ID=1,ND
DEL=(RIN(I,ID)-ROUT(I,ID))/RIN(I,ID)
WRITE(16,310) I,ID,RIN(I,ID),ROUT(I,ID),DEL,popul(i,id)
END DO
END IF
END DO
300 FORMAT('1 Level:',I5///)
310 FORMAT(2I5,1P3E16.7,2x,e16.7)
RETURN
END
tlusty/extracted/chctab.f
+171
View File
@@ -0,0 +1,171 @@
subroutine chctab
c =================
c
c check the consistency of the opacities in the opacity
c table; modify the input paramaters for additional opacities
c if needed
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
common/abntab/abunt(matom),abuno(matom),tmolit,
* iophmt,ioph2t,iophet,iopcht,iopoht,
* ioh2mt,ih2h2t,ih2het,ioh2ht,iohhet,
* ifmolt
c
character*4 typ
dimension typ(matom)
c
DATA TYP/' H ',' He ',' Li ',' Be ',' B ',' C ',
* ' N ',' O ',' F ',' Ne ',' Na ',' Mg ',
* ' Al ',' Si ',' P ',' S ',' Cl ',' Ar ',
* ' K ',' Ca ',' Sc ',' Ti ',' V ',' Cr ',
* ' Mn ',' Fe ',' Co ',' Ni ',' Cu ',' Zn ',
* ' Ga ',' Ge ',' As ',' Se ',' Br ',' Kr ',
* ' Rb ',' Sr ',' Y ',' Zr ',' Nb ',' Mo ',
* ' Tc ',' Ru ',' Rh ',' Pd ',' Ag ',' Cd ',
* ' In ',' Sn ',' Sb ',' Te ',' I ',' Xe ',
* ' Cs ',' Ba ',' La ',' Ce ',' Pr ',' Nd ',
* ' Pm ',' Sm ',' Eu ',' Gd ',' Tb ',' Dy ',
* ' Ho ',' Er ',' Tm ',' Yb ',' Lu ',' Hf ',
* ' Ta ',' W ',' Re ',' Os ',' Ir ',' Pt ',
* ' Au ',' Hg ',' Tl ',' Pb ',' Bi ',' Po ',
* ' At ',' Rn ',' Fr ',' Ra ',' Ac ',' Th ',
* ' Pa ',' U ',' Np ',' Pu ',' Am ',' Cm ',
* ' Bk ',' Cf ',' Es '/
c
write(6,600)
do ia=1,matom
write(6,601) typ(ia),abndd(ia,1),abunt(ia),abuno(ia)
end do
600 format(
* ' chemical abundances:'//
* 7x,' HERE OP.TAB.EOS OP.TAB.OPACITIES')
601 format(2x,a4,1p3e12.3)
603 format(/' treatment of molecules: IFMOL here: ',i4/
* ' op.tab:',i4/
* ' TMOLIM here: ',f10.1/
* ' op.tab:',f10.1)
c
write(6,603) ifmol,ifmolt,tmolim,tmolit
if(ifmol.ne.ifmolt) then
if(keepop.eq.0) then
ifmol=ifmolt
tmolim=tmolit
write(6,*)
* ' IFMOL and TMILIM changed to the values of op.table'
else
write(6,*) ' but IFMOL and TMOLIM retained here'
end if
end if
c
write(6,604)
604 format(/' additional opacities'/)
if(iophmt.gt.0.and.(iophmi.gt.0.or.ielhm.gt.0)) then
write(6,*) 'H- opacity included in the op.table and here'
if(keepop.eq.0) then
iophmi=0
write(6,*) ' so removed here (IOPHMI=0)'
if(ielhm.gt.0)
* write(6,*) ' but H- is explicit here, needs to be changed!!'
* '
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
if(iophmi.gt.0.or.ielhm.gt.0) write(6,*)
* 'H- opacity included here'
c
if(ioph2t.gt.0.and.ioph2p.gt.0) then
write(6,*) 'H2+ opacity included in the op.table and here'
if(keepop.eq.0) then
ioph2p=0
write(6,*) ' so removed here (IOPH2P=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
if(ioph2p.gt.0) write(6,*) 'H2+ opacity included here'
c
if(iophet.gt.0.and.iophem.gt.0) then
write(6,*) 'He- opacity included in the op.table and here'
if(keepop.eq.0) then
iophem=0
write(6,*) ' so removed here (IOPHEM=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(iopcht.gt.0.and.iopch.gt.0) then
write(6,*) 'CH opacity included in the op.table and here'
if(keepop.eq.0) then
iopch=0
write(6,*) ' so removed here (IOPCH=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(iopoht.gt.0.and.iopoh.gt.0) then
write(6,*) 'OH opacity included in the op.table and here'
if(keepop.eq.0) then
iopoh=0
write(6,*) ' so removed here (IOPOH=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(ioh2mt.gt.0.and.ioph2m.gt.0) then
write(6,*) 'H2- opacity included in the op.table and here'
if(keepop.eq.0) then
ioph2m=0
write(6,*) ' so removed here (IOPH2M=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(ih2h2t.gt.0.and.ioh2h2.gt.0) then
write(6,*) 'CIA H2-H2 opacity included in the op.table and here'
if(keepop.eq.0) then
ioh2h2=0
write(6,*) ' so removed here (IOH2H2=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(ih2het.gt.0.and.ioh2he.gt.0) then
write(6,*) 'CIA H2-He opacity included in the op.table and here'
if(keepop.eq.0) then
ioh2he=0
write(6,*) ' so removed here (IOH2HE=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(ioh2ht.gt.0.and.ioh2h.gt.0) then
write(6,*) 'CIA H2-H opacity included in the op.table and here'
if(keepop.eq.0) then
ioh2h=0
write(6,*) ' so removed here (IOH2H=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
if(iohhet.gt.0.and.iohhe.gt.0) then
write(6,*) 'CIA H2-H2 opacity included in the op.table and here'
if(keepop.eq.0) then
iohhe=0
write(6,*) ' so removed here (IOHHE=0)'
else
write(6,*) ' but retained here, so it is taken twice!'
end if
end if
c
return
end
tlusty/extracted/cheav.f
+148
View File
@@ -0,0 +1,148 @@
FUNCTION CHEAV(II,JJ,IC)
C ========================
C
C Calculates collisional excitation rates of neutral helium
C between states with n= 1, 2, 3, 4; with either the upper state
C alone, or both upper and lower states are some averaged states
C The program allows only two standard possibilities of
C constructing averaged levels:
C i) all states within given principal quantum number n (>1) are
C lumped together
C ii) all siglet states for given n, and all triplet states for
C given n are lumped together separately (there are thus two
C explicit levels for a given n)
C
C The rates are calculated using appropriate summations and/or
C averages of the Storey-Hummer rates (calculated by procedure
C COLLHE and stored in array COLHE1)
C
C Input parameters:
C II,JJ - indices of the lower and the upper level (in the
C numbering of the explicit levels)
C IC - collisional switch ICOL for the given transition
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
C
CHEAV=0.
NI=NQUANT(II)
NJ=NQUANT(JJ)
IGI=INT(G(II)+0.01)
IGJ=INT(G(JJ)+0.01)
C
C ----------------------------------------------------------------
C IC=2 - transition from an (l,s) lower level to an averaged upper
C level
C ----------------------------------------------------------------
C
IF(IC.EQ.2) THEN
I=II-NFIRST(IELHE1)+1
CHEAV=CHEAVJ(I,NJ,IGJ)
END IF
C
C ----------------------------------------------------------------
C IC=3 - transition from an averaged lower level to an averaged
C upper level
C ----------------------------------------------------------------
C
IF(IC.EQ.3) THEN
IF(NI.EQ.2) THEN
C
C ******** transitions from an averaged level with n=2
C
IF(IGI.EQ.4) THEN
C
C a) lower level is an averaged singlet state
C
CHEAV=(CHEAVJ(3,NJ,IGJ)+3.D0*CHEAVJ(5,NJ,IGJ))/4.D0
ELSE IF(IGI.EQ.12) THEN
C
C b) lower level is an averaged triplet state
C
CHEAV=(CHEAVJ(2,NJ,IGJ)+3.D0*CHEAVJ(4,NJ,IGJ))/4.D0
ELSE IF(IGI.EQ.16) THEN
C
C c) lower level is an average of both singlet and triplet states
C
CHEAV=(CHEAVJ(3,NJ,IGJ)+3.D0*(CHEAVJ(5,NJ,IGJ)+
* CHEAVJ(2,NJ,IGJ))+9.D0*CHEAVJ(4,NJ,IGJ))/1.6D1
ELSE
GO TO 10
END IF
C
C
C ******** transitions from an averaged level with n=3
C
ELSE IF(NI.EQ.3) THEN
IF(IGI.EQ.9) THEN
C
C a) lower level is an averaged singlet state
C
CHEAV=(CHEAVJ(7,NJ,IGJ)+3.D0*CHEAVJ(11,NJ,IGJ)+
* 5.D0*CHEAVJ(10,NJ,IGJ))/9.D0
ELSE IF(IGI.EQ.27) THEN
C
C b) lower level is an averaged triplet state
C
CHEAV=(CHEAVJ(6,NJ,IGJ)+3.D0*CHEAVJ(8,NJ,IGJ)+
* 5.D0*CHEAVJ(9,NJ,IGJ))/9.D0
ELSE IF(IGI.EQ.36) THEN
C
C c) lower level is an average of both singlet and triplet states
C
CHEAV=(CHEAVJ(7,NJ,IGJ)+3.D0*CHEAVJ(11,NJ,IGJ)+
* 5.D0*CHEAVJ(10,NJ,IGJ)+
* 3.D0*CHEAVJ(6,NJ,IGJ)+9.D0*CHEAVJ(8,NJ,IGJ)+
* 1.5D1*CHEAVJ(9,NJ,IGJ))/3.6D1
ELSE
GO TO 10
END IF
C
C ******** transitions from an averaged level with n=4
C
ELSE IF(NI.EQ.4) THEN
IF(IGI.EQ.16) THEN
C
C a) lower level is an averaged singlet state
C
CHEAV=(CHEAVJ(13,NJ,IGJ)+
* 3.D0*CHEAVJ(19,NJ,IGJ)+
* 5.D0*CHEAVJ(16,NJ,IGJ)+
* 7.D0*CHEAVJ(18,NJ,IGJ))/1.6D1
ELSE IF(IGI.EQ.48) THEN
C
C b) lower level is an averaged triplet state
C
CHEAV=(CHEAVJ(12,NJ,IGJ)+
* 3.D0*CHEAVJ(14,NJ,IGJ)+
* 5.D0*CHEAVJ(15,NJ,IGJ)+
* 7.D0*CHEAVJ(17,NJ,IGJ))/1.6D1
ELSE IF(IGI.EQ.64) THEN
C
C c) lower level is an average of both singlet and triplet states
C
CHEAV=(CHEAVJ(13,NJ,IGJ)+
* 3.D0*CHEAVJ(19,NJ,IGJ)+
* 5.D0*CHEAVJ(16,NJ,IGJ)+
* 7.D0*CHEAVJ(18,NJ,IGJ)+
* 3.D0*CHEAVJ(12,NJ,IGJ)+
* 9.D0*CHEAVJ(14,NJ,IGJ)+
* 15.D0*CHEAVJ(15,NJ,IGJ)+
* 21.D0*CHEAVJ(17,NJ,IGJ))/6.4D1
ELSE
GO TO 10
END IF
ELSE
GO TO 10
END IF
END IF
RETURN
10 WRITE(6,601) NI,NJ,IGI,IGJ
write(10,601) NI,NJ,IGI,IGJ
601 FORMAT(1H0/' INCONSISTENT INPUT TO PROCEDURE CHEAV'/
* ' QUANTUM NUMBERS =',2I3,' STATISTICAL WEIGHTS',2I4)
call quit(' ',ni,nj)
END
tlusty/extracted/cheavj.f
+111
View File
@@ -0,0 +1,111 @@
FUNCTION CHEAVJ(I,NJ,IGJ)
C =========================
C
C Calculates collisional excitation rates from a non-averaged (l,s)
C state of He I, with n=1, 2, 3, to some averaged state
C with n = 2, 3, 4.
C
C The rates are calculated using appropriate summations of the
C Storey-Hummer rates (calculated by procedure COLLHE, and stored
C in array COLHE1)
C
C Input:
C I - index of the lower state, using the ordering defined in
C COLLHE, ie. I=1 for 1 sing S, I=2 for 2 trip S, etc.
C NJ - principal quantum number of the (averaged) upper level
C IGJ - statistical weight of the upper level
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
CHEAVJ=0.
C
C -----------------------------------------------------
C ******** transitions to an averaged level with n=2
C -----------------------------------------------------
C
IF(NJ.EQ.2) THEN
IF(IGJ.EQ.4) THEN
C
C a) upper level is an averaged singlet state
C
CHEAVJ=COLHE1(1,3)+COLHE1(1,5)
ELSE IF(IGJ.EQ.12) THEN
C
C b) upper level is an averaged triplet state
C
CHEAVJ=COLHE1(1,2)+COLHE1(1,4)
ELSE IF(IGJ.EQ.16) THEN
C
C c) upper level is an average of both siglet and triplet states
C
CHEAVJ=COLHE1(1,3)+COLHE1(1,5)+COLHE1(1,2)+COLHE1(1,4)
ELSE
GO TO 10
END IF
C
C -----------------------------------------------------
C ******** transitions to an averaged level with n=3
C -----------------------------------------------------
C
ELSE IF(NJ.EQ.3) THEN
IF(IGJ.EQ.9) THEN
C
C a) upper level is an averaged singlet state
C
CHEAVJ=COLHE1(I,7)+COLHE1(I,11)+COLHE1(I,10)
ELSE IF(IGJ.EQ.27) THEN
C
C b) upper level is an averaged triplet state
C
CHEAVJ=COLHE1(I,6)+COLHE1(I,8)+COLHE1(I,9)
ELSE IF(IGJ.EQ.36) THEN
C
C c) upper level is an average of both siglet and triplet states
C
CHEAVJ=COLHE1(I,7)+COLHE1(I,11)+COLHE1(I,10)+
* COLHE1(I,6)+COLHE1(I,8)+COLHE1(I,9)
ELSE
GO TO 10
END IF
C
C -----------------------------------------------------
C ******** transitions to an averaged level with n=4
C -----------------------------------------------------
C
ELSE IF(NJ.EQ.4) THEN
IF(IGJ.EQ.16) THEN
C
C a) upper level is an averaged singlet state
C
CHEAVJ=COLHE1(I,13)+COLHE1(I,19)+COLHE1(I,16)+
* COLHE1(I,18)
ELSE IF(IGJ.EQ.48) THEN
C
C b) upper level is an averaged triplet state
C
CHEAVJ=COLHE1(I,12)+COLHE1(I,14)+COLHE1(I,15)+
* COLHE1(I,17)
ELSE IF(IGJ.EQ.64) THEN
C
C c) upper level is an average of both siglet and triplet states
C
CHEAVJ=COLHE1(I,13)+COLHE1(I,19)+COLHE1(I,16)+
* COLHE1(I,18)+COLHE1(I,12)+COLHE1(I,14)+
* COLHE1(I,15)+COLHE1(I,17)
ELSE
GO TO 10
END IF
ELSE
GO TO 10
END IF
RETURN
10 WRITE(6,601) NJ,IGJ
WRITE(10,601) NJ,IGJ
601 FORMAT(1H0/' INCONSISTENT INPUT TO PROCEDURE CHEAVJ'/
* ' QUANTUM NUMBER =',I3,' STATISTICAL WEIGHT',2I4)
call quit(' ',nj,igj)
END
tlusty/extracted/cia_h2h.f
+89
View File
@@ -0,0 +1,89 @@
subroutine cia_h2h(t,ah2,ah,ff,opac)
c ====================================
c
c CIA H2-H opacity - data taken from TURBOSPEC
c
IMPLICIT REAL*8(A-H,O-Z)
parameter (nlines=67)
dimension freq(nlines),temp(4),alpha(nlines,4)
parameter (amagat=2.6867774d+19,fac=1./amagat**2)
data temp / 1000. , 1500., 2000. , 2500. /
data ntemp /4/
data ifirst /0/
PARAMETER (CAS=2.997925D10)
c input frequency in Hz but needed wave numbers in cm^-1
f=ff/cas
c read in CIA tables if this is the first call
if (ifirst.eq.0) then
write(*,'(a)') 'Reading in H2-H CIA opacity tables...'
open(10,file="./data/CIA_H2H.dat",status='old')
do i=1,3
read (10,*)
end do
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
end do
close(10)
c take logarithm of tables prior to doing linear interpolations
do i=1,nlines
do j=1,ntemp
alpha(i,j)=log(alpha(i,j))
end do
end do
ifirst=1
end if
c locate position in temperature array
if(t.gt.2500.) return
call locate(temp,ntemp,t,j,ntemp)
if (j.eq.0) then
write(*,*)
write(*,'(a,f6.0,a)')
* 'Warning: requested temperature is below',temp(1),' K'
write(*,'(a)') 'CIA H2-H CIA opacity set to zero'
write(*,*)
opac=0.
return
end if
c locate position in frequency array
call locate(freq,nlines,f,i,nlines)
c linearly interpolate in frequency and temperature
if (j.eq.ntemp) then
c hold values constant if off high temperature end of table
y1=alpha(i,j)
y2=alpha(i+1,j)
tt=(f-freq(i))/(freq(i+1)-freq(i))
alp=(1.-tt)*y1 + tt*y2
else if (i.eq.0 .or. i.eq.nlines) then
c set values to a very small number if off frequency table
alp=-50.
else
c interpolate linearly within table
y1=alpha(i,j)
y2=alpha(i+1,j)
y3=alpha(i+1,j+1)
y4=alpha(i,j+1)
tt=(f-freq(i))/(freq(i+1)-freq(i))
uu=(t-temp(j))/(temp(j+1)-temp(j))
alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 +
* (1.-tt)*uu*y4
end if
alp=exp(alp)
c final opacity
opac=fac*ah2*ah*alp
c
return
end
tlusty/extracted/cia_h2h2.f
+89
View File
@@ -0,0 +1,89 @@
subroutine cia_h2h2(t,ah2,ff,opac)
c ===================--=============
c
c CIA H2-H2 opacity
c data from Borysow A., Jorgensen U.G., Fu Y. 2001, JQSRT 68, 235
c
IMPLICIT REAL*8(A-H,O-Z)
parameter (nlines=1000)
dimension freq(nlines),temp(7),alpha(nlines,7)
parameter (amagat=2.6867774d+19,fac=1./amagat**2)
data temp / 1000. , 2000. , 3000. , 4000. , 5000. , 6000. ,
* 7000. /
data ntemp /7/
data ifirst /0/
PARAMETER (CAS=2.997925D10)
c input frequency in Hz but needed wave numbers in cm^-1
f=ff/cas
c read in CIA tables if this is the first call
if (ifirst.eq.0) then
write(*,'(a)') 'Reading in H2-H2 CIA opacity tables...'
open(10,file="./data/CIA_H2H2.dat",status='old')
do i=1,3
read (10,*)
end do
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
end do
close(10)
c take logarithm of tables prior to doing linear interpolations
do i=1,nlines
do j=1,ntemp
alpha(i,j)=log(alpha(i,j))
end do
end do
ifirst=1
end if
c locate position in temperature array
call locate(temp,ntemp,t,j,ntemp)
if (j.eq.0) then
write(*,*)
write(*,'(a,f6.0,a)')
* 'Warning: requested temperature is below',temp(1),' K'
write(*,'(a)') 'CIA H2-H2 opacity set to 0'
write(*,*)
opac=0.
return
end if
c locate position in frequency array
call locate(freq,nlines,f,i,nlines)
c linearly interpolate in frequency and temperature
if (j.eq.ntemp) then
c hold values constant if off high temperature end of table
y1=alpha(i,j)
y2=alpha(i+1,j)
tt=(f-freq(i))/(freq(i+1)-freq(i))
alp=(1.-tt)*y1 + tt*y2
else if (i.eq.0 .or. i.eq.nlines) then
c set values to a very small number if off frequency table
alp=-50.
else
c interpolate linearly within table
y1=alpha(i,j)
y2=alpha(i+1,j)
y3=alpha(i+1,j+1)
y4=alpha(i,j+1)
tt=(f-freq(i))/(freq(i+1)-freq(i))
uu=(t-temp(j))/(temp(j+1)-temp(j))
alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 +
* (1.-tt)*uu*y4
end if
alp=exp(alp)
c final opacity
opac=fac*ah2*ah2*alp
c
return
end
tlusty/extracted/cia_h2he.f
+90
View File
@@ -0,0 +1,90 @@
subroutine cia_h2he(t,ah2,ahe,ff,opac)
c ======================================
c
c CIA H2-He opacity
c data from Jorgensen U.G., Hammer D., Borysow A., Falkesgaard J., 2000,
c Astronomy & Astrophysics 361, 283
c
IMPLICIT REAL*8(A-H,O-Z)
parameter (nlines=242)
dimension freq(nlines),temp(7),alpha(nlines,7)
parameter (amagat=2.6867774d+19,fac=1./amagat**2)
data temp / 1000. , 2000. , 3000. , 4000. , 5000. , 6000. ,
* 7000. /
data ntemp /7/
data ifirst /0/
PARAMETER (CAS=2.997925D10)
c input frequency in Hz but needed wave numbers in cm^-1
f=ff/cas
c read in CIA tables if this is the first call
if (ifirst.eq.0) then
write(*,'(a)') 'Reading in H2-He CIA opacity tables...'
open(10,file="./data/CIA_H2He.dat",status='old')
do i=1,3
read (10,*)
end do
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
end do
close(10)
c take logarithm of tables prior to doing linear interpolations
do i=1,nlines
do j=1,ntemp
alpha(i,j)=log(alpha(i,j))
end do
end do
ifirst=1
end if
c locate position in temperature array
call locate(temp,ntemp,t,j,ntemp)
if (j.eq.0) then
write(*,*)
write(*,'(a,f6.0,a)')
* 'Warning: requested temperature is below',temp(1),' K'
write(*,'(a)') 'CIA H2-He opacity set to 0'
write(*,*)
opac=0.
return
end if
c locate position in frequency array
call locate(freq,nlines,f,i,nlines)
c linearly interpolate in frequency and temperature
if (j.eq.ntemp) then
c hold values constant if off high temperature end of table
y1=alpha(i,j)
y2=alpha(i+1,j)
tt=(f-freq(i))/(freq(i+1)-freq(i))
alp=(1.-tt)*y1 + tt*y2
else if (i.eq.0 .or. i.eq.nlines) then
c set values to a very small number if off frequency table
alp=-50.
else
c interpolate linearly within table
y1=alpha(i,j)
y2=alpha(i+1,j)
y3=alpha(i+1,j+1)
y4=alpha(i,j+1)
tt=(f-freq(i))/(freq(i+1)-freq(i))
uu=(t-temp(j))/(temp(j+1)-temp(j))
alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 +
* (1.-tt)*uu*y4
end if
alp=exp(alp)
c final opacity
opac=fac*ah2*ahe*alp
c
return
end
tlusty/extracted/cia_hhe.f
+89
View File
@@ -0,0 +1,89 @@
subroutine cia_hhe(t,ah,ahe,ff,opac)
c ====================================
c
c CIA H-He opacity
c data from Gustafsson M., Frommhold, L. 2001, ApJ 546, 1168
c
IMPLICIT REAL*8(A-H,O-Z)
parameter (nlines=43)
dimension freq(nlines),temp(11),alpha(nlines,11)
parameter (amagat=2.6867774d+19,fac=1./amagat**2)
data temp / 1000., 1500., 2250., 3000., 4000., 5000.,
* 6000., 7000., 8000., 9000., 10000./
data ntemp /11/
data ifirst /0/
PARAMETER (CAS=2.997925D10)
c input frequency in Hz but needed wave numbers in cm^-1
f=ff/cas
c read in CIA tables if this is the first call
if (ifirst.eq.0) then
write(*,'(a)') 'Reading in H-He CIA opacity tables...'
open(10,file="./data/CIA_HHe.dat",status='old')
do i=1,3
read (10,*)
end do
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
end do
close(10)
c take logarithm of tables prior to doing linear interpolations
do i=1,nlines
do j=1,ntemp
alpha(i,j)=log(alpha(i,j))
end do
end do
ifirst=1
end if
c locate position in temperature array
call locate(temp,ntemp,t,j,ntemp)
if (j.eq.0) then
write(*,*)
write(*,'(a,f6.0,a)')
* 'Warning: requested temperature is below',temp(1),' K'
write(*,'(a)') 'CIA H-He opacity set to 0'
write(*,*)
opac=0.
return
end if
c locate position in frequency array
call locate(freq,nlines,f,i,nlines)
c linearly interpolate in frequency and temperature
if (j.eq.ntemp) then
c hold values constant if off high temperature end of table
y1=alpha(i,j)
y2=alpha(i+1,j)
tt=(f-freq(i))/(freq(i+1)-freq(i))
alp=(1.-tt)*y1 + tt*y2
else if (i.eq.0 .or. i.eq.nlines) then
c set values to a very small number if off frequency table
alp=-50.
else
c interpolate linearly within table
y1=alpha(i,j)
y2=alpha(i+1,j)
y3=alpha(i+1,j+1)
y4=alpha(i,j+1)
tt=(f-freq(i))/(freq(i+1)-freq(i))
uu=(t-temp(j))/(temp(j+1)-temp(j))
alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 +
* (1.-tt)*uu*y4
end if
alp=exp(alp)
c final opacity
opac=fac*ah*ahe*alp
c
return
end
tlusty/extracted/cion.f
+93
View File
@@ -0,0 +1,93 @@
function cion(n,j,e,t)
c
c collisional ionization rate from Raymond
c rate is returned in units cm^3/s
c inputs are: n=nuclear charge,
c j=ion stage
c e=valence shell ionization threshold (in eV)
c t=temperature in K.
c
c Tim Kallman's routine for calculating collisional ionization rates.
c Note that this routine only accounts for valence shell ionization.
c It should be called only once for each ion stage and the valence
c shell ionization threshold should be the lowest one (e.g. the 2p
c ionization potential for CI).
c
c
INCLUDE 'IMPLIC.FOR'
c
c sm younger jqsrt 26, 329; 27, 541; 29, 61 with moores for undone
c a0 for b-like ion has twice 2s plus one 2p as in summers et al
c chi = kt / i
c
dimension a0(30),a1(30),a2(30),a3(30),b0(30),b1(30),
& b2(30),b3(30),c0(30),c1(30),c2(30),c3(30),
& d0(30),d1(30),d2(30),d3(30)
c
data a0/13.5,27.0,9.07,11.80,20.2,28.6,37.0,45.4,
& 53.8,62.2,11.7,38.8,37.27,46.7,57.4,67.0,
& 77.8,90.1,106.,120.8,135.6,150.4,165.2,180.0,
& 194.8,209.6,224.4,239.2,154.0,268.8/
data a1/ - 14.2,-60.1,4.30,27*0./
data a2/40.6,140.,7.69,27*0./
data a3/ - 17.1,-89.8,-7.53,27*0./
c
data b0/ - 4.81,-9.62,-2.47,-3.28,-5.96,-8.64,-11.32,
& -14.00,-16.68,-19.36,-4.29,-16.7,-14.58,-16.95,
& -19.93,-23.05,-26.00,-29.45,-34.25,-38.92,
& -43.59,-48.26,-52.93,-57.60,-62.27,-66.94,
& -71.62,-76.29,-80.96,-85.63/
data b1/9.77,33.1,-3.78,27*0./
data b2/ - 28.3,-82.5,-3.59,27*0./
data b3/11.4,54.6,3.34,27*0./
c
data c0/1.85,3.69,1.34,1.64,2.31,2.984,3.656,4.328,
& 5.00,5.672,1.061,1.87,3.26,5.07,6.67,8.10,
& 9.92,11.79,7.953,8.408,8.863,9.318,9.773,
& 10.228,10.683,11.138,11.593,12.048,12.505,12.96/
data c1/0.,4.32,.343,27*0./
data c2/0.,-2.527,-2.46,27*0./
data c3/0.,.262,1.38,27*0./
c
data d0/ - 10.9,-21.7,-5.37,-7.58,-12.66,-17.74,
& -22.82,-27.9,-32.98,-38.06,-7.34,-28.8,-24.87,
& -30.5,-37.9,-45.3,-53.8,-64.6,-54.54,-61.70,
& -68.86,-76.02,-83.18,-90.34,-97.50,-104.66,
& -111.82,-118.98,-126.14,-133.32/
data d1/8.90,42.5,-12.4,27*0./
data d2/ - 35.7,-131.,-8.09,27*0./
data d3/16.5,87.4,1.23,27*0./
c
cion = 0.
chir = t/(11590.*e)
if ( chir.le..0115 ) return
chi=chir
if(chi.lt.0.1) ch=0.1
ch2 = chi*chi
ch3 = ch2*chi
alpha = (.001193+.9764*chi+.6604*ch2+.02590*ch3)
& /(1.0+1.488*chi+.2972*ch2+.004925*ch3)
beta = (-.0005725+.01345*chi+.8691*ch2+.03404*ch3)
& /(1.0+2.197*chi+.2457*ch2+.002503*ch3)
j2 = j*j
j3 = j2*j
iso = n - j + 1
c
a = a0(iso) + a1(iso)/j + a2(iso)/j2 + a3(iso)/j3
b = b0(iso) + b1(iso)/j + b2(iso)/j2 + b3(iso)/j3
c = c0(iso) + c1(iso)/j + c2(iso)/j2 + c3(iso)/j3
d = d0(iso) + d1(iso)/j + d2(iso)/j2 + d3(iso)/j3
c
c fe ii experimental ionization montague et al: d. neufeld fit
if ( n.eq.26 .and. j.eq.2 ) then
a = -13.825
b = -11.0395
c = 21.07262
d = 0.
endif
c
ch = 1./chi
fchi = 0.3*ch*(a+b*(1.+ch)+(c-(a+b*(2.+ch))*ch)*alpha+d*beta*ch)
cion = 2.2e-6*sqrt(chir)*fchi*expo(-1./chir)/(e*sqrt(e))
return
end
tlusty/extracted/ckoest.f
+59
View File
@@ -0,0 +1,59 @@
FUNCTION CKOEST(S,L,N,FREQ,GG)
C ==============================
C
C EVALUATES HE I PHOTOIONIZATION CROSS SECTION USING
C KOESTER'S FITS (1985, AA 149, 423)
C
C CALLING SEQUENCE INCLUDES:
C S = MULTIPLICITY, EITHER 1 OR 3
C L = ANGULAR MOMENTUM, 0, 1, OR 2;
C for L > 2 - hydrogenic expresion
C N = PRINCIPAL QUANTUM NUMBER
C FREQ = FREQUENCY
C GG = STATISTICAL WEIGHT
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INTEGER S,L,SS,LL
PARAMETER (PHOT0=2.815D29)
DIMENSION COEF(3,11),IST(3)
C
DATA IST/1,2,6/
C
DATA COEF/
. -58.229, 4.3965, -0.22134 ,
. -68.438, 5.7453, -0.26277 ,
. -67.310, 6.1831, -0.32244 ,
. -92.020, 10.313 , -0.45090 ,
. -68.936, 5.2666, -0.15812 ,
. -63.408, 3.8797, -0.12479 ,
. -63.778, 4.5102, -0.18213 ,
. -76.903, 6.3639, -0.21565 ,
. -61.027, 3.1833, -0.043675,
. -83.287, 7.1751, -0.20821 ,
. -83.287, 7.1751, -0.20821 /
C
SAVE COEF,IST
C
IF(L.GT.2) GO TO 20
C
C SELECT BEGINNING AND END OF COEFFICIENTS
C
SS=(S-1)/2
LL=2*L
NSL=IST(N)+LL+SS
C
C EVALUATE CROSS SECTION
C
X=LOG(CAS/FREQ)
CKOEST=EXP(COEF(1,NSL)+X*(COEF(2,NSL)+X*COEF(3,NSL)))/GG
RETURN
C
C Hydrogenic expression for L > 2
C [multiplied by relative population of state (s,l,n), ie.
C by stat.weight(s,l)/stat.weight(n)]
C
20 GN=TWO*N*N
CKOEST=PHOT0/FREQ/FREQ/FREQ/N**5*(2*L+1)*S/GN
RETURN
END
tlusty/extracted/colh.f
+522
View File
@@ -0,0 +1,522 @@
SUBROUTINE COLH(ID,T,COL)
C =========================
C
C Hydrogen collision rates
C
C All standard expressions are taken from Mihalas, Heasley, and
C Auer, NCAR-TN/STR-104 (1975)
C
C New expressions (also from Mihalas) for collisional ionization
C for first 10 levels taken from Klaus Werner.
C
C New standard expressions from Giovanardi et al. (1987, AAS, 70, 29)
C for collisional excitation (valid from 3000K to 500000K)
C
C Meaning of ICOL:
C a) for ionization - .ge.0 - standard expression
C < 0 - non-standard, user suplied formula
C b) for 1 - 2 transition =0 - standard theoretical formula
C = 1 - experimental fit (formula quted in
C Mihalas et al.)
C = 2 - formula by Crandall et al (procedure
C CEH12)
C c) for all other line transitions
C .ge.0 - standard expression
C < 0 - non-standard, user supplie formula
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (CC0 = 5.465D-11,
* CEX1 = -30.20581,
* CEX2 = 3.8608704,
* CEX3 = 305.63574,
* CI1 = 0.3,
* CI2 = 0.435,
* CA1 = 5.444416D7,
* CA2 = -2.8185937D4,
* CA3 = 19.987261,
* CA4 = -5.8906298D-5,
* CB1 = 1.3935312D3,
* CB2 = -1.6805859D2,
* CB3 = -2.539D3,
* CC1 = 2.0684609D3,
* CC2 = -3.341582D2,
* CC3 = -7.6440625D3,
* CD1 = 3.2174844D3,
* CD2 = -5.5882422D2,
* CD3 = -6.86325D3,
* CE1 = 5.759125D3,
* CE2 = 81.75,
* CE3 = -1.5163D3,
* CF1 = 1.461475D4,
* CF2 = 393.4,
* CF3 = -4.8284D3,
* ALF0 = 1.8,
* ALF1 = 0.4,
* BET0 = 3.0,
* BET1 = 1.2,
* O148 = 0.148,
* CHMI = 5.59D-15)
PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193,
* EXPIA3=-0.24991055,EXPIA4=0.05519968,
* EXPIA5=-0.00976004,EXPIA6=0.00107857,
* EXPIB1=0.2677734343,EXPIB2=8.6347608925,
* EXPIB3=18.059016973,EXPIB4=8.5733287401,
* EXPIC1=3.9584969228,EXPIC2=21.0996530827,
* EXPIC3=25.6329561486,EXPIC4=9.5733223454)
DIMENSION COL(MTRANS),A(6,10)
DIMENSION CCOOL(4,14,15),CHOT(4,14,15),XTT(4)
DATA ((A(I,J),J=1,10),I=1,6) /
* -86.7633398, 2632.8369 , 7478.9556 ,-4202.8442 ,-47995.930 ,
* -120942.89 ,-202300.81 ,-261373.03 ,-266337.91 ,-192293.20 ,
* 100.919188 ,-2738.7485 ,-8495.4590 , 1937.3763 , 45825.371 ,
* 122209.39 , 211928.67 , 285044.75 , 309455.47 , 258802.22 ,
* -45.7813807, 1121.3976 , 3794.6826 , 340.35764 ,-16617.055 ,
* -47390.313 ,-84973.688 ,-117833.95 ,-133243.61 ,-120363.95 ,
* 10.1978559 ,-224.30670 ,-822.83636 ,-290.10489 , 2905.7393 ,
* 8944.6025 , 16556.992 , 23544.543 , 27419.742 , 26002.143 ,
* -1.11223557, 21.923729 , 86.619110 , 48.840523 ,-246.99014 ,
* -828.41028 ,-1581.2722 ,-2297.9321 ,-2738.1743 ,-2686.4087 ,
* .0474198818,-.83974838,-3.5534720 ,-2.6097214 , 8.1972208 ,
* 30.267115 , 59.521984 , 88.178680 , 107.05288 , 107.73775 /
C
DATA ((CCOOL(I, 1, K),I=1,4),K=1,15)/ 4*0.,
& 5.742D-01, 1.818D-05,-1.093D-10, 8.687D-16,
& 1.934D-01,-4.698D-07, 8.352D-11,-5.576D-16,
& 6.323D-03, 2.237D-06,-1.620D-11, 8.955D-17,
& 2.035D-02, 6.076D-07,-2.175D-13,-2.495D-18,
& 1.136D-02, 3.428D-07,-1.467D-13,-1.300D-18,
& 6.999D-03, 2.126D-07,-9.963D-14,-7.672D-19,
& 4.624D-03, 1.410D-07,-6.969D-14,-4.927D-19,
& 3.217D-03, 9.836D-08,-5.031D-14,-3.361D-19,
& 2.329D-03, 7.135D-08,-3.737D-14,-2.400D-19,
& 1.741D-03, 5.342D-08,-2.845D-14,-1.775D-19,
& 1.336D-03, 4.103D-08,-2.213D-14,-1.351D-19,
& 1.048D-03, 3.220D-08,-1.754D-14,-1.053D-19,
& 8.369D-04, 2.574D-08,-1.413D-14,-8.368D-20,
& 6.791D-04, 2.090D-08,-1.154D-14,-6.763D-20/
DATA ((CCOOL(I, 2, K),I=1,4),K=1,15)/ 8*0.,
& 2.253D+01, 9.350D-04, 1.215D-08,-9.969D-14,
& 7.816D-01, 5.414D-04,-1.827D-09, 5.140D-17,
& 1.459D+00, 2.858D-04,-2.207D-09, 9.028D-15,
& 7.172D-01, 1.440D-04,-1.139D-09, 4.755D-15,
& 4.107D-01, 8.360D-05,-6.699D-10, 2.823D-15,
& 2.591D-01, 5.319D-05,-4.293D-10, 1.819D-15,
& 1.747D-01, 3.608D-05,-2.925D-10, 1.243D-15,
& 1.237D-01, 2.567D-05,-2.087D-10, 8.891D-16,
& 9.097D-02, 1.893D-05,-1.539D-10, 6.585D-16,
& 6.896D-02, 1.438D-05,-1.174D-10, 5.017D-16,
& 5.356D-02, 1.119D-05,-9.150D-11, 3.913D-16,
& 4.247D-02, 8.887D-06,-7.272D-11, 3.112D-16,
& 3.425D-02, 7.176D-06,-5.877D-11, 2.516D-16/
DATA ((CCOOL(I, 3, K),I=1,4),K=1,15)/ 12*0.,
& -1.290D+01, 2.059D-02, 5.461D-08,-9.082D-13,
& 3.562D+02, 7.337D-03,-9.622D-08, 5.596D-13,
& 5.744D+00, 3.570D-03,-3.259D-08, 1.452D-13,
& 2.968D+00, 1.813D-03,-1.703D-08, 7.744D-14,
& 1.756D+00, 1.065D-03,-1.016D-08, 4.667D-14,
& 1.135D+00, 6.865D-04,-6.601D-09, 3.053D-14,
& 7.802D-01, 4.713D-04,-4.558D-09, 2.116D-14,
& 5.615D-01, 3.390D-04,-3.292D-09, 1.532D-14,
& 4.189D-01, 2.528D-04,-2.461D-09, 1.148D-14,
& 3.213D-01, 1.939D-04,-1.891D-09, 8.833D-15,
& 2.523D-01, 1.522D-04,-1.487D-09, 6.953D-15,
& 2.018D-01, 1.218D-04,-1.192D-09, 5.576D-15/
DATA ((CCOOL(I, 4, K),I=1,4),K=1,15)/ 16*0.,
& 4.139D+03, 4.645D-01,-7.097D-06, 4.388D-11,
& 1.794D+03, 4.443D-02,-6.484D-07, 3.936D-12,
& 1.536D+01, 2.042D-02,-2.065D-07, 9.734D-13,
& 8.730D+00, 1.033D-02,-1.074D-07, 5.161D-13,
& 5.434D+00, 6.084D-03,-6.423D-08, 3.116D-13,
& 3.628D+00, 3.938D-03,-4.196D-08, 2.048D-13,
& 2.554D+00, 2.718D-03,-2.914D-08, 1.428D-13,
& 1.873D+00, 1.967D-03,-2.119D-08, 1.041D-13,
& 1.418D+00, 1.476D-03,-1.594D-08, 7.843D-14,
& 1.102D+00, 1.138D-03,-1.232D-08, 6.075D-14,
& 8.744D-01, 8.987D-04,-9.746D-09, 4.809D-14/
DATA ((CCOOL(I, 5, K),I=1,4),K=1,15)/ 20*0.,
& -9.122D+02, 1.260D+00,-1.070D-05, 4.290D-11,
& 3.959D+01, 2.108D-01,-2.162D-06, 1.020D-11,
& 3.691D+01, 7.806D-02,-8.485D-07, 4.166D-12,
& 2.352D+01, 3.911D-02,-4.365D-07, 2.179D-12,
& 1.542D+01, 2.296D-02,-2.601D-07, 1.310D-12,
& 1.062D+01, 1.487D-02,-1.699D-07, 8.608D-13,
& 7.642D+00, 1.029D-02,-1.183D-07, 6.014D-13,
& 5.695D+00, 7.464D-03,-8.621D-08, 4.394D-13,
& 4.368D+00, 5.617D-03,-6.508D-08, 3.323D-13,
& 3.430D+00, 4.348D-03,-5.051D-08, 2.583D-13/
DATA ((CCOOL(I, 6, K),I=1,4),K=1,15)/ 24*0.,
& -3.431D+03, 4.116D+00,-3.853D-05, 1.679D-10,
& 4.397D+01, 6.434D-01,-7.008D-06, 3.431D-11,
& 8.927D+01, 2.325D-01,-2.667D-06, 1.350D-11,
& 6.153D+01, 1.152D-01,-1.354D-06, 6.957D-12,
& 4.165D+01, 6.729D-02,-8.024D-07, 4.156D-12,
& 2.923D+01, 4.349D-02,-5.232D-07, 2.724D-12,
& 2.130D+01, 3.008D-02,-3.641D-07, 1.902D-12,
& 1.603D+01, 2.185D-02,-2.656D-07, 1.391D-12,
& 1.239D+01, 1.647D-02,-2.008D-07, 1.054D-12/
DATA ((CCOOL(I, 7, K),I=1,4),K=1,15)/ 28*0.,
& -9.280D+03, 1.116D+01,-1.122D-04, 5.167D-10,
& 6.658D+01, 1.651D+00,-1.884D-05, 9.487D-11,
& 2.172D+02, 5.833D-01,-6.977D-06, 3.615D-11,
& 1.535D+02, 2.858D-01,-3.499D-06, 1.838D-11,
& 1.049D+02, 1.660D-01,-2.060D-06, 1.090D-11,
& 7.412D+01, 1.070D-01,-1.339D-06, 7.118D-12,
& 5.428D+01, 7.389D-02,-9.304D-07, 4.963D-12,
& 4.103D+01, 5.366D-02,-6.786D-07, 3.629D-12/
DATA ((CCOOL(I, 8, K),I=1,4),K=1,15)/ 32*0.,
& -2.069D+04, 2.637D+01,-2.802D-04, 1.342D-09,
& 2.055D+02, 3.731D+00,-4.420D-05, 2.276D-10,
& 5.123D+02, 1.292D+00,-1.599D-05, 8.442D-11,
& 3.578D+02, 6.265D-01,-7.922D-06, 4.235D-11,
& 2.438D+02, 3.616D-01,-4.633D-06, 2.494D-11,
& 1.721D+02, 2.322D-01,-3.000D-06, 1.622D-11,
& 1.260D+02, 1.601D-01,-2.081D-06, 1.129D-11/
DATA ((CCOOL(I, 9, K),I=1,4),K=1,15)/ 36*0.,
& -4.032D+04, 5.614D+01,-6.231D-04, 3.073D-09,
& 6.989D+02, 7.655D+00,-9.352D-05, 4.903D-10,
& 1.141D+03, 2.605D+00,-3.313D-05, 1.777D-10,
& 7.755D+02, 1.250D+00,-1.624D-05, 8.808D-11,
& 5.234D+02, 7.175D-01,-9.437D-06, 5.153D-11,
& 3.677D+02, 4.590D-01,-6.087D-06, 3.338D-11/
DATA ((CCOOL(I,10, K),I=1,4),K=1,15)/ 40*0.,
& -7.097D+04, 1.101D+02,-1.266D-03, 6.390D-09,
& 2.018D+03, 1.455D+01,-1.824D-04, 9.708D-10,
& 2.383D+03, 4.875D+00,-6.348D-05, 3.449D-10,
& 1.569D+03, 2.319D+00,-3.081D-05, 1.691D-10,
& 1.046D+03, 1.323D+00,-1.779D-05, 9.830D-11/
DATA ((CCOOL(I,11, K),I=1,4),K=1,15)/ 44*0.,
& -1.150D+05, 2.020D+02,-2.392D-03, 1.231D-08,
& 4.988D+03, 2.601D+01,-3.334D-04, 1.797D-09,
& 4.675D+03, 8.595D+00,-1.142D-04, 6.273D-10,
& 2.986D+03, 4.054D+00,-5.491D-05, 3.046D-10/
DATA ((CCOOL(I,12, K),I=1,4),K=1,15)/ 48*0.,
& -1.737D+05, 3.511D+02,-4.263D-03, 2.227D-08,
& 1.094D+04, 4.419D+01,-5.774D-04, 3.146D-09,
& 8.673D+03, 1.442D+01,-1.950D-04, 1.082D-09/
DATA ((CCOOL(I,13, K),I=1,4),K=1,15)/ 52*0.,
& -2.459D+05, 5.829D+02,-7.233D-03, 3.830D-08,
& 2.191D+04, 7.194D+01,-9.561D-04, 5.259D-09/
DATA ((CCOOL(I,14, K),I=1,4),K=1,15)/ 56*0.,
& -3.273D+05, 9.312D+02,-1.178D-02, 6.306D-08/
DATA ((CHOT(I, 1, K),I=1,4),K=1,15)/ 4*0.,
& 5.856D-01, 1.551D-05,-9.669D-12, 5.716D-19,
& 1.537D-01, 3.548D-06,-3.224D-12, 7.626D-19,
& 2.400D-02, 1.419D-06,-2.008D-12, 1.356D-18,
& 2.002D-02, 6.325D-07,-7.070D-13, 4.096D-19,
& 1.123D-02, 3.549D-07,-3.998D-13, 2.331D-19,
& 6.940D-03, 2.194D-07,-2.483D-13, 1.453D-19,
& 4.593D-03, 1.453D-07,-1.648D-13, 9.667D-20,
& 3.199D-03, 1.012D-07,-1.150D-13, 6.758D-20,
& 2.318D-03, 7.334D-08,-8.349D-14, 4.910D-20,
& 1.727D-03, 5.493D-08,-6.270D-14, 3.695D-20,
& 1.326D-03, 4.218D-08,-4.821D-14, 2.844D-20,
& 1.040D-03, 3.310D-08,-3.786D-14, 2.236D-20,
& 8.305D-04, 2.645D-08,-3.028D-14, 1.790D-20,
& 6.740D-04, 2.147D-08,-2.460D-14, 1.455D-20/
DATA ((CHOT(I, 2, K),I=1,4),K=1,15)/ 8*0.,
& 1.710D+01, 1.530D-03,-2.553D-09, 1.924D-15,
& 8.237D+00, 3.554D-04,-7.566D-10, 6.420D-16,
& 5.932D+00, 1.301D-04,-2.912D-10, 2.535D-16,
& 2.987D+00, 6.419D-05,-1.444D-10, 1.260D-16,
& 1.733D+00, 3.689D-05,-8.324D-11, 7.267D-17,
& 1.102D+00, 2.334D-05,-5.273D-11, 4.605D-17,
& 7.472D-01, 1.576D-05,-3.567D-11, 3.116D-17,
& 5.312D-01, 1.118D-05,-2.532D-11, 2.212D-17,
& 3.919D-01, 8.232D-06,-1.865D-11, 1.630D-17,
& 2.977D-01, 6.245D-06,-1.416D-11, 1.237D-17,
& 2.315D-01, 4.855D-06,-1.101D-11, 9.622D-18,
& 1.838D-01, 3.851D-06,-8.734D-12, 7.635D-18,
& 1.484D-01, 3.108D-06,-7.050D-12, 6.164D-18/
DATA ((CHOT(I, 3, K),I=1,4),K=1,15)/ 12*0.,
& 1.940D+02, 1.949D-02,-3.832D-08, 3.137D-14,
& 4.729D+02, 1.927D-03,-4.171D-09, 3.628D-15,
& 6.741D+01, 1.315D-03,-3.145D-09, 2.814D-15,
& 3.444D+01, 6.477D-04,-1.560D-09, 1.399D-15,
& 2.031D+01, 3.744D-04,-9.054D-10, 8.130D-16,
& 1.311D+01, 2.388D-04,-5.789D-10, 5.203D-16,
& 9.007D+00, 1.629D-04,-3.955D-10, 3.556D-16,
& 6.484D+00, 1.166D-04,-2.835D-10, 2.550D-16,
& 4.837D+00, 8.666D-05,-2.108D-10, 1.896D-16,
& 3.711D+00, 6.631D-05,-1.614D-10, 1.452D-16,
& 2.914D+00, 5.194D-05,-1.265D-10, 1.138D-16,
& 2.332D+00, 4.150D-05,-1.011D-10, 9.100D-17/
DATA ((CHOT(I, 4, K),I=1,4),K=1,15)/ 16*0.,
& 7.204D+03, 1.627D-01,-5.181D-07, 5.605D-13,
& 2.507D+03, 9.370D-03,-2.091D-08, 1.842D-14,
& 3.823D+02, 6.480D-03,-1.600D-08, 1.452D-14,
& 1.950D+02, 3.161D-03,-7.869D-09, 7.157D-15,
& 1.154D+02, 1.823D-03,-4.561D-09, 4.154D-15,
& 7.486D+01, 1.165D-03,-2.924D-09, 2.665D-15,
& 5.178D+01, 7.977D-04,-2.006D-09, 1.830D-15,
& 3.752D+01, 5.737D-04,-1.444D-09, 1.318D-15,
& 2.816D+01, 4.283D-04,-1.080D-09, 9.858D-16,
& 2.174D+01, 3.293D-04,-8.307D-10, 7.587D-16,
& 1.717D+01, 2.592D-04,-6.544D-10, 5.978D-16/
DATA ((CHOT(I, 5, K),I=1,4),K=1,15)/ 20*0.,
& 2.166D+04, 4.690D-01,-1.122D-06, 1.008D-12,
& 3.874D+03, 6.443D-02,-1.596D-07, 1.452D-13,
& 1.465D+03, 2.207D-02,-5.556D-08, 5.082D-14,
& 7.410D+02, 1.062D-02,-2.698D-08, 2.476D-14,
& 4.374D+02, 6.096D-03,-1.556D-08, 1.430D-14,
& 2.841D+02, 3.889D-03,-9.962D-09, 9.167D-15,
& 1.969D+02, 2.663D-03,-6.838D-09, 6.297D-15,
& 1.431D+02, 1.918D-03,-4.935D-09, 4.547D-15,
& 1.078D+02, 1.436D-03,-3.698D-09, 3.409D-15,
& 8.353D+01, 1.107D-03,-2.854D-09, 2.632D-15/
DATA ((CHOT(I, 6, K),I=1,4),K=1,15)/ 24*0.,
& 7.146D+04, 1.379D+00,-3.346D-06, 3.023D-12,
& 1.187D+04, 1.794D-01,-4.501D-07, 4.118D-13,
& 4.380D+03, 5.990D-02,-1.527D-07, 1.405D-13,
& 2.192D+03, 2.846D-02,-7.324D-08, 6.759D-14,
& 1.288D+03, 1.621D-02,-4.197D-08, 3.881D-14,
& 8.351D+02, 1.031D-02,-2.678D-08, 2.480D-14,
& 5.790D+02, 7.050D-03,-1.837D-08, 1.702D-14,
& 4.213D+02, 5.079D-03,-1.326D-08, 1.229D-14,
& 3.179D+02, 3.804D-03,-9.944D-09, 9.226D-15/
DATA ((CHOT(I, 7, K),I=1,4),K=1,15)/ 28*0.,
& 1.954D+05, 3.426D+00,-8.397D-06, 7.624D-12,
& 3.057D+04, 4.266D-01,-1.080D-06, 9.917D-13,
& 1.103D+04, 1.392D-01,-3.582D-07, 3.309D-13,
& 5.458D+03, 6.530D-02,-1.696D-07, 1.572D-13,
& 3.189D+03, 3.693D-02,-9.653D-08, 8.966D-14,
& 2.062D+03, 2.338D-02,-6.136D-08, 5.707D-14,
& 1.429D+03, 1.595D-02,-4.200D-08, 3.910D-14,
& 1.039D+03, 1.148D-02,-3.029D-08, 2.282D-14/
DATA ((CHOT(I, 8, K),I=1,4),K=1,15)/ 32*0.,
& 4.651D+05, 7.527D+00,-1.859D-05, 1.694D-11,
& 6.930D+04, 9.038D-01,-2.302D-06, 2.121D-12,
& 2.450D+04, 2.891D-01,-7.487D-07, 6.939D-13,
& 1.200D+04, 1.340D-01,-3.505D-07, 3.260D-13,
& 6.970D+03, 7.523D-02,-1.981D-07, 1.846D-13,
& 4.493D+03, 4.741D-02,-1.254D-07, 1.170D-13,
& 3.106D+03, 3.226D-02,-8.559D-08, 7.997D-14/
DATA ((CHOT(I, 9, K),I=1,4),K=1,15)/ 36*0.,
& 9.956D+05, 1.506D+01,-3.741D-05, 3.418D-11,
& 1.425D+05, 1.754D+00,-4.489D-06, 4.146D-12,
& 4.949D+04, 5.510D-01,-1.435D-06, 1.333D-12,
& 2.401D+04, 2.526D-01,-6.645D-07, 6.196D-13,
& 1.386D+04, 1.408D-01,-3.729D-07, 3.485D-13,
& 8.904D+03, 8.835D-02,-2.350D-07, 2.200D-13/
DATA ((CHOT(I,10, K),I=1,4),K=1,15)/ 40*0.,
& 1.961D+06, 2.798D+01,-6.982D-05, 6.394D-11,
& 2.715D+05, 3.175D+00,-8.158D-06, 7.551D-12,
& 9.279D+04, 9.821D-01,-2.567D-06, 2.390D-12,
& 4.460D+04, 4.458D-01,-1.178D-06, 1.100D-12,
& 2.561D+04, 2.468D-01,-6.566D-07, 6.150D-13/
DATA ((CHOT(I,11, K),I=1,4),K=1,15)/ 44*0.,
& 3.613D+06, 4.898D+01,-1.227D-04, 1.125D-10,
& 4.861D+05, 5.434D+00,-1.401D-05, 1.299D-11,
& 1.638D+05, 1.658D+00,-4.348D-06, 4.054D-12,
& 7.810D+04, 7.456D-01,-1.976D-06, 1.850D-12/
DATA ((CHOT(I,12, K),I=1,4),K=1,15)/ 48*0.,
& 6.300D+06, 8.163D+01,-2.051D-04, 1.884D-10,
& 8.271D+05, 8.881D+00,-2.296D-05, 2.131D-11,
& 2.753D+05, 2.676D+00,-7.037D-06, 6.571D-12/
DATA ((CHOT(I,13, K),I=1,4),K=1,15)/ 52*0.,
& 1.049D+07, 1.305D+02,-3.288D-04, 3.025D-10,
& 1.348D+06, 1.396D+01,-3.617D-05, 3.361D-11/
DATA ((CHOT(I,14, K),I=1,4),K=1,15)/ 56*0.,
& 1.680D+07, 2.016D+02,-5.089D-04, 4.687D-10/
C
HKT=HK/T
CT=CC0*SQRT(T)
TK=HKT/H
t0=t
X=LOG10(T)
X2=X*X
X3=X*X2
X4=X2*X2
X5=X3*X2
XTT(1)=1.
XTT(2)=T
XTT(3)=T*T
XTT(4)=T*T*T
SQT=SQRT(T)
N0HN=NFIRST(IELH)
N1H=NLAST(IELH)
NKH=NKA(IATH)
N0Q=NQUANT(N1H)+1
N1Q=ICUP(IELH)
DO 200 II=N0HN,N1H
I=II-N0HN+1
IT=ITRA(II,NKH)
IF(IT.EQ.0) GO TO 100
C
C *************** Collisional ionization
C
c for high temperature, use XSTAR formulae
C
if(t0.gt.1.e6) then
rno=16.
izc=1
call irc(i,t0,izc,rno,cs)
col(it)=cs
go to 100
end if
C
IC=ICOL(IT)
U0=FR0(IT)*HKT
IF(IC.LT.0) GO TO 90
if(ifwop(ii).lt.0) go to 95
GAM=I*I*I
IF(I.GT.10) GO TO 80
GAM=A(1,I)+A(2,I)*X+A(3,I)*X2+A(4,I)*X3
* +A(5,I)*X4+A(6,I)*X5
80 COL(IT)=CT*EXP(-U0)*GAM
GO TO 100
C
C non-standard (user supplied) formula
C
90 CALL CSPEC(II,NKH,IC,OSC0(IT),CPAR(IT),U0,T,COL(IT))
go to 100
c
c ionization from the merged state
c
95 sum1=0.
sum2=0.
ehk=eh/tk
n00q=nquant(n1h-1)+1
n11q=nlmx
do img=n00q,n11q
xi=img
xii=xi*xi
sum1=sum1+xii*xii*xi*wnhint(img,id)
sum2=sum2+xii*wnhint(img,id)*exp(ehk/xii)
end do
col(it)=ct*sum1/sum2
go to 200
C
C ***************** Collisional excitation
C
100 CONTINUE
I1=I+1
XI=I
VI=XI*XI
ALF=ALF0-ALF1/VI
BET=BET0-BET1/XI
NHL=N1H-N0HN+1
IF(N1Q.GT.0) NHL=N1Q
N1HC=N1H
IF(IFWOP(N1H).LT.0) THEN
NHL=NLMX
N1HC=N1H-1
END IF
CSUM=0.
IF(I1.GT.NHL) GO TO 200
CSCA=8.63D-6/2./VI/SQT
DO 190 J=I1,NHL
XJ=J
VJ=XJ*XJ
IC=0
JJ=J+N0HN-1
IF(JJ.GT.N1HC) GO TO 150
ICT=ITRA(II,JJ)
IF(ICT.EQ.0) GO TO 190
IC=ICOL(ICT)
U0=FR0(ICT)*HKT
E=U0/EH/TK
C1=OSC0(ICT)
IF(IC.LT.0) THEN
CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT))
ELSE IF(IC.EQ.0) THEN
GO TO 160
ELSE IF(IC.EQ.1) THEN
COL(ICT)=CT*EXP(-U0)*(CEX1+CEX2*X+CEX3/X/X)
ELSE IF(IC.GE.2) THEN
COL(ICT)=CEH12(T)
END IF
GO TO 190
C
C collisional excitations from level I to higher, non-explicit
C levels are lumped into the collisional ionization rate
C (the so-called modified collision ionization rate)
C
150 CONTINUE
E=UN/VI-UN/VJ
U0=EH*E*TK
IF(J.LE.20) C1=OSH(I,J)
IF(J.GT.20) THEN
C1=OSH(I,20)*((400.-VI)/20.*XJ/(VJ-VI))**3
end if
160 CONTINUE
C
IF(ICOLHN.EQ.1.AND.J.LE.7) GO TO 250
IF(ICOLHN.EQ.2.AND.J.LE.15) GO TO 260
C
C Old standard formula for the collisional excitation rate - used for
C rates in explicit transitions as well as for evaluation of the
C modified collisional rate
C
IF(ICOLHN.EQ.1.AND.J.LE.7) GO TO 250
IF(ICOLHN.EQ.2.AND.J.LE.15) GO TO 260
CS=4.*CT*C1/E/E
EX=EXP(-U0)
IF(U0.LE.UN) THEN
E1=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
E1=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
E5=E1
DO IX=1,4
E5=(EX-U0*E5)/IX
END DO
CS=CS*U0*(E1+O148*U0*E5)
IF(J-I.NE.1) CS=CS*(BET+TWO*(ALF-BET)/(XJ-XI))
GO TO 180
C End of the old standard formula (Mihalas et al 1975)
C
c Butler new calculations
c
250 call butler(i,j,t,u0,cs,ierr)
go to 180
c
C Giovanardi et al. 1987, AAS, 70, 269
C Cool: T<=60000K ; Hot: T>60000K
C
260 IF(T.GT.60000.) GO TO 270
CS=CCOOL(1,I,J)
DO ICA=2,4
CS=CS+CCOOL(ICA,I,J)*XTT(ICA)
END DO
GO TO 280
270 CS=CHOT(1,I,J)
DO ICA=2,4
CS=CS+CHOT(ICA,I,J)*XTT(ICA)
END DO
280 CS=CSCA*CS*EXP(-U0)
C
180 IF(JJ.GT.N1HC) THEN
CSUM=CSUM+CS
ELSE
COL(ICT)=CS
END IF
190 CONTINUE
IF(IT.NE.0.AND.N1Q.GT.0) COL(IT)=COL(IT)+CSUM
ITH=ITRA(II,N1H)
IF(IFWOP(N1H).LT.0.AND.ITH.GT.0) COL(ITH)=CSUM
200 CONTINUE
C
C special standard formula for collisional ionization of H-
C
IF(IELHM.EQ.0) RETURN
IT=ITRA(NFIRST(IELHM),N0HN)
IF(IT.EQ.0) RETURN
IC=ICOL(IT)
IF(IC.GE.0) THEN
COL(IT)=CHMI*T*SQRT(T)
ELSE
C
C if desired, non-standard, user supplied, formula for H-
C
U0=ENION(NFIRST(IELHM))*TK
CALL CSPEC(NFIRST(IELHM),N0HN,IC,OSC0(IT),CPAR(IT),U0,T,CS)
COL(IT)=CS
END IF
RETURN
END
tlusty/extracted/colhe.f
+355
View File
@@ -0,0 +1,355 @@
SUBROUTINE COLHE(T,COL)
C =======================
C
C Helium (both neutral and ionized) collision rates
C
C Meaning of ICOL: for all kinds of transitions and for both HeI
C and HeII:
C ICOL = 0 - approximate expressions taken from Mihalas, Heasley
C and Auer, NCAR-TN/STR-104 (1975) - for He I and II
C
C New expression for He II collisional ionization from Klaus Werner
C (ICOL >= 1) (also originally from Mihalas)
C
C For He I bound-bound transitions, the following standard
C possibilities are also available:
C
C ICOL = 1, 2, or 3 - much more accurate Storey's rates,
C subroutine written by D.G.Hummer (COLLHE).
C This procedure can be used only for transitions
C between states with n = 1, 2, 3, 4.
C ICOL = 1 - means that a given transition is a transition
C between non-averaged (l,s) states. In this case,
C labeling of the He I energy levels must agree
C with that given in subroutine COLLHE, ie. states
C have to be labeled sequentially in order of
C increasing frequency.
C ICOL = 2 - means that a given transition is a transition between
C a non-averaged (l,s) lower state and averaged upper
C state.
C ICOL = 3 - means that a given transition is a transition between
C two averaged states.
C Note:
C The program allows only two standard possibilities of
C constructing averaged levels of He I:
C i) all states within given principal quantum number n (>1) are
C lumped together
C ii) all siglet states for given n, and all triplet states for
C given n are lumped together separately (there are thus two
C explicit levels for a given n).
C If the user wants to use another averaging, he had to take care
C of appropriate averaged collisional rates himself (by updating
C subroutine CSPEC)
C
C
C ICOL < 0 - non-standard, user supplied formula
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
DIMENSION COL(MTRANS)
DIMENSION FHE1(16),G0(3),G1(3),G2(3),G3(3),A(6,10)
PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193,
* EXPIA3=-0.24991055,EXPIA4=0.05519968,
* EXPIA5=-0.00976004,EXPIA6=0.00107857,
* EXPIB1=0.2677734343,EXPIB2=8.6347608925,
* EXPIB3=18.059016973,EXPIB4=8.5733287401,
* EXPIC1=3.9584969228,EXPIC2=21.0996530827,
* EXPIC3=25.6329561486,EXPIC4=9.5733223454)
DATA FHE1/0.,2.75D-1,7.29D-2,2.96D-2,1.48 D-2,8.5D-3,5.3D-3,
* 3.5D-3,2.5D-3,1.8D-3,1.5D-3,1.2D-3,9.4D-4,7.5D-4,
* 6.1D-4,5.3D-4/
DATA G0/ 7.3399521D-2, 1.7252867, 8.6335087 /,
* G1/-1.4592763D-7, 2.0944117D-6, 2.7575544D-5 /,
* G2/ 7.6621299D5, 5.4254879D6, 6.6395519D6 /,
* G3/ 2.3775439D2, 2.2177891D3, 5.20725D3 /
DATA ((A(I,J),J=1,10),I=1,6) /
* -8.5931587 , 85.014091 , 923.64099, 2018.6470, 1551.5061 ,
* -2327.4819 ,-10701.481 ,-27619.789,-41099.602,-61599.023 ,
* 9.3868790 ,-78.834488 ,-969.18451,-2243.1768,-2059.9768 ,
* 1546.7107 , 9834.3447 , 27067.436, 41421.254, 63594.133 ,
* -4.0027571 , 28.360615 , 401.23965, 983.83374, 1051.4103 ,
* -204.82320 ,-3335.4211 ,-10100.119,-15863.257,-24949.125 ,
* 0.83941799 ,-4.7963457 ,-81.122566,-209.86169,-251.30855 ,
* -43.175175 , 530.37292 , 1826.1049, 2941.6460, 4740.8364 ,
* -.86396709E-01,0.37385577 , 8.0078983, 21.757591, 28.375637 ,
* 11.890312 ,-39.536087 ,-161.52513,-266.86011,-440.88257 ,
* 0.34853835E-02,-.10401310E-01,-.30957383,-.87988985,-1.2254572 ,
* -.72724497 , 1.0879648 , 5.6239786, 9.5323009, 16.150818 /
SAVE FHE1,G0,G1,G2,G3
C
HKT=HK/T
TK=HKT/H
SRT=SQRT(T)
t0=t
CT=5.465D-11*SRT
CT1=5.4499487/T/SRT
C
C --------------
C Neutral helium
C --------------
C
IF(IELHE1.EQ.0) GO TO 60
ICALL=0
N0I=NFIRST(IELHE1)
N1I=NLAST(IELHE1)
NKI=NNEXT(IELHE1)
N0Q=NQUANT(NLAST(IELHE1))+1
N1Q=ICUP(IELHE1)
DO 50 II=N0I,N1I
IT=ITRA(II,NKI)
IF(IT.EQ.0) GO TO 10
C
C ******** Collisional ionization
C
IC=ICOL(IT)
C1=OSC0(IT)
C2=CPAR(IT)
U0=ENION(II)*TK
IF(IC.GE.0) THEN
U1=U0+0.27
U2=(U0+3.43)/(U0+1.43)**3
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
IF(U1.LE.UN) THEN
EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+
* U1*(EXPIA5+U1*EXPIA6))))
ELSE
EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+
* U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+
* U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1
END IF
COL(IT)=CT*C1*U0*(EXPIU0-U0*(0.728*EXPIU1/U1+
* 0.189*EXP(-U0)*U2))
ELSE
CALL CSPEC(II,NKI,IC,C1,C2,U0,T,COL(IT))
END IF
10 IF(II.GE.N1I) GO TO 30
C
C ********* Collisional excitation
C
DO 20 JJ=II+1,N1I
ICT=ITRA(II,JJ)
IF(ICT.EQ.0) GO TO 20
IC=ICOL(ICT)
C1=OSC0(ICT)
C2=CPAR(ICT)
U0=FR0(ICT)*HKT
IF(IC.EQ.0) THEN
C
C *** ICOL = 0 Formula used by Mihalas, Heasley, and Auer
C
IF(U0.LE.UN) THEN
EX=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EX=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
IF(II.EQ.N0I) THEN
C
C excitation from the ground state
C
COL(ICT)=CT1*EX/U0*C1
ELSE
C
C transitions between excited states
C
U1=U0+0.2
IF(U1.LE.UN) THEN
EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+
* U1*(EXPIA5+U1*EXPIA6))))
ELSE
EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+
* U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+
* U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1
END IF
COL(ICT)=CT1/U0*(EX-U0/U1*0.81873*EXPIU1)*C1
END IF
ELSE IF(IC.EQ.1) THEN
C
C *** ICOL = 1 Storey - Hummer collisional rates between
C non-averaged states
C (Note: procedure COLLHE, which calculates all rates,
C is called only once)
C
IF(ICALL.EQ.0) CALL COLLHE(T,COLHE1)
ICALL=1
COL(ICT)=COLHE1(II-N0I+1,JJ-N0I+1)
ELSE IF(IC.EQ.2.OR.IC.EQ.3) THEN
C
C *** ICOL = 2 or 3 Storey - Hummer collisional rates between
C averaged states
C
IF(ICALL.EQ.0) CALL COLLHE(T,COLHE1)
ICALL=1
COL(ICT)=CHEAV(II,JJ,IC)
ELSE IF(IC.LT.0) THEN
C
C Non-standard, user supplied formula
C
CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT))
END IF
20 CONTINUE
C
C collisional excitations from level II to higher, non-explicit
C levels are lumped into the collisional ionization rate
C (the so-called modified collision ionization rate);
C the individual rates are calculated by expressions used by
C Mihalas, Heasley, and Auer
C
30 IF(N1Q.EQ.0.OR.IT.EQ.0) GO TO 50
I=NQUANT(II)
REL=G(II)/2./I/I
DO 40 J=N0Q,N1Q
XJ=J
U0=(ENION(II)-EH/XJ/XJ)*TK
IF(I.EQ.1) THEN
GAM=0.
C1=FHE1(J)
ELSE
C1=OSH(I,J)*REL
U1=U0+0.2
IF(U1.LE.UN) THEN
EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+
* U1*(EXPIA5+U1*EXPIA6))))
ELSE
EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+
* U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+
* U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1
END IF
GAM=U0/U1*0.81873*EXPIU1
END IF
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
COL(IT)=COL(IT)+CT1/U0*C1*(EXPIU0-GAM)
40 CONTINUE
50 CONTINUE
C
C --------------
C Ionized helium
C --------------
C
60 IF(IELHE2.EQ.0) RETURN
N0I=NFIRST(IELHE2)
N1I=NLAST(IELHE2)
NKI=NNEXT(IELHE2)
N0Q=NQUANT(NLAST(IELHE2))+1
N1Q=ICUP(IELHE2)
X=LOG10(T)
X2=X*X
X3=X2*X
X4=X3*X
X5=X4*X
CT2=3.7036489/T/SRT
C
DO 200 II=N0I,N1I
I=II-N0I+1
IT=ITRA(II,NKI)
IF(IT.EQ.0) GO TO 100
C
C ********* Collisional ionization
C
c for high temperature, use XSTAR formulae
C
if(t0.gt.1.e5) then
rno=16.
izc=2
call irc(i,t0,izc,rno,cs)
col(it)=cs
go to 100
end if
C
IC=ICOL(IT)
U0=FR0(IT)*HKT
IF(IC.EQ.0) THEN
IF(I.LE.3) THEN
GAM=G0(I)-G1(I)*T+(G2(I)/T-G3(I))/T
ELSE IF(I.EQ.4) THEN
GAM=-95.23828+(62.656249-8.1454078*X)*X
ELSE IF(I.EQ.5) THEN
GAM=472.99219-74.144287*X-1869.6562/X2
ELSE IF(I.EQ.6) THEN
GAM=825.17186-134.23096*X-2739.4375/X2
ELSE IF(I.EQ.7) THEN
GAM=1181.3516-200.71191*X-2810.7812/X2
ELSE IF(I.EQ.8) THEN
GAM=1440.1016-259.75781*X-1283.5625/X2
ELSE IF(I.EQ.9) THEN
GAM=2492.1250-624.84375*X+30.101562*X2
ELSE IF(I.EQ.10) THEN
GAM=4663.3129-1390.1250*X+97.671874*X2
ELSE
GAM=I*I*I
END IF
COL(IT)=CT*EXP(-U0)*GAM
ELSE IF(IC.GE.1) THEN
GAM=I*I*I
IF(I.LE.10) GAM=A(1,I)+A(2,I)*X+A(3,I)*X2+
* A(4,I)*X3+A(5,I)*X4+A(6,I)*X5
COL(IT)=CT*EXP(-U0)*GAM
ELSE
CALL CSPEC(II,NKI,IC,OSC0(IT),CPAR(IT),U0,T,COL(IT))
END IF
C
100 I1=I+1
XI=I
VI=XI*XI
NHL=N1I-N0I+1
IF(N1Q.GT.0) NHL=N1Q
IF(I1.GT.NHL) GO TO 200
C
C ********** collisional excitation
C
C both explicit transitions as well as contributions to the
C modified collisional ionization rate
C
DO 150 J=I1,NHL
JJ=J+N0I-1
IC=0
IF(JJ.GT.N1I) GO TO 110
ICT=ITRA(II,JJ)
IF(ICT.EQ.0) GO TO 150
IC=ICOL(ICT)
110 XJ=J
VJ=XJ*XJ
U0=ENION(N0I)*(1./VI-1./VJ)*TK
IF(J.LE.20) C1=OSH(I,J)
IF(J.GT.20) C1=OSH(I,20)*(20./XJ)**3
IF(IC.LT.0) GO TO 120
GAM=XI-(XI-1.)/(XJ-XI)
IF(GAM.GT.XJ-XI) GAM=XJ-XI
IF(I.GT.1) GAM=GAM*1.1
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
CS=CT2/U0*C1*(0.693*EXP(-U0)+EXPIU0)*GAM
GO TO 130
120 CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT))
GO TO 150
130 IF(JJ.GT.N1I) GO TO 140
COL(ICT)=CS
GO TO 150
140 IF(IT.NE.0) COL(IT)=COL(IT)+CS
150 CONTINUE
200 CONTINUE
RETURN
END
tlusty/extracted/colis.f
+443
View File
@@ -0,0 +1,443 @@
SUBROUTINE COLIS(ID,T,COL,CLOC)
C ===============================
C
C Driving procedure for evaluation of the collisional rates
C
C Input: T - temperature
C Output: COL - array of quantities proportional to the
C collisional rates in all transitions
C for a given temperature (ie. at a given depth)
C Precisely, COL(IT)*Nlow(IT) is the UPWARD
C collisional rate of the transition IT
C Output: CLOC - array of quantities proportional to the
C collisional rates in all transitions
C for a given temperature (ie. at a given depth)
C Precisely, CLOC(IT)*Nupp(IT) is the DOWNWARD
C collisional rate of the transition IT
C
C Procedure COLIS calls procedures COLH and COLHE for evaluating
C the collisional rates in hydrogen and helium,
C and itself evaluates collisional rates for other species
C
C Evaluation is controlled by input parameter ICOL(ITR).
C Meaning of ICOL for all species, excluding hydrogen and helium:
C
C a) for ionization
C ICOL = 0 - Seatons formula ; here the value of the photo-
C ionization cross section at the threshold is
C transmitted in array OSC0
C = 1 - Allen's formula; again, OSC0 has the meaning of
C the necessary multiplicative parameter
C = 2 - the so-called SIMPLE1 mode - see below
C = 3 - the so-called SIMPLE2 mode - see below
C b) for excitation
C ICOL = 0 - Van Regemorter formula, with standard g(bar)=0.25
C = 1 - Van Regemorter formula, with "exact" g(bar)
C = 2 - the so-called SIMPLE1 mode - see below
C = 3 - the so-called SIMPLE2 mode - see below
C = 4 - Eissner-Seaton formula - see below
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193,
* EXPIA3=-0.24991055,EXPIA4=0.05519968,
* EXPIA5=-0.00976004,EXPIA6=0.00107857,
* EXPIB1=0.2677734343,EXPIB2=8.6347608925,
* EXPIB3=18.059016973,EXPIB4=8.5733287401,
* EXPIC1=3.9584969228,EXPIC2=21.0996530827,
* EXPIC3=25.6329561486,EXPIC4=9.5733223454)
DIMENSION COL(MTRANS),TYPEARR(MXTCOL),CCRATE(MCFIT),
* CCTEMP(MCFIT),CLOC(MTRANS)
C
COMMON/CTRTEMP/ te
C
CREGER(X,U,A,GG)=19.7363*X*EXP(-U)/U*GG*A
CSEATN(X,U,A)=1.55D13*X/ABS(U)*EXP(-U)*A
CALLEN(X,U,A)=X*A*EXP(-U)/U/U
CSMPL1(X,U,A)=5.465D-11*X*EXP(-U)*A
CSMPL2(X,U,A)=5.465D-11*X*EXP(-U)*A*(1.+U)
CUPSX(X,U,A)=8.631D-6/X*EXP(-U)*A
C
DO I=1,NTRANS
CLOC(I)=0.
COL(I)=0.
END DO
C
C calculate collider's populations: e, p, H(1s)
C ANE : Electron
C ANP : Proton
C ANHM: H-
C ANH : H(1s)
ANE=ELEC(ID)
c
IF (IELH.gt.0) THEN ! if H is an explicit atom
ANP=POPUL(NNEXT(IELH),ID) ! Protons
ANH=POPUL(NFIRST(IELH),ID) ! H(1s)
else
anh=ahtot-anp
ENDIF
IF (IELHM.gt.0) THEN
ANHM=POPUL(NFIRST(IELHM),ID) ! if H- is an explicit atom
else
anhm=1.0353e-16/t/sqrt(t)*exp(8762.9/t)*anh*ane
ENDIF
C
HKT=HK/T
SRT=SQRT(T)
T32=UN/T/SRT
TK=HKT/H
CSTD=0.25
T0=TEFF
if(t0.gt.0.) then
TT0=UN-T/T0
SRT0=SQRT(T0)/SRT
end if
C
C Call procedures COLH and COLHE for hydrogen and helium
C
IF(IATH.NE.0) CALL COLH(ID,T,COL)
IF(IATHE.NE.0) CALL COLHE(T,COL)
IF(IATH.NE.0.OR.IATHE.NE.0) THEN
DO I=1, NTRANS
COL(I)=COL(I) * ANE
IF (LINE(I)) THEN
CLOC(I)=COL(I) * EXP(FR0(I)*HKT)*G(ILOW(I))/G(IUP(I))
ELSE
CORR=UN
NKE=NNEXT(IEL(ILOW(I)))
IF(NKE.NE.IUP(I)) CORR=G(NKE)/G(IUP(I))*
* EXP((ENION(NKE)-ENION(IUP(I)))*TK)
CLOC(I)=COL(I) * ANE * SBF(ILOW(I))*CORR
ENDIF
ENDDO
ENDIF
C
C Loop over all explicit species, excluding hydrogen and helium
C
DO 100 IAT=1,NATOM
IF(IAT.EQ.IATH.OR.IAT.EQ.IATHE) GO TO 100
N0I=N0A(IAT)
NKI=NKA(IAT)
DO 50 I=N0I,NKI-1
IE=IEL(I)
DO 40 J=I+1,NKI
IT=ITRA(I,J)
IF(IT.EQ.0) GO TO 40
IC=ICOL(IT)
COL(IT)=0.0
CLOC(IT)=0.0
C1=OSC0(IT)
C2=CPAR(IT)
U0=FR0(IT)*HKT
U0HM=U0-8752.072/T ! including H-minus potential !
U0P =U0-157821.5/T ! including H-proton potential!
DO K=1, MXTCOL
TYPEARR(K)=0
ENDDO
IF(LINE(IT)) GO TO 30
C
C the detailed balancing factor for an inverse process
C
CORR=UN
NKE=NNEXT(IEL(I))
IF(NKE.NE.J) CORR=G(NKE)/G(J)*
* EXP((ENION(NKE)-ENION(J))*TK)
CINV=ANE*SBF(I)*CORR
C
C *********** tabulated data ***************
C For collisional processes that change the total
C charge of the target atom, there are three
C processes considered here:
C - TYPE 1 Electron Collisional ionization
C - TYPE 2 Charge exchange with protons
C - TYPE 3 Charge exchange with hydrogen
C
C There are several 'calculated' options in the code for
C electron collisional excitation that are
C neglected if TYPE 1 tabulated data are present.
C
C There is also an option for TYPE 2 that is calculated
C here (ICOL ge 10) that is also overriden if TYPE 2 is
C present.
IF (IC.GE.1000) THEN
IORICE=1
IF (IC.LT.0) IORICE=-1
IC=ABS(IC)
ITYPE=IC/1000
IC=IORICE*(MOD(IC,1000)-1) !ICOL RECOVERED
DO K=1, MXTCOL
TYPEARR(K)=MOD(ITYPE/(2**(K-1)),2)
ENDDO
C
C ****** START 'GENCOL' FOR IONIZATION **********
C
C ****** ELECTRON COLLISIONAL IONIZATION *****
IF (TYPEARR(1).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(1,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(1,K,IT))
CCTEMP(K)=CTEMP(1,k,IT)
NX=NX+1
ELSE ! CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
ENDDO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
CS=ANE*exp(CS)
COL(IT)=COL(IT) + CS !UPPWARD
CLOC(IT)=CLOC(IT) + CS*CINV !DOWNWARD
ENDIF
C ****** CHARGE EXCHANGE WITH PROTONS *******
IF (TYPEARR(2).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(2,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(2,K,IT))
CCTEMP(K)=CTEMP(2,K,IT)
NX=NX+1
ELSE ! CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
ENDDO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
cs=exp(cs)*ANP
COL(IT)=COL(IT) + CS ! UPPWARD
CINH=G(I)/G(J)*0.5*EXP(U0P)
CLOC(IT)=CLOC(IT) + CS*CINH*ANH !DOWNWARD
ENDIF
C ******* CHARGE EXCHANGE WITH HYDROGEN *****
IF (TYPEARR(3).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(3,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(3,K,IT))
CCTEMP(K)=CTEMP(3,K,IT)
NX=NX+1
ELSE ! CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
ENDDO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
cs=exp(cs)*ANH
COL(IT)=COL(IT) + CS ! UPPWARD
CINH=G(I)/G(J)*TWO*EXP(U0HM)
CLOC(IT)=CLOC(IT) + CS*CINH*ANHM !DOWNWARD
ENDIF
C ************** END GENCOL ******************
IF (IC.EQ.-1) GO TO 40
ENDIF
C
C ********* Charge transfer with protons reactions- an old scheme
C
IF(IC.GE.10) THEN
IF(TYPEARR(2).NE.1) THEN
C radiative charge transfer ionization of neutrals in the
C grround state with protons
te=T
CS=HCTIon(1,NUMAT(IAT))
CS=CS*ANP
COL(IT)=COL(IT) + CS !UPPWARD
CS=CS*0.5*G(I)/G(J) * EXP(U0P)
CLOC(IT)=CLOC(IT) + CS*ANH !DOWNWARD
ENDIF
IC=IC-10
IF(TYPEARR(1).eq.1) GO TO 40
ENDIF
C
C ********* Electron collisional ionization
C
IF(IC.EQ.0) THEN
CS=CSEATN(UN/SRT,U0,C1)*ANE
COL(IT)=COL(IT)+CS
ELSE IF(IC.EQ.1) THEN
CS=CALLEN(T32,U0,C1)*ANE
COL(IT)=COL(IT)+CS
ELSE IF(IC.EQ.2) THEN
CS=CSMPL1(SRT,U0,C1)*ANE
COL(IT)=COL(IT)+CS
ELSE IF(IC.EQ.3) THEN
CS=CSMPL2(SRT,U0,C1)*ANE
COL(IT)=COL(IT)+CS
ELSE IF(IC.EQ.4) THEN
ia=numat(iatm(i))
CS=cion(ia,iz(iel(i)),enion(i)*6.24298e11,t)*ANE
COL(IT)=COL(IT)+CS
ELSE IF(IC.EQ.5) THEN
ia=numat(iatm(i))
izc=iz(ie)
rno=16.
ii=i-nfirst(ie)+1
call irc(ii,t,izc,rno,cs)
CS=CS*ANE
col(it)=COL(IT)+CS
ELSE IF(IC.LT.0) THEN
CALL CSPEC(I,J,IC,C1,C2,U0,T,CS)
CS=CS*ANE
COL(IT)=COL(IT)+CS
END IF
CLOC(IT)=CLOC(IT)+CS*CINV !DOWNWARD
if(ic.eq.4) go to 40
C
C collisional excitations from level I to higher, non-explicit
C levels are lumped into the collisional ionization rate
C (the so-called modified collision ionization rate)
C
N0Q=NQUANT(NLAST(IE))+1
N1Q=ICUP(IE)
IF(N1Q.EQ.0) GO TO 40
IQ=NQUANT(I)
REL=G(I)/2./IQ/IQ
DO 20 JQ=N0Q,N1Q
XJ=JQ
U0=(ENION(I)-EH/XJ/XJ)*TK
IF(JQ.LE.20) CC1=OSH(IQ,JQ)*REL
IF(JQ.GT.20) CC1=OSH(IQ,20)*(20./XJ)**3*REL
GG=CSTD
if(u0.gt.35.) go to 20
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+
* U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+
* U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
GG0=0.276*EXP(U0)*EXPIU0
IF(GG0.GT.GG) GG=GG0
CS=CREGER(T32,U0,CC1,GG)*ANE
COL(IT)=COL(IT)+CS !UPPWARD
CLOC(IT)=CLOC(IT)+CS*ANE*SBF(I)*WOP(I,ID)*CORR !DOWNWARD
20 CONTINUE
GO TO 40
C
C ********* Collisional excitation
C
30 CONTINUE
C
C the detailed balancing factor for an inverse process
C
CINV=EXP(U0)*G(I)/G(J)
C
c ********** Tabulated Data
IF (IC.GE.1000) THEN
IORICE=1
IF (IC.LT.0) IORICE=-1
IC=ABS(IC)
ITYPE=IC/1000
IC=IORICE*(MOD(IC,1000)-1) !ICOL RECOVERED
DO K=1, MXTCOL
TYPEARR(K)=MOD(ITYPE/(2**(K-1)),2)
END DO
C ****** START 'GENCOL' FOR EXCITATION **********
C
C ****** ELECTRON COLLISIONAL EXCITATION *****
IF (TYPEARR(1).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(1,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(1,K,IT))
CCTEMP(K)=CTEMP(1,K,IT)
NX=NX+1
ELSE !CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
END DO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
CS=exp(CS)*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD
END IF
C ****** PROTON COLLISIONAL EXCITATION *******
IF (TYPEARR(2).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(2,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(2,K,IT))
CCTEMP(K)=CTEMP(2,K,IT)
NX=NX+1
ELSE !CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
END DO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
CS=exp(CS)*ANP
COL(IT)=COL(IT) + CS ! UPPWARD
CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD
END IF
C ******* HYDROGEN COLLISIONAL EXCITATION *****
IF (TYPEARR(3).EQ.1) THEN
NX=0
DO K=1,MCFIT
IF (CTEMP(3,K,IT).NE.0) THEN
CCRATE(K)=log(CRATE(3,K,IT))
CCTEMP(K)=CTEMP(3,K,IT)
NX=NX+1
ELSE !CLEAN CC**** ARRAYS
CCRATE(K)=0.
CCTEMP(K)=0.
ENDIF
END DO
cs=ylintp(t,cctemp,ccrate,nx,mcfit)
CS=exp(CS)*ANH
COL(IT)=COL(IT) + CS ! UPPWARD
CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD
END IF
C ************** END GENCOL ******************
IF (IC.EQ.-1) GO TO 40
END IF
IF(IC.LE.1.AND.IC.GT.0) THEN
GG=CSTD
IF(IC.EQ.1) GG=C2
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+
* U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*
* (EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
GG0=0.276*EXP(U0)*EXPIU0
IF(GG0.GT.GG) GG=GG0
CS=CREGER(T32,U0,C1,GG)*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
ELSE IF(IC.EQ.2) THEN
CS=CSMPL1(SRT,U0,C1*C2)*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
ELSE IF(IC.EQ.3) THEN
CS=CSMPL2(SRT,U0,C2)*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
ELSE IF(IC.EQ.4) THEN
CS=CUPSX(SRT,U0,C2/G(I))*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
ELSE IF(IC.EQ.9) THEN
CS=OMECOL(I,J)*SRT0*EXP(-U0*TT0) * ANE
COL(IT)=COL(IT) + CS ! UPPWARD
ELSE IF(IC.LT.0) THEN
CALL CSPEC(I,J,IC,C1,C2,U0,T,CS)
CS=CS*ANE
COL(IT)=COL(IT) + CS ! UPPWARD
END IF
CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD
40 CONTINUE
50 CONTINUE
100 CONTINUE
RETURN
END
tlusty/extracted/collhe.f
+314
View File
@@ -0,0 +1,314 @@
SUBROUTINE COLLHE(TEMP,COLHE1)
C ==============================
C
C GENERATES COLLISIONAL RATE COEFFICIENTS AMONG THE 19 STATES OF
C HELIUM WITH N = 1, 2, 3, AND 4, USING RATES EVALUATED FROM THE
C CROSS SECTIONS CALCULATED BY BERRINGTON AND KINGSTON (J. PHYS.B. 20,
C 6631(1987)). COLLISIONAL RATE COEFFICIENTS HAVE BEEN EVALUATED
C NUMERICALLY BY P.J.STOREY FROM THE UNPUBLISHED COMPUTER OUTPUT
C FILES OF BERRINGTON AND KINGSTON.
C
C THE STATES INCLUDED IN THE CALCULATION ARE LABELLED SEQUENTIALLY
C IN ORDER OF INCREASING ENERGY:
C 1 1 SING S
C 2 2 TRIP S
C 3 2 SING S
C 4 2 TRIP P
C 5 2 SING P
C 6 3 TRIP S
C 7 3 SING S
C 8 3 TRIP P
C 9 3 TRIP D
C 10 3 SING D
C 11 3 SING P
C 12 4 TRIP S
C 13 4 SING S
C 14 4 TRIP P
C 15 4 TRIP D
C 16 4 SING D
C 17 4 TRIP F
C 18 4 SING F
C 19 4 SING P
C
C THIS ORDERING DIFFERS SLIGHTLY FROM THAT OF BERRINGTON AND KINGSTON,
C IN WHICH 15 AND 16, AND 17 AND 18, WERE INTERCHANGED.
C
C THE INTRINSIC ACCURACY OF TRANSITIONS AMONG STATES WITH N = 1, 2,
C AND 3 IS EXPECTED TO BE CONSIDERABLY BETTER THAN THOSE WITH N = 4
C AS DISCUSSED BY BERRINGTON AND KINGSTON. THE FITTING ACCURACY IS
C EVERYWHERE BETTER THAN 2%. THE ENERGIES OF THE LEVELS ARE TAKEN
C FROM W. C. MARTIN, PHYS. CHEM. REF. DATA., VOL.2, 257 (1973) AND
C ARE GIVEN IN ELECTRON VOLTS. (BOLTZMANN'S CONSTANT = 8.62E-5)
C
C FIRST REVISED VERSION: D.G.HUMMER, MAY 1988, JILA
C slightly modified by I.H., July 1988
C
INCLUDE 'IMPLIC.FOR'
PARAMETER (UN=1.D0,
* C1=3.849485D0,
* C2=8.49485002D-1,
* N=19)
DIMENSION ENER(19),COLHE1(19,19),
* NSTART(172),A(929),B(10),STWT(19)
C
DATA ENER/ 0.0D0,19.8198D0,20.6160D0,20.96432D0,21.2182D0,
.22.7187D0,22.9206D0,23.00731D0,23.0739D0,23.0743D0,23.0873D0,
.23.5942D0,23.6738D0,23.7081D0,23.7363D0,23.7366D0,23.7373D0,
.23.7373D0,23.7423D0/
C
DATA STWT/1.0D0,3.0D0,1.0D0,9.0D0,3.0D0,3.0D0,1.0D0,9.0D0,
.1.5D1,5.0D0,3.0D0,3.0D0,1.0D0,9.0D0,1.5D1,5.0D0,2.1D1,
.7.0D0,3.0D0/
C
DATA NSTART/
. 1, 6, 11, 16, 20, 28, 32, 40, 44, 52, 57, 62, 67, 72, 77, 82,
. 88, 92, 98,104,110,114,120,125,129,135,139,147,151,157,164,170,
.177,183,190,195,202,208,213,220,225,232,236,243,247,251,260,266,
.273,278,285,290,300,304,309,316,320,324,329,333,338,343,347,352,
.357,362,367,372,376,382,386,391,395,401,405,410,414,421,425,431,
.435,440,445,449,454,459,465,470,475,480,487,491,497,503,508,515,
.520,525,530,536,542,547,552,559,564,571,576,581,587,592,598,603,
.608,613,617,623,630,635,642,646,650,655,660,666,671,677,683,689,
.695,702,707,713,718,723,728,732,737,741,745,750,754,759,765,771,
.777,782,789,796,801,805,810,815,819,824,831,837,844,850,856,861,
.868,873,877,882,890,895,905,909,913,920,925,930/
C
DATA (A(I),I=1,95)/
. 1.7339D-07, 2.7997D-08,-1.3812D-08, 2.6639D-09, 1.7776D-09,
. 2.9820D-07, 7.5210D-08,-3.5975D-09, 3.2270D-09, 1.5245D-09,
. 1.5601D-05, 1.5340D-06,-2.2122D-06,-1.1073D-07, 1.9249D-07,
. 2.3682D-08, 1.0638D-08, 2.0959D-09, 2.8381D-10, 3.0497D-05,
. 1.9252D-05, 6.3109D-06, 6.9098D-07,-2.8039D-07,-2.1128D-07,
.-1.2192D-07,-4.4417D-08, 1.3896D-06, 1.5715D-07,-8.4358D-08,
.-2.8800D-08, 5.9599D-08, 3.4756D-08, 1.2183D-08, 3.7999D-09,
. 8.5500D-10,-3.9428D-10,-5.3999D-10,-2.2962D-10, 2.2510D-06,
. 6.1436D-07,-1.2437D-07,-7.1718D-08, 5.9026D-05, 3.8150D-05,
. 1.1426D-05, 9.2886D-07,-6.4827D-07,-4.4270D-07,-1.8611D-07,
.-5.6403D-08, 5.8752D-06, 2.5167D-06, 2.0787D-07,-2.3353D-07,
.-8.9900D-08, 5.6334D-08, 2.9313D-09, 1.7775D-09, 5.5494D-10,
.-5.8914D-10, 8.1939D-06, 2.4014D-07, 3.8681D-07, 2.8446D-07,
.-6.1936D-08, 1.8173D-06,-4.7530D-07,-6.6432D-08, 5.4898D-08,
.-1.2377D-08, 2.0732D-05, 6.5991D-07, 1.5840D-06, 4.9920D-07,
.-1.8332D-07, 3.2273D-06,-4.9880D-07,-2.4929D-07, 1.1964D-07,
.-2.1996D-08, 9.7096D-08, 1.3557D-08, 7.4404D-09, 1.3858D-09,
.-1.3778D-09,-8.4885D-10, 3.5068D-06,-5.0675D-07,-1.2252D-07,
. 6.0514D-08, 7.0524D-06, 1.4454D-06, 8.3966D-07, 2.7203D-07/
DATA (A(I),I=96,190)/
.-2.3854D-08,-8.6693D-08, 7.1193D-06, 8.3111D-09,-9.3916D-07,
.-2.7944D-08, 1.7803D-07,-3.9216D-08, 9.2760D-06, 2.4761D-06,
. 1.0095D-06, 3.4039D-07,-8.6900D-08,-1.1156D-07, 2.5036D-05,
.-5.7791D-06,-1.8197D-06, 1.0630D-06, 9.8746D-09, 3.1048D-09,
. 1.2172D-09, 1.8411D-10,-1.5835D-10,-1.4443D-10, 1.9240D-06,
. 1.5012D-07, 7.9741D-08, 2.9323D-08,-1.2796D-08, 5.0457D-07,
.-5.5146D-08,-2.7506D-08, 1.4341D-09, 1.3321D-05, 2.6960D-06,
. 2.8059D-07, 1.7548D-08,-2.3623D-07,-1.4619D-07, 1.5294D-06,
.-9.4925D-08,-1.1347D-07, 8.1980D-09, 1.3324D-04, 7.8068D-05,
. 2.9238D-05, 4.2718D-06,-1.6556D-06,-1.4529D-06,-8.6046D-07,
.-2.1062D-07, 2.8510D-06,-4.7936D-07,-2.4042D-07, 6.2333D-08,
. 1.3493D-09, 3.5113D-10,-4.7269D-11, 2.4872D-11,-9.7136D-12,
.-1.4217D-11, 1.5680D-06, 8.9272D-07, 2.8313D-07, 5.2456D-08,
.-2.3404D-08,-2.7304D-08,-8.4539D-09, 1.7967D-07, 6.2133D-08,
.-3.2814D-09,-3.7299D-09,-1.9587D-09,-1.6685D-09, 1.2707D-05,
. 7.5029D-06, 2.8330D-06, 6.7478D-07,-1.5012D-07,-2.3916D-07,
.-8.9594D-08, 7.6160D-07, 2.0422D-07,-2.5881D-08,-1.7624D-08,
.-8.3518D-09,-4.1743D-09, 4.6044D-05, 2.2425D-05, 3.3079D-06,
. 3.6752D-07,-8.4476D-08,-4.8455D-07,-2.5391D-07, 7.0824D-07/
DATA (A(I),I=191,285)/
. 1.4917D-07,-1.2005D-07,-1.6983D-08, 1.1545D-08, 7.2866D-04,
. 3.8907D-04, 9.6365D-05, 2.3153D-05, 1.8462D-07,-9.0627D-06,
.-5.4332D-06, 1.0458D-08, 1.6430D-09, 5.6453D-10, 2.0276D-10,
.-1.6501D-10,-1.0656D-10, 5.2198D-07, 4.2898D-08,-1.0332D-08,
.-5.6754D-09,-7.1960D-09, 3.0390D-06, 1.5385D-06, 6.2110D-07,
. 1.4111D-07,-3.7415D-08,-4.8395D-08,-1.7219D-08, 2.7227D-06,
. 1.4381D-07,-5.5030D-08,-2.2192D-10,-2.8583D-08, 1.8417D-05,
. 9.3860D-06, 3.9999D-06, 1.0424D-06,-2.1337D-07,-3.3271D-07,
.-1.2684D-07, 4.6063D-06,-6.7185D-07,-2.5830D-07, 2.9976D-08,
. 7.8012D-05, 3.4921D-05, 8.3012D-06, 1.5643D-06,-4.3892D-07,
.-9.5318D-07,-4.6534D-07, 1.7584D-05,-2.8817D-06,-1.0081D-06,
. 1.3259D-07, 1.8561D-05, 2.6602D-06,-1.7243D-06,-3.5533D-07,
. 2.3315D-08, 1.6239D-08, 7.3739D-09, 1.9570D-09,-2.5667D-10,
.-5.8101D-10,-2.3947D-10, 4.5821D-12, 4.5024D-11, 3.8796D-07,
. 1.1239D-07,-2.9033D-08,-5.7237D-09, 2.4186D-09,-2.9670D-09,
. 1.0887D-06, 4.3737D-07, 8.3753D-08, 3.6771D-08, 1.6545D-09,
.-1.3849D-08,-5.8855D-09, 2.1028D-06, 4.3725D-07,-1.7621D-07,
.-3.0743D-08, 1.7119D-08, 8.4698D-06, 4.5395D-06, 1.5774D-06,
. 4.1647D-07,-7.9865D-08,-1.6003D-07,-6.0171D-08, 3.1692D-06/
DATA (A(I),I=286,380)/
. 3.6965D-07,-4.9333D-07,-2.8856D-08, 4.2819D-08, 2.0492D-04,
. 1.3705D-04, 4.0972D-05, 2.9565D-06,-1.4061D-06,-1.8775D-06,
.-1.6306D-06,-3.6380D-07, 3.1213D-07, 2.0912D-07, 1.1965D-05,
. 9.9088D-07,-1.3565D-06,-2.3128D-07, 1.1379D-05, 2.6632D-06,
.-1.6877D-06,-4.0541D-07, 9.8921D-08, 5.9262D-03, 3.2332D-03,
. 9.2954D-04, 1.6597D-04,-3.7972D-05,-7.1646D-05,-4.0073D-05,
. 2.5789D-08, 5.2124D-09,-2.2517D-10,-7.9400D-10, 3.3181D-06,
. 1.9117D-07, 1.0299D-07,-7.7443D-08, 2.2953D-06,-1.0879D-06,
. 3.4368D-07,-1.1230D-07, 1.6826D-08, 6.9774D-06, 9.2721D-07,
.-1.8983D-08,-1.6068D-07, 1.5843D-06,-3.5616D-08,-1.1262D-07,
.-4.3051D-08, 8.8140D-09, 3.4244D-05, 8.0163D-06, 2.9703D-06,
.-1.6480D-07,-6.3282D-07, 2.3791D-06,-4.9305D-07,-1.7122D-07,
. 1.2147D-07, 7.2131D-05, 1.7699D-05, 8.4281D-06,-9.3966D-07,
.-6.8048D-07, 5.3785D-05, 6.9745D-06,-2.3554D-06,-7.2141D-07,
. 3.8501D-07, 4.4794D-06,-6.2435D-07,-2.7340D-07, 2.3127D-08,
. 4.2314D-08, 3.3784D-06,-5.1356D-07,-2.4321D-07,-6.2698D-09,
. 3.0812D-08, 5.6419D-08, 1.6889D-08, 2.7037D-09,-1.7433D-09,
.-9.4507D-10, 1.9714D-06, 4.2743D-08,-7.4114D-08,-2.9304D-08,
. 2.8973D-06, 1.0079D-06, 2.9561D-07,-6.2977D-09,-4.5782D-08/
DATA (A(I),I=381,475)/
.-2.4331D-08, 4.3284D-06, 2.8398D-07,-3.2705D-07,-1.5079D-07,
. 5.2686D-06, 1.6539D-06, 3.6079D-07,-1.1589D-07,-5.4904D-08,
. 7.0939D-06,-1.9534D-06, 3.2391D-08, 5.5702D-08, 3.9072D-05,
. 1.7299D-05, 5.1530D-06,-6.0911D-07,-1.2652D-06,-4.6507D-07,
. 1.1506D-05,-2.0422D-06,-6.1195D-07, 5.8641D-08, 1.0150D-05,
.-4.6977D-07,-6.9446D-07, 2.2516D-08, 1.1109D-07, 3.6715D-05,
. 5.6186D-06,-3.2309D-06,-1.6403D-06, 4.1051D-05, 2.3335D-05,
. 7.8106D-06, 2.0279D-07,-8.1139D-07,-3.7619D-07,-1.4982D-07,
. 2.5621D-05,-1.0798D-05, 1.4607D-06, 3.2421D-07, 6.5478D-09,
. 2.7233D-09, 3.8646D-10,-1.9143D-10,-1.0483D-10,-4.8664D-11,
. 1.0698D-06, 2.7752D-07,-2.6636D-08,-3.7583D-08, 2.6989D-07,
. 3.0325D-08,-2.4613D-08,-1.0828D-08, 2.2522D-09, 8.0777D-06,
. 2.2558D-06, 7.4760D-08,-2.4140D-07,-5.4292D-08, 8.8362D-07,
. 9.5045D-08,-5.0543D-08,-1.9134D-08, 1.1284D-05, 4.0659D-06,
. 7.6246D-07,-9.0394D-08,-8.7408D-08, 1.2192D-06,-2.0362D-07,
.-1.0700D-07, 2.1990D-08, 1.2519D-08, 5.2758D-05, 2.0175D-05,
. 3.6690D-06,-4.9014D-07,-7.0474D-07,-3.9931D-07, 4.7638D-05,
. 1.5546D-05, 6.2294D-07,-1.3428D-06,-1.8177D-07, 4.1203D-06,
.-4.9340D-07,-3.0198D-07,-1.5902D-08, 2.8567D-08, 2.2397D-06/
DATA (A(I),I=476,570)/
.-2.1306D-08,-1.7897D-07, 2.8178D-08, 4.1722D-08, 2.0594D-04,
. 1.2838D-04, 5.8219D-05, 1.1735D-05,-6.9778D-06,-6.2486D-06,
.-1.3800D-06, 2.9170D-06,-7.0833D-07,-1.2673D-07, 4.5069D-08,
. 1.0974D-09, 4.7908D-10, 3.0294D-11,-7.0815D-11,-1.2039D-11,
. 5.6357D-12, 8.1274D-07, 4.5158D-07, 1.1655D-07,-2.1481D-08,
.-2.2493D-08,-6.5884D-09, 9.8696D-08, 3.6499D-08, 1.4768D-09,
.-8.0141D-09,-2.8147D-09, 5.8287D-06, 3.2469D-06, 9.4927D-07,
.-7.2550D-08,-1.4231D-07,-5.8408D-08,-1.4468D-08, 4.6070D-07,
. 1.5956D-07,-3.2311D-09,-3.3487D-08,-7.9013D-09, 4.0092D-06,
. 1.2195D-06, 1.1192D-07,-1.3870D-07,-6.2194D-08, 5.4918D-07,
.-5.1133D-08,-5.4844D-08,-3.1054D-09, 6.1049D-09, 2.4833D-05,
. 1.1280D-05, 2.2680D-06,-4.4637D-07,-2.8942D-07,-1.2382D-07,
. 6.8223D-05, 3.6505D-05, 7.8792D-06,-1.7946D-06,-1.4925D-06,
.-4.6018D-07, 2.5677D-06,-7.2440D-08,-2.2441D-07,-4.1769D-08,
. 2.3833D-08, 1.1885D-06, 4.0457D-09,-1.2273D-07,-2.3271D-08,
. 1.5149D-08, 9.1912D-05, 5.6621D-05, 1.4338D-05,-2.6072D-06,
.-2.3688D-06,-6.2490D-07,-1.4386D-07, 1.0821D-06,-1.6304D-07,
.-7.9756D-08,-4.9881D-09, 9.9527D-09, 1.5288D-03, 9.8517D-04,
. 3.4966D-04, 3.4238D-05,-4.3610D-05,-3.2734D-05,-8.3676D-06/
DATA (A(I),I=571,665)/
. 9.6630D-09, 3.2976D-09, 2.1545D-10,-3.3938D-10,-1.4397D-10,
. 3.4140D-07, 7.6536D-08,-2.2485D-08,-1.8244D-08,-2.0611D-09,
. 1.3128D-06, 6.4165D-07, 1.4728D-07,-2.7600D-08,-3.0125D-08,
.-1.0320D-08, 1.6295D-06, 3.3697D-07,-5.7547D-08,-7.3134D-08,
.-1.5301D-08, 8.0375D-06, 4.0695D-06, 1.1441D-06,-5.8423D-08,
.-1.6488D-07,-7.5920D-08, 2.1173D-06,-1.9184D-07,-2.4986D-07,
. 7.2656D-09, 2.7560D-08, 7.9040D-06, 3.3963D-06, 4.8082D-07,
.-3.1619D-07,-1.6501D-07, 5.8017D-06,-5.5173D-07,-6.3613D-07,
. 1.9633D-08, 7.8681D-08, 9.4568D-06, 9.8227D-08,-7.8983D-07,
.-2.0343D-07, 7.0351D-05, 3.6017D-05, 8.0504D-06,-1.7276D-06,
.-1.5329D-06,-4.7799D-07, 3.5263D-05, 1.8639D-05, 4.2070D-06,
.-4.2643D-07,-5.2726D-07,-2.5481D-07,-1.0144D-07, 4.4613D-06,
.-8.7802D-07,-3.9633D-07, 6.7953D-08, 4.1539D-08, 1.8780D-04,
. 1.0547D-04, 2.0983D-05,-3.7076D-06,-3.7090D-06,-1.5934D-06,
.-2.6146D-07, 1.6384D-05,-3.3765D-06,-7.8390D-07, 1.2382D-07,
. 1.5748D-05,-9.4352D-07,-4.8936D-07,-4.9967D-07, 3.8177D-10,
. 9.6781D-11,-1.9622D-11,-1.7859D-11,-4.4781D-12, 3.0310D-07,
. 1.1193D-07,-5.4059D-09,-1.4249D-08,-1.9549D-09, 4.7664D-08,
. 8.5684D-09,-5.0948D-09,-3.1313D-09, 4.9557D-10, 4.2702D-10/
DATA (A(I),I=666,760)/
. 2.3433D-06, 8.3824D-07, 2.6585D-08,-7.5944D-08,-1.5093D-08,
. 1.8775D-07, 2.7614D-08,-2.1193D-08,-1.0264D-08, 1.9660D-09,
. 1.1637D-09, 7.7890D-06, 3.2901D-06,-2.9753D-07,-5.3153D-07,
.-5.2098D-08, 3.3947D-08, 5.5937D-07, 5.1363D-08,-8.5390D-08,
.-2.2580D-08, 1.0857D-08, 3.5157D-09, 4.1303D-05, 2.1947D-05,
. 3.9480D-06,-1.4234D-06,-9.0220D-07,-2.4485D-07, 1.1031D-04,
. 6.6726D-05, 1.9581D-05,-4.3637D-07,-2.8911D-06,-1.4332D-06,
.-3.2332D-07, 3.0922D-06, 2.0624D-07,-4.0771D-07,-1.0402D-07,
. 4.8807D-08, 1.2491D-06, 2.1187D-07,-1.5951D-07,-7.2537D-08,
. 1.4035D-08, 9.6514D-09, 2.5146D-05,-9.4490D-08,-3.4103D-06,
. 2.4020D-07, 2.9564D-07, 6.6566D-07,-3.0772D-08,-1.0055D-07,
.-3.1082D-09, 1.4897D-08, 7.7189D-04, 3.3710D-04, 3.9258D-05,
.-1.5271D-05,-6.0652D-06, 2.1986D-04,-3.3135D-05,-8.5682D-06,
.-9.2988D-07, 3.8085D-06,-1.3259D-07,-3.8517D-07,-5.7276D-08,
. 3.7226D-08, 2.0825D-09, 1.6707D-10,-1.2443D-10,-3.9117D-11,
. 1.0068D-07, 6.2278D-09,-5.9169D-09,-3.9535D-09, 5.3334D-07,
. 2.2022D-07, 1.4522D-08,-2.8440D-08,-8.1406D-09, 6.0187D-07,
. 5.8318D-08,-2.7772D-08,-2.6639D-08, 3.0929D-06, 1.0648D-06,
. 1.2317D-07,-9.9233D-08,-4.0796D-08, 1.5217D-06, 8.3095D-08/
DATA (A(I),I=761,855)/
.-1.9819D-07,-6.0417D-08, 2.9553D-08, 9.0905D-09, 8.6651D-06,
. 3.9125D-06,-2.2871D-07,-6.4651D-07,-7.4440D-08, 4.3543D-08,
. 4.4505D-06, 2.7350D-07,-4.6428D-07,-2.2293D-07, 5.5275D-08,
. 3.6505D-08, 8.3471D-06, 5.0215D-07,-1.1189D-06,-2.5404D-07,
. 1.3175D-07, 1.1687D-04, 7.0674D-05, 2.0219D-05,-1.2136D-06,
.-3.2299D-06,-1.3981D-06,-2.8271D-07, 3.7298D-05, 2.2054D-05,
. 5.5510D-06,-9.1515D-07,-1.0832D-06,-3.6657D-07,-4.8581D-08,
. 2.2506D-06,-2.9469D-07,-2.1641D-07,-3.9630D-08, 5.2879D-08,
. 2.7894D-05,-3.9312D-06,-2.6413D-06, 5.5848D-07, 8.7829D-06,
.-1.4800D-06,-7.0982D-07,-2.1645D-08, 1.3258D-07, 1.2248D-05,
.-1.4244D-06,-7.6696D-07,-1.5029D-07, 6.8467D-08, 1.9392D-04,
.-2.6676D-05,-8.0536D-06,-6.3609D-07, 2.3074D-05, 7.2856D-07,
.-2.3751D-06,-5.8464D-07, 1.3685D-07, 1.9646D-08, 1.2918D-08,
. 4.6924D-09, 5.1593D-10,-4.4715D-10,-3.4091D-10,-9.7254D-11,
. 3.4117D-07, 1.2731D-07,-2.2300D-08,-2.5297D-08,-1.1877D-10,
. 2.3436D-09, 9.4463D-07, 4.9464D-07, 8.9138D-08,-2.2158D-08,
.-1.2008D-08,-4.3715D-09,-2.8719D-09, 1.4091D-06, 4.8184D-07,
.-9.6135D-08,-1.0945D-07,-9.3174D-09, 9.0166D-09, 4.3747D-06,
. 2.1053D-06, 1.7702D-07,-3.0956D-07,-1.2902D-07,-8.9418D-09/
DATA (A(I),I=856,929)/
. 1.4297D-06, 7.7612D-08,-1.7188D-07, 6.4348D-10, 1.1572D-08,
. 7.4828D-06, 4.0177D-06, 1.0890D-06, 8.6393D-08,-5.4701D-08,
.-5.7656D-08,-3.3030D-08, 5.0379D-06, 1.2861D-07,-7.1313D-07,
.-3.3703D-09, 7.9367D-08, 6.2235D-06, 9.8196D-07,-4.6416D-07,
.-2.3278D-07, 2.9519D-05, 1.5275D-05, 3.1448D-06,-6.4571D-07,
.-3.4445D-07, 3.6508D-05, 2.0524D-05, 3.1203D-06,-2.3606D-06,
.-1.5012D-06,-2.5807D-07, 1.3807D-07, 9.9656D-08, 3.1628D-06,
.-5.6361D-08,-3.8861D-07,-1.0385D-09, 2.9930D-08, 3.1351D-04,
. 2.3774D-04, 1.0342D-04, 1.2429D-05,-1.4107D-05,-9.2597D-06,
.-1.7338D-06, 8.4903D-07, 7.3795D-07, 2.2065D-07, 1.2134D-05,
. 4.6651D-07,-9.3659D-07,-2.7485D-07, 1.2462D-05, 6.2559D-07,
.-6.1634D-07,-5.1080D-07, 1.2493D-02, 8.2057D-03, 2.9562D-03,
. 3.3090D-04,-3.7349D-04,-2.8886D-04,-7.4606D-05, 1.2726D-05,
.-1.6480D-07,-1.5006D-06,-1.1181D-07, 1.4846D-07, 8.7160D-03,
. 4.2652D-03, 5.2455D-04,-2.6363D-04,-7.9836D-05/
SAVE ENER,NSTART,A,STWT
C
C SET ALL ELEMENTS OF COLHE1 = 0
C
DO I=1,N
DO J=1,N
COLHE1(I,J)=0.
END DO
END DO
C
C EVALUATE GAMMAS FOR REQUESTED LEVELS
C
XXX=2.D0*(LOG10(TEMP)-C1)/C2
TFAC=UN/SQRT(TEMP)
C
C LOOPS OVER LEVELS
C
DO IL=1,N-1
DO IU=IL+1,N
J=((IU*IU-3*IU+4)/2)+IL-1
N1=NSTART(J)
NF=NSTART(J+1)-1
NT=NF-N1+1
NTM2=NT-2
C
C CLENSHAW SUMMATION
C
B(NT)=A(NF)
B(NT-1)=XXX*B(NT)+A(NF-1)
IR=NTM2
JJ=NF-2
DO J=1,NTM2
B(IR)=XXX*B(IR+1)-B(IR+2)+A(JJ)
IR=IR-1
JJ=JJ-1
END DO
COLHE1(IU,IL)=(B(1)-B(3))*TFAC
X=(ENER(IL)-ENER(IU))/8.62D-5/TEMP
COLHE1(IL,IU)=COLHE1(IU,IL)*STWT(IU)/STWT(IL)*EXP(X)
END DO
END DO
RETURN
END
tlusty/extracted/column.f
+50
View File
@@ -0,0 +1,50 @@
subroutine column
c =================
c
c approximate determination of the total disk column
c mass, DMTOT
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
common/relcor/arh,brh,crh,drh
c
parameter (xmdsun = 6.3029e25,
* xmsun = 1.989e33,
* rsun = 6.9598e10,
* grcon = 6.668e-8,
* velc = 2.997925e10,
* rgas = 1.3e8,
* xkram0 = 7.e25,
* xkap0 = 6.4e24,
* chiel = 0.39,
* pi = 3.14159265e0,
* pi4 = 4.*pi)
c
alpha= abs(alphav)
r = rstar*abs(reldst)
ga=xmdot*xmdsun/pi4*sqrt(5.9*grcon*abs(xmstar)/r**3)*drh/arh
c
be=0.77*rgas*xkap0**0.125*(two*qgrav/pi/rgas)**0.0625*sqrt(teff)
be=be*fractv**0.125
al=(sig4p*pi4*teff**4*chiel/velc)**2/(3.*qgrav)
c
dm00=(ga/alpha/be)**0.8
write(6,640) ga,al,be,dm00
640 format(/' new procedure to determine M_tot'/
* ' gam, al, be, dm0 ',1p4e11.3/
* ' iter M delta(M)/M p, jac'/)
itdm=0
10 itdm=itdm+1
p0=alpha*dm00*(al+be*dm00**0.25)-ga
ppr=alpha*(al+1.25*be*dm00**0.25)
ddm0=-p0/ppr
write(6,641) itdm,dm00,ddm0/dm00,p0,ppr
641 format(i4,1p4e11.3)
dm00=dm00+ddm0
if(abs(ddm0/dm00).gt.1.e-2.and.itdm.lt.20) go to 10
dmtot=dm00
visc=3.34379D24*XMDOT/dmtot*BRH*DRH/ARH/ARH
c
return
end
tlusty/extracted/compt0.f
+107
View File
@@ -0,0 +1,107 @@
SUBROUTINE COMPT0(IJ,ID,ab,compa,compb,compc,compe,comps,compd)
C ===============================================================
C
c auxiliary quantities for the Compton scattering source function
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ITERAT.FOR'
PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10)
common/auxcbc/cden1m(mdepth),cden10(mdepth),
* cden2m(mdepth),cden20(mdepth)
c
IJI=NFREQ-KIJ(IJ)+1
if(iji.eq.1) then
compa=0.
compb=0.
compc=0.
compd=0.
compe=0.
comps=0.
return
end if
c
FR=FREQ(IJ)
frp=freq(ijorig(iji+1))
frm=freq(ijorig(iji-1))
xcomp=fr*xcon
e2=ycon*temp(id)
e1=xcomp-3.*e2
c
del0=two/(dlnfr(iji)+dlnfr(iji-1))
cder1p(iji)=(un-delj(iji,id))*del0
cder1m(iji)=-delj(iji-1,id)*del0
cder10(iji)=-del0*(un-delj(iji-1,id)-delj(iji,id))
ss0=elec(id)*sige/ab
if(ichcoo.eq.0) then
cder10(iji)=-cder1m(iji)-cder1p(iji)
compa=ss0*(e1*cder1m(iji)+e2*cder2m(iji))
compb=ss0*(un-xcomp-sigec(ij)/sige+e1*cder10(iji)+
* e2*cder20(iji))
compc=ss0*(e1*cder1p(iji)+e2*cder2p(iji))
else
epsnu=(ab-elec(id)*sigec(ij))/ab
zxxp=xcon*frp+0.5*bnus(iji+1)*rad(iji+1,id)-3.*e2
zxx0=xcomp+0.5*bnus(iji)*rad(iji,id)-3.*e2
zxxm=xcon*frm+0.5*bnus(iji-1)*rad(iji-1,id)-3.*e2
zxxp12=((un-delj(iji,id))*zxxp+delj(iji,id)*zxx0)*del0
zxxm12=((un-delj(iji-1,id))*zxx0+delj(iji-1,id)*zxxm)*del0
compa=ss0*(-delj(iji-1,id)*zxxm12+e2*cder2m(iji))
compc=ss0*((un-delj(iji,id))*zxxp12+e2*cder2p(iji))
compb=ss0*(delj(iji,id)*zxxp12-(un-delj(iji-1,id))*zxxm12+
* e2*cder20(iji)-sigec(ij)/sige)-epsnu+1.
compe=0.
end if
compd=(-3.*cder10(iji)+cder20(iji))*rad(iji,id)
c
IF(ICOMDE.EQ.0) THEN
COMPA=0.
COMPC=0.
COMPB=0.
END IF
c
x0=ss0*bnus(iji)
if(icomst.eq.0) x0=0.
if(ichcoo.eq.0) then
compe=x0*(cder10(iji)-un)
compu=x0*cder1m(iji)
compv=x0*cder1p(iji)
cbs=compe*rad(iji,id)
compe=cbs
end if
comps=compb*rad(iji,id)
if(iji.gt.1) then
if(ichcoo.eq.0) cbs=cbs+compu*rad(iji-1,id)
comps=comps+compa*rad(iji-1,id)
compd=compd+(-3.*cder1m(iji)+cder2m(iji))*rad(iji-1,id)
end if
if(iji.lt.nfreq) then
if(ichcoo.eq.0) cbs=cbs+compv*rad(iji+1,id)
comps=comps+compc*rad(iji+1,id)
compd=compd+(-3.*cder1p(iji)+cder2p(iji))*rad(iji+1,id)
end if
if(ichcoo.eq.0) then
compb=compb+cbs
compa=compa+compu*rad(iji,id)
compc=compc+compv*rad(iji,id)
comps=comps+cbs*rad(iji,id)
end if
compd=compd*ss0*ycon
IF(ICOMDE.EQ.0) COMPD=0.
c
c a variant with ICOMPT=2 - no off-diagonal terms in intensity
c
if(icompt.eq.2) then
if(iji.gt.1) compb=compb+compa*rad(iji-1,id)
if(iji.lt.nfreq) compb=compb+compc*rad(iji+1,id)
compa=0.
compc=0.
else if(icompt.eq.3) then
compa=0.
compb=0.
compc=0.
end if
return
end
tlusty/extracted/comset.f
+164
View File
@@ -0,0 +1,164 @@
SUBROUTINE COMSET
C =================
C
C sets up necessary parameters for treating the Compton scattering
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
dimension freqi(mfreq)
parameter (xcon=8.0935d-21,YCON=1.68638E-10)
parameter (t15=1.d-15)
common/auxcbc/cden1m(mdepth),cden10(mdepth),
* cden2m(mdepth),cden20(mdepth)
common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc)
DIMENSION PL(MDEPTH),PLM(MDEPTH)
C
if(icompt.le.0) go to 100
nmuc=3
nsti=0
nedd=3
C
C frequency-dependent universal parameters
C
do ij=1,nfreq
cder10(ij)=0.
cder1p(ij)=0.
cder1m(ij)=0.
cder20(ij)=0.
cder2p(ij)=0.
cder2m(ij)=0.
iji=nfreq-kij(ij)+1
ijorig(iji)=ij
freqi(iji)=freq(ij)
fr=freqi(iji)
bnus(iji)=two*xcon*fr/(bn*(fr*1.d-15)**3)
end do
C
ij=1
dlnfr(ij)=log(freqi(ij+1)/freqi(ij))
do ij=2,nfreq-1
dlnfr(ij)=log(freqi(ij+1)/freqi(ij))
delp=dlnfr(ij)
delm=dlnfr(ij-1)
del0=delp+delm
cd0=two/del0
cder2m(ij)=cd0/delm
cder2p(ij)=cd0/delp
cder20(ij)=-cder2m(ij)-cder2p(ij)
end do
c
do ij=1,nfreq-1
frj0=freqi(ij)
frjp=freqi(ij+1)
frz=sqrt(frj0*frjp)
do id=1,nd
C to avoid over/underflow problems:
IF(HK*FRJ0/TEMP(ID).LT.200.) THEN
fjb0=un/(exp(hk*frj0/temp(id))-un)
ELSE
fjb0=0.
ENDIF
IF(HK*FRJP/TEMP(ID).LT.200.) THEN
fjbp=un/(exp(hk*frjp/temp(id))-un)
ELSE
fjbp=0.
ENDIF
fjz0=fjb0*(bn*(frj0*t15)**3)
fjzp=fjbp*(bn*(frjp*t15)**3)
if(ichcoo.eq.0) then
zj0=hk*frz/temp(id)
dfjz=fjz0-fjzp
dfjb=fjb0-fjbp
fzz=un+fjbp-3./zj0
aa=dfjz*dfjb
bb=dfjz*fzz+fjzp*dfjb
cc=fjzp*fzz-dfjz/dlnfr(ij)/zj0
else
e2=ycon*temp(id)
zxxp=xcon*frjp*(un+fjbp)-3.*e2
zxx0=xcon*frj0*(un+fjb0)-3.*e2
dzxx=zxx0-zxxp
dfjb=fjb0-fjbp
dfjz=fjz0-fjzp
aa=dfjz*dzxx
bb=dfjz*zxxp+fjzp*dzxx
cc=fjzp*zxxp-e2*dfjz/dlnfr(ij)
end if
CXXX to avoid division by zero:
if(abs(aa).eq.0.and.abs(bb).eq.0.) then
xx1=0.
elseif(abs(aa).lt.1.e-7*abs(bb)) then
xx1=-cc/bb
else
dd=bb*bb-4.*aa*cc
if(dd.lt.0.) dd=0.
dd=sqrt(dd)
xx1=(dd-bb)*half/aa
if(ichcoo.gt.0) then
xx2=-(dd+bb)*half/aa
dxx1=abs(xx1-half)
dxx2=abs(xx2-half)
if(dxx2.lt.dxx1) xx1=xx2
if((xx1.gt.1.).or.(xx1.lt.0.)) xx1=half
end if
end if
delj(ij,id)=xx1
end do
end do
c
C angle-dependent universal parameters
C
call angset
c
C frequency-dependent universal parameters
C
100 continue
do ij=1,nfreq
c
c first-order expression
c
if(knish.eq.0) then
SIGEC(IJ)=SIGE*(un-two*freq(ij)*xcon)
c
C Use full Klein-Nishina cross section (Rybicki & Lightman 1975):
c
else
xf=xcon*freq(ij)
if(xf.lt.1.d-1) then
SIGEC(IJ)=SIGE*(1.-xf*(2.-xf*(26./5.-xf*(13.3
* -xf*(1144./35.-xf*(544./7.-xf*(3784./21.
* -xf*(6148./15.-xf*(151552./165.
* -xf*111872./55.)))))))))
else if(xf.gt.1.d3) then
SIGEC(IJ)=SIGE*3./8./xf*(log(2.*xf)+0.5)
else
SIGEC(IJ)=SIGE*0.75*((1.+xf)/xf**3*(2.*xf*(1.+xf)/
* (1.+2.*xf)-log(1.+2.*xf))+0.5*log(1.+2.*xf)/xf
* -(1.+3.*xf)/(1.+2.*xf)**2)
endif
endif
end do
c
if(icompt.le.0) return
IJ=1
IJO=ijorig(ij)
DO ID=1,ND
PLM(ID)=BNUE(IJO)/(EXP(HK/Temp(ID)*FREQ(IJO))-UN)
END DO
C
DO IJ=2,NFREQ
IJO=ijorig(ij)
DO ID=1,ND
C to avoid over/underflow problems:
IF(HK/TEMP(ID)*FREQ(IJO).LT.200.) THEN
PL(ID)=BNUE(IJO)/(EXP(HK/temp(ID)*FREQ(IJO))-UN)
ELSE
PL(ID)=PLM(ID)
ENDIF
PLM(ID)=PL(ID)
END DO
END DO
C
return
end
tlusty/extracted/concor.f
+48
View File
@@ -0,0 +1,48 @@
SUBROUTINE CONCOR
C =================
C
C Auxiliary procedure called from INILAM
C Initialization of the model parameter DELTA immediately
C after a completed iteration of complete linearization
C
C DELTA is defined as d(lnT)/dln(P)
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
C
IF(INDL.EQ.0) RETURN
NDEL=NFREQE+INDL
C
if(idisk.eq.0) then
PRAD0=PRADT(1)-PRD0
DO ID=1,ND
PTOTAL(ID)=DM(ID)*GRAV+PRAD0
END DO
end if
C
DO ID=2,ND
P=PTOTAL(ID)
PM=PTOTAL(ID-1)
DEL1=DELTA(ID)
TM=TEMP(ID-1)
T1=TEMP(ID)
FAC=DEL1*(P-PM)/(P+PM)
T2=TM*(UN+FAC)/(UN-FAC)
DEL2=(T1-TM)/(P-PM)/(T1+TM)*(P+PM)
IF(ITEMP.EQ.1.AND.ID.GE.ICBEG-1) TEMP(ID)=T2
IF(ITEMP.EQ.2) TEMP(ID)=T2
END DO
C
C check whether the corresponding convective flux is less
C than total flux; if not, recalculate tempertaure
C
if(itmcor.ne.0) then
CALL TEMCOR
write(6,603)
call conout(1,ipconf)
end if
c
603 format(' recalculation of convective flux in CONCOR'/)
RETURN
END
tlusty/extracted/conout.f
+130
View File
@@ -0,0 +1,130 @@
SUBROUTINE CONOUT(IMOD,IPRIN)
C =============================
C
C Diagnostic outprint of temperature gradients, convective flux,
C and their derivatives
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD
C
IF(IPRIN.GT.0) WRITE(6,600)
ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1))
ICBEG=0
FLXTO0=SIG4P*TEFF**4
DO ID=1,ND
T=TEMP(ID)
PTOT=PTOTAL(ID)
PG=PGS(ID)
PRAD=PTOT-PG-HALF*DENS(ID)*VTURB(ID)**2
if(prad.lt.0.) prad=0.
IF(IMOD.EQ.2) THEN
if(ioptab.ge.0) then
CALL OPACF0(ID,NFREQ)
CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA)
ABROSD(ID)=OPROS/DENS(ID)
else
call meanopt(t,id,dens(id),opros,oppla)
if(hmix0.gt.0.) abrosd(id)=opros
end if
END IF
FLXTOT=flxto0
if(idisk.eq.1) then
flxtot=flxto0*(un-thetav(id))
gravd=zd(id)*qgrav
prad=pradt(id)
end if
IF(ID.EQ.1) THEN
TAU=DM(ID)*ABROSD(ID)
FLXCR=0.
GRDADB=0.
DELTA(ID)=0.
FLXC(ID)=0.
FLXCNV=0.
ELSE
TM=TEMP(ID-1)
TAU=TAUM+HALF*(DM(ID)-DM(ID-1))*(ABROSD(ID)+ABROSD(ID-1))
PTOTM=PTOTAL(ID-1)
PGM=PGS(ID-1)
PRADM=PTOTM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2
if(idisk.eq.1) pradm=pradt(id-1)
if(pradm.lt.0.) pradm=0.
if(ilgder.eq.0) then
T0=HALF*(T+TM)
PT0=HALF*(PTOT+PTOTM)
PG0=HALF*(PG+PGM)
PR0=HALF*(PRAD+PRADM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
DLT=(T-TM)/(PTOT-PTOTM)*PT0/T0
else
T0=SQRT(T*TM)
PT0=SQRT(PTOT*PTOTM)
PG0=SQRT(PG*PGM)
PR0=SQRT(PRAD*PRADM)
AB0=SQRT(ABROSD(ID)*ABROSD(ID-1))
DLT=LOG(T/TM)/LOG(PTOT/PTOTM)
end if
DELTA(ID)=DLT
flxcnv=0.
if(idisk.ne.1.or.id.lt.nd)
* CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DLT,FLXCNV,VCON)
if(hmix0.gt.0.) FLXC(ID)=FLXCNV
IF(ICBEG.EQ.0.AND.FLXC(ID).GT.0..AND.FLXC(ID-1).EQ.0..
* AND.ID.GT.25) ICBEG=ID
if(icbeg.gt.0.and.flxc(id).gt.0.) icend=id
END IF
PRADR=PRAD/PTOT
conrel=0.
radrel=1.
if(flxtot.gt.0.) then
conrel=FLXCNV/FLXTOT
radrel=flrd(id)/flxtot
end if
IF(IPRIN.GT.0) WRITE(6,601) ID,TAU,T,DELTA(ID),
* GRDADB,conrel,radrel,conrel+radrel
TAUM=TAU
END DO
if(iprin.gt.0) write(6,603) icbeg,icend
603 format(/' convective zone between depths (inclusive) ',2i4/)
C
c if ICONV=3, then:
c in the convective zone the radiative (+ convective) equilibrium
c is taken obligatorily in the differential form, i.e.
c NDRE is modified to have the value just below the beginning of
c convection zone, and
c rediff(id) has to be set to unity, and reint(id) to 0 for id => ndre
c
IF(ICBEG.GT.3.AND.ICONV.EQ.3) THEN
NDRE=ICBEG-1
DO ID=1,ND
IF(ID.GE.NDRE) THEN
REINT(ID)=0.
REDIF(ID)=1.
else
reint(id)=1.
redif(id)=0.
END IF
END DO
WRITE(6,602) NDRE
END IF
c
IF(ICBEG.GT.3.AND.ICONV.EQ.2) THEN
NDRE=ICBEG-1
DO ID=1,ND
IF(ID.GE.NDRE) THEN
REDIF(ID)=1.
END IF
END DO
WRITE(6,602) NDRE
END IF
c
600 FORMAT(//' ID',3X,'TAUR',7X,'TEMP',6X,
* 'DELTA',2X,'DELTA(AD)',2X,'CON/TOT RAD/TOT (C+R)/TOT'//)
601 FORMAT(1H ,I4,1PD9.2,0PF9.1,1P5D10.2)
602 FORMAT(//' NDRE IS RESET IN CONOUT DUE TO THE EXISTENCE OF'
* ,' CONVECTIVE ZONE'/' NDRE= ',I3/)
RETURN
END
tlusty/extracted/conref.f
+328
View File
@@ -0,0 +1,328 @@
SUBROUTINE CONREF
C =================
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD
common/imucnn/imucon
dimension idcon(mdepth),
* flxtt(mdepth),delta0(mdepth)
C
IF(ICONV.LE.0.AND.INDL.EQ.0) RETURN
FLXTO0=SIG4P*TEFF**4
DLTND=DELTA(ND)
IFNDM1=0
C
ICBEG=0
ICEND=0
DO ID=2,ND
T=TEMP(ID)
P=PTOTAL(ID)
PG=PGS(ID)
PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2
TM=TEMP(ID-1)
PM=PTOTAL(ID-1)
PGM=PGS(ID-1)
PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2
IF(ID.EQ.ND.AND.IFNDM1.EQ.1) THEN
FAC=DLTND*(P-PM)/(P+PM)
T=TM*(UN+FAC)/(UN-FAC)
END IF
if(ilgder.eq.0) then
T0=HALF*(T+TM)
P0=HALF*(P+PM)
PG0=HALF*(PG+PGM)
PR0=HALF*(PRAD+PRADM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
DLT=(T-TM)/(P-PM)*P0/T0
else
T0=SQRT(T*TM)
P0=SQRT(P*PM)
PG0=SQRT(PG*PGM)
PR0=SQRT(PRAD*PRADM)
AB0=SQRT(ABROSD(ID)*ABROSD(ID-1))
DLT=LOG(T/TM)/LOG(P/PM)
end if
DELTA(ID)=DLT
if(idisk.eq.0) then
flxtot=flxto0
gravd=grav
else
flxtot=flxto0*(1.d0-thetav(id))
gravd=qgrav*zd(id)
end if
flxtt(id)=flxtot
C
C convective flux
C
CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON)
FLXC(ID)=FLXCNV
idcon(id)=0
if(flxc(id).gt.0.) idcon(id)=1
IF(ICBEG.EQ.0.AND.FLXC(ID).GT.0..AND.FLXC(ID-1).EQ.0..
* AND.ID.GT.IDCONZ) ICBEG=ID
if(icbeg.gt.0.and.flxc(id).gt.0.) icend=id
END DO
C
c correction algorithm - if in the convetion zone one has
c some depth point have gradient slightly smaller that the
c adaibatic gradient, recompute gradients to have convection there.
C in this case, the radiation flux is held fixed
c
c
icbeg0=icbeg
if(ideepc.gt.0) then
if(icend.eq.nd-1.and.ideepc.eq.2) icend=nd
icbegd=icend
do id=icend,icbeg,-1
if(idcon(id).gt.0) then
icbegd=id
else
igap=0
do idd=id-1,id-ndcgap,-1
if(idcon(idd).gt.0) igap=1
end do
if(igap.gt.0) then
icbegd=id
else
go to 10
end if
end if
end do
10 continue
icbeg0=icbegd
end if
c
if(ideepc.eq.3) icend=nd
if(ideepc.ge.4) then
if(icend.le.icbegp) then
icbeg0=icbegp
icend=icendp
end if
end if
icbegp=icbeg0
icendp=icend
c
if(icbeg0.gt.0.and.icend.gt.0) then
write(6,601) icbeg0,icend
601 format(/' convective refinement between depths ',2i4/)
c
c check the temperature at the depth just above the base of
c convection zone; if there is an oscillation there, re-adjust
c the temperature
c
if(temp(icbeg0-1).lt.temp(icbeg0-2).and.
* temp(icbeg0-1).lt.temp(icbeg0)) then
temp(icbeg0-1)=half*(temp(icbeg0)+temp(icbeg0-2))
end if
c
do id=icbeg0,icend
T=TEMP(ID)
P=PTOTAL(ID)
PG=PGS(ID)
PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2
TM=TEMP(ID-1)
PM=PTOTAL(ID-1)
PGM=PGS(ID-1)
PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2
if(ilgder.eq.0) then
P0=HALF*(P+PM)
T0=HALF*(T+TM)
PG0=HALF*(PG+PGM)
PR0=HALF*(PRAD+PRADM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
DLT=(T-TM)/(P-PM)*P0/T0
ppd=(p+pm)/(p-pm)
else
T0=SQRT(T*TM)
P0=SQRT(P*PM)
PG0=SQRT(PG*PGM)
PR0=SQRT(PRAD*PRADM)
AB0=SQRT(ABROSD(ID)*ABROSD(ID-1))
DLT=LOG(T/TM)/LOG(P/PM)
end if
if(idisk.eq.0) then
flxtot=flxto0
gravd=grav
else
flxtot=flxto0*(1.d0-thetav(id))
gravd=qgrav*zd(id)
end if
fcnv=flxtot-flrd(id)
tor=t
if(fcnv.le.0.) fcnv=flxtot*(un-flrd(id)/flrd(2))
if(fcnv.lt.0.) fcnv=0.001*flxtot
c
c iteration loop to correct temperature
c
iic=0
20 iic=iic+1
if(ilgder.eq.0) then
T0=HALF*(T+TM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
DLT=(T-TM)/(P-PM)*P0/T0
else
T0=SQRT(T*TM)
AB0=SQRT(ABROSD(ID)*ABROSD(ID-1))
DLT=LOG(T/TM)/LOG(P/PM)
end if
DELTA(ID)=DLT
if(flxc(id)/flxtot.gt.crflim) then
CALL CONVC1(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,FC0)
deltae=(fcnv/fc0)**0.666666666666667
deltaa=deltae+bcnv*sqrt(deltae)
dlt=deltaa+grdadb
end if
told=t
if(ilgder.eq.0) then
dlp=dlt/ppd
t=tm*(un+dlp)/(un-dlp)
else
t=tm*(P/PM)**DLT
end if
flxcnv=fc0*deltae**1.5
ff=flxcnv/flxtot
dtt=(t-told)/told
erfl=(flrd(id)+flxcnv)/flxtot
if(ilgder.eq.0) then
T0=HALF*(T+TM)
DLT=(T-TM)/(P-PM)*P0/T0
else
T0=SQRT(T*TM)
DLT=LOG(T/TM)/LOG(P/PM)
end if
CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCN0,VCON)
erfl=(flrd(id)+flxcn0)/flxtot
if(abs(dtt).gt.1.e-9.and.iic.lt.10) go to 20
delta(id)=dlt
temp(id)=t
c write(6,667) id,iic,tor,t,flxcn0/flxtot,dlt,grdadb
end do
c
c new refinement procedure
c
if(iter.ge.imucon) then
icbeg0=icbeg
icend=nd
icendp=nd
write(6,674) imucon,icbeg0,icend
674 format(/' modification with imucon: icbeg0,icend',3i4)
write(6,677) icbeg0,icend
677 format(/' new refinement procedure: icbeg0, icend ',2i4/
*' entries are: id,itrc,t,dlt,grdadb,flrd/ft,flr/ft,fcn0/ft,
*(fcn0+flr)/ft'/)
do id=icbeg0,icend
t=temp(id)
p=ptotal(id)
tm=temp(id-1)
pm=ptotal(id-1)
pg=pgs(id)
PG=PGS(ID)
PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2
PGM=PGS(ID)
PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2
pg0=sqrt(pg*pgm)
pr0=sqrt(prad*pradm)
told=t
fcnv=flxtt(id)-flrd(id)
t0=sqrt(t*tm)
p0=sqrt(p*pm)
ab0=sqrt(abrosd(id)*abrosd(id-1))
dlt=log(t/tm)/log(p/pm)
call convc1(id,t0,p0,pg0,prad0,ab0,dlt,flxcn0,fc0)
alp=min(flrd(id),flxtt(id))/t0**4/dlt
c
if(fcnv.le.0.) go to 200
if(flxcn0.le.0.) go to 200
c
bet=bcnv/t0**3
deltae=(fcnv/fc0)**twothr
deltaa=deltae+bcnv*sqrt(deltae)
dlt=deltaa+grdadb
t=tm*(P/PM)**DLT
t0=sqrt(t*tm)
c
itrnrc=0
100 continue
itrnrc=itrnrc+1
t1=un/t
dltp=t1/log(p/pm)
t0p=half*t0*t1
dele=(flxtt(id)-alp*t0**4*dlt)/fc0
dele3= dele**third
delep=-alp*t0**4*dlt/fc0*(two*t1+d1tp/dlt)
vl=dlt-grdadb-dele3*(dele3+bet*t0**3)
bb=dltp-twothr*delep/dele3-
* bet*t0**3*dele3*(1.5d0*t1+third*delep/dele)
dt=-vl/bb*t1
t=t*(un+dt)
t0=sqrt(t*tm)
dlt=log(t/tm)/log(p/pm)
call convc1(id,t0,p0,pg0,prad0,ab0,dlt,flxcn0,fc0)
645 format(2i4,1pe11.3,0pf8.2,1p3e13.5)
if(abs(dt).lt.1.e-9.or.itrnrc.gt.20) go to 110
go to 100
110 continue
go to 230
c
200 continue
if(flxtt(id).lt.flrd(id)) then
alp=flxtt(id)/flrd(id)*t0**4*delta0(id)
itrnrc=0
210 continue
itrnrc=itrnrc+1
t1=un/t
dltp=t1/log(p/pm)
t0p=half*t0*t1
dele=alp-t0**4*dlt
delep=-t0**4*dlt*(two*t1+dltp/dlt)
dt=-dele/delep*t1
t=t*(un+dt)
write(6,645) id,itrnrc,dt,t
if(abs(dt).lt.1.e-6.or.itrnrc.gt.20) go to 220
t0=sqrt(t*tm)
dlt=log(t/tm)/log(p/pm)
go to 210
220 continue
alp=flrd(id)/t0**4/dlt
end if
c
230 continue
delta(id)=dlt
temp(id)=t
flr=alp*t0**4*dlt
if(dlt.ge.grdadb) then
flc=fc0*dele
write(6,646) id,itrnrc,t,dlt,grdadb,flrd(id)/flxtt(id),
* flr/flxtt(id),flc/flxtt(id),flxcn0/flxtt(id),
* (flr+flxcn0)/flxtt(id)
else
itrnrc=0
write(6,646) id,itrnrc,t,dlt,grdadb,flrd(id)/flxtt(id),
* flr/flxtt(id)
end if
646 format(2i4,f8.1,1p7e12.4)
end do
end if
c
if(ioptab.ge.-1.and.ifryb.gt.0) then
do id=1,nd
t=temp(id)
an=pgs(id)/bolk/t
CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1)
RHO=WMM(ID)*(AN-ANE)
DENS(ID)=RHO
ELEC(ID)=ANE
CALL WNSTOR(ID)
CALL STEQEQ(ID,POP,1)
END DO
END IF
c
call tdpini
call conout(1,ipconf)
end if
c
return
end
tlusty/extracted/contmd.f
+144
View File
@@ -0,0 +1,144 @@
SUBROUTINE CONTMD
C =================
C
C Auxiliary procedure for LTEGRD
C Determination of temperature in convectively unstable layers
C for disks.
C This is done by solving the energy balance equation
C F(rad)+F(conv)=F(mech), which yields a cubic equation for
C the logarithmic temperature gradient
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
COMMON ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),
* DEPTH(MDEPTH),DEPTH0(MDEPTH),TAU(MDEPTH),TAU0(MDEPTH),
* TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),DM0(MDEPTH)
DIMENSION DELTR(MDEPTH),TEMPR(MDEPTH),ICON0(MDEPTH)
COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD
COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1
PARAMETER (ERRT=1.D-3)
C
C First, store the temperature(rad) and gradient Delta(rad) -
C quantities for the purely raditive equilibrium model
C
T4=TEFF**4
FLXTO0=SIG4P*T4
DPRAD=1.891204931D-15*T4
if(ifprad.eq.0) dprad=0.
PRAD0=DPRAD/1.732D0
DO ID=1,ND
TEMPR(ID)=TEMP(ID)
IF(ID.EQ.1) THEN
DELTR(ID)=0.
ELSE
DELTR(ID)=
* (TEMP(ID)-TEMP(ID-1))/(PTOTAL(ID)-PTOTAL(ID-1))*
* (PTOTAL(ID)+PTOTAL(ID-1))/(TEMP(ID)+TEMP(ID-1))
END IF
END DO
ICONIT=0
C
C ------------------------------------------------------
C Global iteration loop for calculating convective model
C ------------------------------------------------------
C
20 ICONIT=ICONIT+1
ICONBE=0
HR1=FLXTO0*PCK*ABROSD(1)/QGRAV
CHANTM=0.
DOID=1,ND
T=TEMP(ID)
PTOT=PTOTAL(ID)
PGAS=PGS(ID)
PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID)
PRAD=PRADT(ID)
FLXTOT=FLXTO0*(UN-THETA(ID))
GRAVD=ZD(ID)*QGRAV
ICON0(ID)=0
C
IF(ID.EQ.1) GO TO 40
J=0
IF(ICONIT.EQ.1) T=T-TEMPR(ID-1)+TEMP(ID-1)
TM=TEMP(ID-1)
IF(T.LT.0.) T=TM
PGM=PGS(ID-1)
PTOTM=PTOTAL(ID-1)
PT0=HALF*(PTOT+PTOTM)
DELR=DELTR(ID)
C
C Inner iteration loop for determining temperature in the
C conectively unstable layers
C
30 J=J+1
TOLD=T
T0=HALF*(T+TM)
PG0=HALF*(PGAS+PGM)
PR0=HALF*(PRAD+PRADM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
IF(ID.GE.ND-2.AND.ICONBE.EQ.0) GO TO 40
CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DELR,FLXCNV,VCON)
IF(FLXCNV.EQ.0.) GO TO 40
ICON0(ID)=1
ICONBE=1
if(id.eq.nd) then
pip=(ptot+ptotm)/(ptot-ptotm)
t=tm*(pip+delr)/(pip-delr)
go to 40
end if
CALL CUBIC(DELTA0)
FAC=DELTA0*(PTOT-PTOTM)/(PTOT+PTOTM)
T=TM*(UN+FAC)/(UN-FAC)
IF(T.LT.TM) T=TM
IF(ABS(UN-T/TOLD).GT.ERRT.AND.J.LT.10) GO TO 30
C
C Store the final quantitites
C
40 IF(ID.GT.1.AND.ICON0(ID).EQ.0.AND.ICON0(ID-1).EQ.1)
* DELTC=DELT0
if(id.eq.nd) then
pip=(ptot+ptotm)/(ptot-ptotm)
t=tm*(pip+delr)/(pip-delr)
end if
DELT0=TEMP(ID)-T
PRADT(ID)=PRADT(ID)*(T/TEMP(ID))**4
DENS(ID)=DENS(ID)*(TEMP(ID)/T)
IF(TEMP(ID).NE.0.) CHANT0=ABS((T-TEMP(ID))/TEMP(ID))
IF(CHANT0.GT.CHANTM) CHANTM=CHANT0
TEMP(ID)=T
IF(ICONIT.GT.1.AND.ICON0(ID).EQ.0.AND.ICONBE.EQ.1)
* TEMP(ID)=T-DELTC
PRADM=PRADT(ID)
END DO
C
C Diagnostic outprint
C
IF(IPRING.EQ.2) THEN
WRITE(6,600) ICONIT
CALL CONOUT(1,IPRING)
END IF
600 FORMAT(1H1,' CONVECTIVE FLUX: AT CONTMD, ITER=',I2/)
C
C 2. New values of electron density and density
C
CALL HESOL6
C
C Evaluation of the Rosseland and Planck mean opacities
C
DO ID=1,ND
T=TEMP(ID)
CALL WNSTOR(ID)
CALL STEQEQ(ID,POP,1)
CALL OPACF0(ID,NFREQ)
CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA)
ABROS=OPROS/DENS(ID)
ABPLA=OPPLA/DENS(ID)
ABROSD(ID)=ABROS
ABPLAD(ID)=ABPLA
END DO
IF(CHANTM.GT.ERRT.AND.ICONIT.LT.NCONIT) GO TO 20
RETURN
END
tlusty/extracted/contmp.f
+222
View File
@@ -0,0 +1,222 @@
SUBROUTINE CONTMP
C =================
C
C Auxiliary procedure for LTEGR
C Determination of temperature in convectively unstable layers
C This is done by solving the energy balance equation
C F(rad)+F(conv)=F(mech), which yields a cubic equation for
C the logarithmic temperature gradient
C
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ALIPAR.FOR'
COMMON ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),
* DEPTH(MDEPTH),DEPTH0(MDEPTH),TAU(MDEPTH),TAU0(MDEPTH),
* TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),DM0(MDEPTH)
DIMENSION DELTR(MDEPTH),TEMPR(MDEPTH),ICON0(MDEPTH)
COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD
common/ichndm/ichanm
PARAMETER (ERRT=1.D-3)
C
C First, store the temperature(rad) and gradient Delta(rad) -
C quantities for the purely raditive equilibrium model
C
T4=TEFF**4
FLXTO0=SIG4P*T4
DPRAD=1.891204931D-15*T4
if(ifprad.eq.0) dprad=0.
C
PRAD0=DPRAD/1.732D0
DO ID=1,ND
TEMPR(ID)=TEMP(ID)
IF(ID.EQ.1) THEN
DELTR(ID)=0.
ELSE
if(ilgder.eq.0) then
DELTR(ID)=
* (TEMP(ID)-TEMP(ID-1))/(PTOTAL(ID)-PTOTAL(ID-1))*
* (PTOTAL(ID)+PTOTAL(ID-1))/(TEMP(ID)+TEMP(ID-1))
else
DELTR(ID)=
* LOG(TEMP(ID)/TEMP(ID-1))/LOG(PTOTAL(ID)/PTOTAL(ID-1))
end if
END IF
END DO
ICONIT=0
C
C ------------------------------------------------------
C Global iteration loop for calculating convective model
C ------------------------------------------------------
C
20 ICONIT=ICONIT+1
ICONBE=0
CHANTM=0.
DO ID=1,ND
T=TEMP(ID)
PTOT=PTOTAL(ID)
PGAS=PGS(ID)
PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID)
PRAD=PTOT-PGAS-PTURB
PRADT(ID)=PRAD
FLXTOT=FLXTO0
IF(IDISK.EQ.1) THEN
FLXTOT=FLXTO0*(UN-THETA(ID))
GRAVD=ZD(ID)*QGRAV
END IF
ICON0(ID)=0
C
IF(ID.EQ.1) GO TO 45
J=0
IF(ICONIT.EQ.1) T=T-TEMPR(ID-1)+TEMP(ID-1)
TM=TEMP(ID-1)
IF(T.LT.0.) T=TM
PTOTM=PTOTAL(ID-1)
if(ilgder.eq.0) then
PT0=HALF*(PTOT+PTOTM)
else
pt0=sqrt(ptot*ptotm)
end if
DELR=DELTR(ID)
C
C Inner iteration loop for determining temperature in the
C conectively unstable layers
C
30 J=J+1
TOLD=T
if(ilgder.eq.0) then
T0=HALF*(T+TM)
PG0=HALF*(PGAS+PGM)
PR0=HALF*(PRAD+PRADM)
AB0=HALF*(ABROSD(ID)+ABROSD(ID-1))
else
t0=sqrt(t*tm)
pg0=sqrt(pgas*pgm)
pr0=sqrt(prad*pradm)
ab0=sqrt(abrosd(id)*abrosd(id-1))
end if
IF(ID.GE.ND-2.AND.ICONBE.EQ.0) GO TO 40
CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DELR,FLXCNV,VCON)
IF(FLXCNV.EQ.0..or.id.lt.idconz) GO TO 40
ICON0(ID)=1
ICONBE=1
CALL CUBIC(DELTA0)
REFF=DELTA0/DELR
PRAD=PRADM+(TAUROS(ID)-TAUROS(ID-1))*DPRAD*REFF
PRADT(ID)=PRAD
PGAS=PTOT-PRAD-PTURB
if(ilgder.eq.0) then
IF(REFF.GT.UN) REFF=UN
IF(REFF.LT.0.) REFF=0.
FAC=DELTA0*(PTOT-PTOTM)/(PTOT+PTOTM)
T=TM*(UN+FAC)/(UN-FAC)
IF(T.LT.TM) T=TM
else
T=TM*(PTOT/PTOTM)**DELTA0
IF(T.LT.TM) T=TM*1.0001
end if
IF(ABS(UN-T/TOLD).GT.ERRT.AND.J.LT.10) GO TO 30
C
C Store the final quantitites
C
40 IF(ID.GT.1.AND.ICON0(ID).EQ.0.AND.ICON0(ID-1).EQ.1)
* DELTC=DELT0
45 DELT0=TEMP(ID)-T
IF(TEMP(ID).NE.0.) CHANT0=ABS((T-TEMP(ID))/TEMP(ID))
IF(CHANT0.GT.CHANTM) CHANTM=CHANT0
TEMP(ID)=T
IF(ICONIT.GT.1.AND.ICON0(ID).EQ.0.AND.ICONBE.EQ.1)
* TEMP(ID)=T-DELTC
PGM=PGAS
PRADM=PRAD
PGS(ID)=PGAS
END DO
C
C Diagnostic outprint
C
IF(IPRING.EQ.2) THEN
WRITE(6,600) ICONIT
CALL CONOUT(1,IPRING)
END IF
600 FORMAT(1H1,' CONVECTIVE FLUX: AT CONTMP, ITER=',I2/)
C
C 2. New values of electron density, density, sound spped,
C and mean opacities and optical depths
C
c
ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1))
DO 70 ID=1,ND
T=TEMP(ID)
P=PTOTAL(ID)
ITINT=0
60 ITINT=ITINT+1
if(ioptab.ge.-1) then
AN=PGS(ID)/T/BOLK
CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1)
ELEC(ID)=ANE
DENS(ID)=WMM(ID)*(AN-ANE)
PHMOL(ID)=AHMOL
C
C Corresponding LTE populations
C
if(ioptab.ge.0) then
CALL WNSTOR(ID)
CALL STEQEQ(ID,POP,1)
C
C Evaluation of the Rosseland and Planck mean opacities
C
CALL OPACF0(ID,NFREQ)
CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA)
ABROS=OPROS/DENS(ID)
ABPLA=OPPLA/DENS(ID)
else
rho=dens(id)
call meanopt(t,id,rho,abros,abpla)
abrosd(id)=abros
abplad(id)=abpla
end if
else
rho=rhoeos(t,p)
dens(id)=rho
call meanopt(t,id,rho,abros,abpla)
abrosd(id)=abros
abplad(id)=abpla
end if
C
C New values of the the column mass
C
PTOLD=PTOTAL(ID)
if(idisk.eq.0.and.ichanm.gt.0) then
IF(ID.EQ.1) THEN
DM(ID)=TAUROS(ID)/ABROS
PTOTAL(ID)=DM(ID)*GRAV+PRAD0
ELSE
DM(ID)=DM(ID-1)+(TAUROS(ID)-TAUROS(ID-1))/
* HALF/(ABROSD(ID-1)+ABROS)
PTOTAL(ID)=DM(ID)*GRAV+PRAD0
END IF
C
C Store the final quantitites
C
PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID)
PGS(ID)=PTOTAL(ID)-PRADT(ID)-PTURB
end if
ABROSD(ID)=ABROS
ABPLAD(ID)=ABPLA
IF((PTOTAL(ID)-PTOLD)/PTOLD.LT.1.D-3) GO TO 70
IF(ITINT.GT.5) THEN
WRITE(6,601) ID,PTOLD,PTOTAL(ID)
GO TO 70
ELSE
GO TO 60
END IF
70 CONTINUE
C *** TEMPORARY
C
IF(ICONIT.LT.NCONIT) GO TO 20
601 FORMAT(1H0,'SLOW CONVERGENCE OF INTERNAL ITERATIONS IN',
* ' CONTMP: ID, PTOT(OLD), PTOT(NEW) ='/I3,1P2D10.2/)
RETURN
END
tlusty/extracted/convc1.f
+67
View File
@@ -0,0 +1,67 @@
SUBROUTINE CONVC1(ID,T,PTOT,PG,PRAD,ABROS,DELTA,FLXCNV,FC0)
C ===========================================================
C
C Determination of the mixing-lengths convective flux
C
C Input: T - temperature
C PTOT - total pressure
C PG - gas pressure
C PRAD - radiation pressure
C ABROS - Rosseland opacity (per gram)
C DELTA - corresponding temperature gradient
C Output: FLXCNV - convective flux (expressed as H, ie F/4/pi)
C VCONV - convective velocity
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
COMMON/CUBCON/A,B,DDEL,GRDADB,DLT,RHO,FLXTOT,GRAVD
C
VCONV=0.
FLXCNV=0.
DLT=0.
IF(HMIX0.LT.0.) RETURN
C
C Thermodynamic derivatives
C
if(ioptab.ge.-1) then
CALL TRMDER(ID,T,PG,PRAD,TAURS(ID),HEATCP,DLRDLT,GRDADB,RHO)
else
call trmdrt(id,t,ptot,heatcp,dlrdlt,grdadb,rho)
end if
DDEL=DELTA-GRDADB
C
C Convective instability criterion
C
if(idisk.eq.0) then
HSCALE=PTOT/RHO/GRAV
else
if(gravd.eq.0.) return
hscale=ptot/rho/gravd
end if
HMIX=HMIX0
if(hmix0.eq.0.) hmix=1.
VCO=HMIX*SQRT(ABS(aconml*PTOT/RHO*DLRDLT))
FLCO=bconml*RHO*HEATCP*T*HMIX/12.5664
FC0=FLCO*VCO
IF(DDEL.LT.0.) RETURN
c
TAUE=HMIX*ABROS*RHO*HSCALE
FAC=TAUE/(UN+HALF *TAUE*TAUE)
C
C Set up parameters A and B (see Mihalas, Eq. 7-76, 7-79, etc)
C
B=5.67d-5*T**3/(rho*heatcp*VCO)*FAC*cconml*half
IF(FLXTOT.GT.0.) A=FLCO*VCO/FLXTOT*DELTA
C
C Determination of Delta - Delta(E)
C
D=B*B/2.D0
DLT=D+DDEL-B*SQRT(D/2.D0+DDEL)
IF(DLT.LT.0.) DLT=0.
C
C Resulting convective velocity VCONV and flux FLXCNV
C
VCONV=VCO*SQRT(DLT)
FLXCNV=FLCO*VCONV*DLT
RETURN
END
tlusty/extracted/convec.f
+66
View File
@@ -0,0 +1,66 @@
SUBROUTINE CONVEC(ID,T,PTOT,PG,PRAD,ABROS,DELTA,FLXCNV,VCONV)
C =============================================================
C
C Determination of the mixing-lengths convective flux
C
C Input: T - temperature
C PTOT - total pressure
C PG - gas pressure
C PRAD - radiation pressure
C ABROS - Rosseland opacity (per gram)
C DELTA - corresponding temperature gradient
C Output: FLXCNV - convective flux (expressed as H, ie F/4/pi)
C VCONV - convective velocity
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
COMMON/CUBCON/A,B,DDEL,GRDADB,DLT,RHO,FLXTOT,GRAVD
C
VCONV=0.
FLXCNV=0.
DLT=0.
GRDADB=0.
IF(HMIX0.LT.0.) RETURN
C
C Thermodynamic derivatives
C
if(ioptab.ge.-1) then
CALL TRMDER(ID,T,PG,PRAD,TAURS(ID),HEATCP,DLRDLT,GRDADB,RHO)
else
call trmdrt(id,t,ptot,heatcp,dlrdlt,grdadb,rho)
end if
DDEL=DELTA-GRDADB
C
C Convective instability criterion
C
IF(DDEL.LT.0.) RETURN
if(idisk.eq.0) then
HSCALE=PTOT/RHO/GRAV
else
if(gravd.eq.0.) return
hscale=ptot/rho/gravd
end if
HMIX=HMIX0
if(hmix0.eq.0.) hmix=1.
VCO=HMIX*SQRT(ABS(aconml*PTOT/RHO*DLRDLT))
FLCO=bconml*RHO*HEATCP*T*HMIX/12.5664
TAUE=HMIX*ABROS*RHO*HSCALE
FAC=TAUE/(UN+HALF *TAUE*TAUE)
C
C Set up parameters A and B (see Mihalas, Eq. 7-76, 7-79, etc)
C
B=5.67d-5*T**3/(rho*heatcp*VCO)*FAC*cconml*half
IF(FLXTOT.GT.0.) A=FLCO*VCO/FLXTOT*DELTA
C
C Determination of Delta - Delta(E)
C
D=B*B/2.D0
DLT=D+DDEL-B*SQRT(D/2.D0+DDEL)
IF(DLT.LT.0.) DLT=0.
C
C Resulting convective velocity VCONV and flux FLXCNV
C
VCONV=VCO*SQRT(DLT)
FLXCNV=FLCO*VCONV*DLT
RETURN
END
tlusty/extracted/coolrt.f
+103
View File
@@ -0,0 +1,103 @@
SUBROUTINE COOLRT
C =================
C
C Evaluation of cooling and heating rates for each ion
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ODFPAR.FOR'
INCLUDE 'ALIPAR.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ITERAT.FOR'
parameter (pi4=4.*3.14159265d0)
DIMENSION CLHT1(MDEPTH),CLHT2(MDEPTH),CLHT3(MDEPTH)
DIMENSION CLRAT(MION,MDEPTH),HTRAT(MION,MDEPTH)
COMMON/COOLCO/ABSOTI(MION,MDEPTH),EMISTI(MION,MDEPTH),
* ABSOC1(MDEPTH),EMISC1(MDEPTH)
C
DO ID=1,ND
DO ION=1,NION
CLRAT(ION,ID)=0.
HTRAT(ION,ID)=0.
END DO
CLHT1(ID)=0.
CLHT2(ID)=0.
CLHT3(ID)=0.
END DO
C
DO IJ=1,NFREQ
IF(IJX(IJ).NE.-1) THEN
CALL OPACFA(IJ)
CALL RTEFR1(IJ)
DO ID=1,ND
DO ION=1,NION
CLRAT(ION,ID)=CLRAT(ION,ID)+W(IJ)*EMISTI(ION,ID)
HTRAT(ION,ID)=HTRAT(ION,ID)+
& W(IJ)*ABSOTI(ION,ID)*RAD1(ID)
END DO
EM=EMIS1(ID)+SCAT1(ID)*RAD1(ID)
CLHT2(ID)=CLHT2(ID)+W(IJ)*(EM-ABSO1(ID)*RAD1(ID))
CLHT3(ID)=CLHT3(ID)+W(IJ)*EMIS1(ID)
END DO
C
if(ipopac.eq.1) then
if(ij.le.nfreqc) then
write(85,685) ij,freq(ij),(absoc1(id)/dens(id),id=1,nd)
end if
end if
if(ipopac.eq.2) then
if(ij.le.nfreqc) then
write(87,686) ij,freq(ij)
taud=abso1(1)*dedm1
do id=1,nd
if(id.gt.1) taud=taud+deldmz(id-1)*
* (absot(id-1)+absot(id))
end do
end if
end if
685 format(i5,1pe15.7/(1p8e10.3))
686 format(i5,1pe15.7)
C
END IF
END DO
C
if(icoolp.le.0) return
C
DO ID=1,ND
DO ION=1,NION
CLHT1(ID)=CLHT1(ID)+CLRAT(ION,ID)-HTRAT(ION,ID)
END DO
WRITE(86,1060) ID,CLHT1(ID)*pi4,CLHT2(ID)*pi4,
* CLHT3(ID)*pi4
1060 FORMAT(I5,1P3E14.6)
END DO
c
if(icoolp.lt.2) return
c
DO ID=1,ND
WRITE(87,1071) id,
* ((CLRAT(ION,ID)-HTRAT(ION,ID))*pi4,ION=1,NION)
END DO
c
if(icoolp.lt.10) return
WRITE(87,1070) ND,NION
IOFE2=0
DO ION=1,NION
NN1=NFIRST(ION)
IAT2=IATM(NN1)
IF(NUMAT(IAT2).EQ.26 .and. IZ(ION).EQ.2) IOFE2=ION
END DO
REWIND 8
READ(8,*) NDR
READ(8,*) TTR,RSR
DO ID=ND,1,-1
READ(8,*) RSR
WRITE(88,1071) RSR,CLRAT(IOFE2,ID)
END DO
1070 FORMAT(2I5)
1071 FORMAT(i5/(1P6E13.5))
RETURN
END
tlusty/extracted/corrwm.f
+125
View File
@@ -0,0 +1,125 @@
SUBROUTINE CORRWM
C =================
C
C The routine for management of various flags for treating
C frequency points; in particular those connected to the so-called
C "subtraction weights" (in the non-overlapping mode only)
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (T15=1.D-15)
C
NFREQE=0
DO 10 IJ=1,NFREQ
IJEX(IJ)=0
DO ID=1,ND
LSKIP(ID,IJ)=.FALSE.
END DO
if(ifprad.eq.0) then
do id=1,nd
lskip(id,ij)=.true.
end do
end if
IF(IJALI(IJ).NE.0) GO TO 10
NFREQE=NFREQE+1
IJEX(IJ)=NFREQE
IJFR(NFREQE)=IJ
10 CONTINUE
c
if(ifryb.ne.0) then
nfreqe=0
do ij=1,nfreq
ijex(ij)=0
end do
end if
C
IF(IBFINT.LE.0) THEN
DO IJ=1,NFREQ
IJBF(IJ)=IJ
AIJBF(IJ)=UN
END DO
ELSE
IF(ISPODF.EQ.0) THEN
DO IJ=1,NFREQC
IJBF(IJ)=IJ
AIJBF(IJ)=UN
END DO
IF(NFREQ.GT.NFREQC) THEN
DO IJ=NFREQC+1,NFREQ
FR=FREQ(IJ)
IJ0=1
DO IJT=1,NFREQC
IF(FREQ(IJT).LE.FR) THEN
IJ0=IJT
GO TO 12
END IF
END DO
12 IJ1=IJ0-1
A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))
IJBF(IJ)=IJ1
AIJBF(IJ)=A1
END DO
END IF
ELSE
DO IJ=1,NFREQC-1
IJ0=IFREQB(IJ)
IJ1=IFREQB(IJ+1)
DO KJ=IJ0,IJ1-1
IJBF(KJ)=IJ
AIJBF(KJ)=(FREQ(KJ)-FREQ(IJ1))/(FREQ(IJ0)-FREQ(IJ1))
END DO
END DO
IJ0=IFREQB(NFREQC)
IJBF(IJ0)=NFREQC
AIJBF(IJ0)=UN
END IF
END IF
C
if(nfreqe.gt.mfrex) CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex)
C
DO 100 ITR=1,NTRANS
IF(.NOT.LINE(ITR)) GO TO 100
C
C first set up array LSKIP(ID,IJ), which has values
C TRUE - if the radiation at frequency point IJ does not contribute
C radiation pressure (ie. this point belongs to a transition
C for which the user required the radiation pressure to be
C skipped - IABS(INDEXP) chosen as 9 or 19)
C FALSE - normal calculatitn of radiation pressure
C
INX=IABS(INDEXP(ITR))
IF(INX.EQ.9.OR.INX.GE.19) THEN
DO IJ=IFR0(ITR),IFR1(ITR)
DO ID=1,ND
LSKIP(ID,IJ)=.TRUE.
END DO
END DO
END IF
100 CONTINUE
C
IF(NFREQE.GT.0) WRITE(6,609)
DO 110 IJ=1,NFREQ
FR15=FREQ(IJ)*T15
W0E(IJ)=W(IJ)*PI4H/FREQ(IJ)
BNUE(IJ)=BN*FR15*FR15*FR15
IF(IJALI(IJ).NE.0.or.ifryb.gt.0) GO TO 110
if(ispodf.eq.0) then
WRITE(6,610) IJ,FREQ(IJ),W(IJ),PROF(IJ)
else
WRITE(6,610) IJ,FREQ(IJ),W(IJ)
end if
110 CONTINUE
C
DO IJ=1,NFREQ
WC(IJ)=W(IJ)
IF(IJALI(IJ).LE.0) WC(IJ)=0.
END DO
C
609 FORMAT(1H0//' FREQUENCY POINTS AND WEIGHTS - EXPLICIT'/
* ' ---------------------------------------'//
* ' IJ',7X,'FREQ',13X,'WEIGHT',11X,'PROF'/)
610 FORMAT(1H ,I8,1P2D17.8,D15.5,D17.8)
RETURN
END
tlusty/extracted/cross.f
+18
View File
@@ -0,0 +1,18 @@
FUNCTION CROSS(IBFT,IJ)
C =======================
C
C Evaluation of the photoionization cross-section
C IBF - index ot the b-f transition
C IJ - frequency index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
C
IJ0=IJBF(IJ)
A1=AIJBF(IJ)
CROSS=A1*BFCS(IBFT,IJ0)+(UN-A1)*BFCS(IBFT,IJ0+1)
c
RETURN
END
tlusty/extracted/crossd.f
+31
View File
@@ -0,0 +1,31 @@
FUNCTION CROSSD(IBFT,IJ,ID)
C ===========================
C
C Evaluation of the photoionization cross-section
C IBF - index ot the b-f transition
C IJ - frequency index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
C
IJ0=IJBF(IJ)
A1=AIJBF(IJ)
CROSSD=A1*BFCS(IBFT,IJ0)+(UN-A1)*BFCS(IBFT,IJ0+1)
c
c contribution from dielectronic recombination
c
if(ifdiel.eq.0) return
ITR=ITRBF(IBFT)
if(idiel(itr).gt.0.and.id.gt.0) then
i=ilow(itr)
ion=iel(i)
if(i.eq.nfirst(ion).and.iup(itr).eq.nnext(ion)) then
if(freq(ij).ge.fr0(itr).and.freq(ij).le.fr0(itr)*1.1)
* crossd=crossd+diesig(ion,id)
end if
end if
c
RETURN
END
tlusty/extracted/cspec.f
+89
View File
@@ -0,0 +1,89 @@
SUBROUTINE CSPEC(I,J,IC,OS,CP,U0,T,CS)
C ======================================
C
C Non-standard evaluation of collision rates
C Basically user-supplied procedure; here is an example
C
C Van Regemorter's formula following the recommendations of
C Mihalas (1978, Stellar Atmospheres, 2nd edition)
C IC=-1 for neutrals
C IC=-2 for ions
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
DIMENSION CHE1FB(3,4)
DATA CHE1FB/ 9.63675,-2.22941,-17.30103,
* 10.85578,-2.40931,-27.00903,
* 8.38043,-2.04791,-7.36621,
* 6.95825,-2.01967,-5.98779/
PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193,
* EXPIA3=-0.24991055,EXPIA4=0.05519968,
* EXPIA5=-0.00976004,EXPIA6=0.00107857,
* EXPIB1=0.2677734343,EXPIB2=8.6347608925,
* EXPIB3=18.059016973,EXPIB4=8.5733287401,
* EXPIC1=3.9584969228,EXPIC2=21.0996530827,
* EXPIC3=25.6329561486,EXPIC4=9.5733223454)
CS=0.
IF(IC.GT.-10) THEN
IF(U0.LE.UN) THEN
EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+
* U0*(EXPIA5+U0*EXPIA6))))
ELSE
EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+
* U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+
* U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0
END IF
CCCCCC Neutrals (See Auer & Mihalas 1973)
IF(IC.EQ.-1) THEN
IF(U0.LE.14.) THEN
GG=0.276*EXP(U0)*EXPIU0
ELSE
GG=0.066*(1.+1.5/U0)/SQRT(U0)
ENDIF
CCCCCC Ions (See Mihalas 1972)
ELSE IF(IC.EQ.-2) THEN
GG0=0.276*EXP(U0)*EXPIU0
GG=CP
IF(GG0.GT.CP) GG=GG0
END IF
T32=T**(-1.5)
CS=CS+19.7363*T32*EXP(-U0)/U0*GG*OS
RETURN
END IF
C
IF(IC.EQ.-11) THEN
XR=-1.68D0
CS=CS+2.16*U0**XR/T/SQRT(T)*EXP(-U0)*OS
C
C Forbidden transitions between n=2 He I sublevels
C (from Klaus Werner)
C
ELSE IF(IC.EQ.-12) THEN
N0I=NFIRST(IELHE1)
I=I-N0I+1
J=J-N0I+1
IFORB=0
IF(I.EQ.2 .AND. J.EQ.3) IFORB=1
IF(I.EQ.2 .AND. J.EQ.5) IFORB=2
IF(I.EQ.3 .AND. J.EQ.4) IFORB=3
IF(I.EQ.4 .AND. J.EQ.5) IFORB=4
IF(IFORB.EQ.0) CALL QUIT(' Inconsistent ICOL - CSPEC',iforb,0)
XT=LOG10(T)
GAM=CHE1FB(1,IFORB)+CHE1FB(2,IFORB)*XT+CHE1FB(3,IFORB)/XT/XT
GAM=EXP(2.30258509299405*GAM)
CS=CS+5.465D-11*SQRT(T)*EXP(-U0)*GAM
END IF
RETURN
END
tlusty/extracted/ctdata.f
+234
View File
@@ -0,0 +1,234 @@
block data ctdata
c
c real CTIon
c second dimension is ionization stage,
c 1=+0 for parent, etc
c third dimension is atomic number of atom
INCLUDE 'IMPLIC.FOR'
common/CTIon/ CTIon(7,4,30)
c real CTRecomb
c second dimension is ionization stage,
c 1=+1 for parent, etc
c third dimension is atomic number of atom
common/CTRecomb/ CTRecomb(6,4,30)
c
c local variables
c integer i
c
c digital form of the fits to the charge transfer
c ionization rate coefficients
c
c Note: First parameter is in units of 1e-9!
c Note: Seventh parameter is in units of 1e4 K
c ionization
data (CTIon(i,1,3),i=1,7)/2.84e-3,1.99,375.54,-54.07,1e2,1e4,0.0/
data (CTIon(i,2,3),i=1,7)/7*0./
data (CTIon(i,3,3),i=1,7)/7*0./
data (CTIon(i,1,4),i=1,7)/7*0./
data (CTIon(i,2,4),i=1,7)/7*0./
data (CTIon(i,3,4),i=1,7)/7*0./
data (CTIon(i,1,5),i=1,7)/7*0./
data (CTIon(i,2,5),i=1,7)/7*0./
data (CTIon(i,3,5),i=1,7)/7*0./
data (CTIon(i,1,6),i=1,7)/1.07e-6,3.15,176.43,-4.29,1e3,1e5,0.0/
data (CTIon(i,2,6),i=1,7)/7*0./
data (CTIon(i,3,6),i=1,7)/7*0./
data (CTIon(i,1,7),i=1,7)/4.55e-3,-0.29,-0.92,-8.38,1e2,5e4,1.086/
data (CTIon(i,2,7),i=1,7)/7*0./
data (CTIon(i,3,7),i=1,7)/7*0./
data (CTIon(i,1,8),i=1,7)/7.40e-2,0.47,24.37,-0.74,1e1,1e4,0.023/
data (CTIon(i,2,8),i=1,7)/7*0./
data (CTIon(i,3,8),i=1,7)/7*0./
data (CTIon(i,1,9),i=1,7)/7*0./
data (CTIon(i,2,9),i=1,7)/7*0./
data (CTIon(i,3,9),i=1,7)/7*0./
data (CTIon(i,1,10),i=1,7)/7*0./
data (CTIon(i,2,10),i=1,7)/7*0./
data (CTIon(i,3,10),i=1,7)/7*0./
data (CTIon(i,1,11),i=1,7)/3.34e-6,9.31,2632.31,-3.04,1e3,2e4,0.0/
data (CTIon(i,2,11),i=1,7)/7*0./
data (CTIon(i,3,11),i=1,7)/7*0./
data (CTIon(i,1,12),i=1,7)/9.76e-3,3.14,55.54,-1.12,5e3,3e4,0.0/
data (CTIon(i,2,12),i=1,7)/7.60e-5,0.00,-1.97,-4.32,1e4,3e5,1.670/
data (CTIon(i,3,12),i=1,7)/7*0./
data (CTIon(i,1,13),i=1,7)/7*0./
data (CTIon(i,2,13),i=1,7)/7*0./
data (CTIon(i,3,13),i=1,7)/7*0./
data (CTIon(i,1,14),i=1,7)/0.92,1.15,0.80,-0.24,1e3,2e5,0.0/
data (CTIon(i,2,14),i=1,7)/2.26,7.36e-2,-0.43,-0.11,2e3,1e5,
1 3.031/
data (CTIon(i,3,14),i=1,7)/7*0./
data (CTIon(i,1,15),i=1,7)/7*0./
data (CTIon(i,2,15),i=1,7)/7*0./
data (CTIon(i,3,15),i=1,7)/7*0./
data (CTIon(i,1,16),i=1,7)/1.00e-5,0.00,0.00,0.00,1e3,1e4,0.0/
data (CTIon(i,2,16),i=1,7)/7*0./
data (CTIon(i,3,16),i=1,7)/7*0./
data (CTIon(i,1,17),i=1,7)/7*0./
data (CTIon(i,2,17),i=1,7)/7*0./
data (CTIon(i,3,17),i=1,7)/7*0./
data (CTIon(i,1,18),i=1,7)/7*0./
data (CTIon(i,2,18),i=1,7)/7*0./
data (CTIon(i,3,18),i=1,7)/7*0./
data (CTIon(i,1,19),i=1,7)/7*0./
data (CTIon(i,2,19),i=1,7)/7*0./
data (CTIon(i,3,19),i=1,7)/7*0./
data (CTIon(i,1,20),i=1,7)/7*0./
data (CTIon(i,2,20),i=1,7)/7*0./
data (CTIon(i,3,20),i=1,7)/7*0./
data (CTIon(i,1,21),i=1,7)/7*0./
data (CTIon(i,2,21),i=1,7)/7*0./
data (CTIon(i,3,21),i=1,7)/7*0./
data (CTIon(i,1,22),i=1,7)/7*0./
data (CTIon(i,2,22),i=1,7)/7*0./
data (CTIon(i,3,22),i=1,7)/7*0./
data (CTIon(i,1,23),i=1,7)/7*0./
data (CTIon(i,2,23),i=1,7)/7*0./
data (CTIon(i,3,23),i=1,7)/7*0./
data (CTIon(i,1,24),i=1,7)/7*0./
data (CTIon(i,2,24),i=1,7)/4.39,0.61,-0.89,-3.56,1e3,3e4,3.349/
data (CTIon(i,3,24),i=1,7)/7*0./
data (CTIon(i,1,25),i=1,7)/7*0./
data (CTIon(i,2,25),i=1,7)/2.83e-1,6.80e-3,6.44e-2,-9.70,1e3,3e4,
1 2.368/
data (CTIon(i,3,25),i=1,7)/7*0./
data (CTIon(i,1,26),i=1,7)/7*0./
data (CTIon(i,2,26),i=1,7)/2.10,7.72e-2,-0.41,-7.31,1e4,1e5,3.005/
data (CTIon(i,3,26),i=1,7)/7*0./
data (CTIon(i,1,27),i=1,7)/7*0./
data (CTIon(i,2,27),i=1,7)/1.20e-2,3.49,24.41,-1.26,1e3,3e4,4.044/
data (CTIon(i,3,27),i=1,7)/7*0./
data (CTIon(i,1,28),i=1,7)/7*0./
data (CTIon(i,2,28),i=1,7)/7*0./
data (CTIon(i,3,28),i=1,7)/7*0./
data (CTIon(i,1,29),i=1,7)/7*0./
data (CTIon(i,2,29),i=1,7)/7*0./
data (CTIon(i,3,29),i=1,7)/7*0./
data (CTIon(i,1,30),i=1,7)/7*0./
data (CTIon(i,2,30),i=1,7)/7*0./
data (CTIon(i,3,30),i=1,7)/7*0./
c
c digital form of the fits to the charge transfer
c recombination rate coefficients (total)
c
c Note: First parameter is in units of 1e-9!
c recombination
data (CTRecomb(i,1,2),i=1,6)/7.47e-6,2.06,9.93,-3.89,6e3,1e5/
data (CTRecomb(i,2,2),i=1,6)/1.00e-5,0.,0.,0.,1e3,1e7/
data (CTRecomb(i,1,3),i=1,6)/6*0./
data (CTRecomb(i,2,3),i=1,6)/1.26,0.96,3.02,-0.65,1e3,3e4/
data (CTRecomb(i,3,3),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,1,4),i=1,6)/6*0./
data (CTRecomb(i,2,4),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,3,4),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,4,4),i=1,6)/5.17,0.82,-0.69,-1.12,2e3,5e4/
data (CTRecomb(i,1,5),i=1,6)/6*0./
data (CTRecomb(i,2,5),i=1,6)/2.00e-2,0.,0.,0.,1e3,1e9/
data (CTRecomb(i,3,5),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,4,5),i=1,6)/2.74,0.93,-0.61,-1.13,2e3,5e4/
data (CTRecomb(i,1,6),i=1,6)/4.88e-7,3.25,-1.12,-0.21,5.5e3,1e5/
data (CTRecomb(i,2,6),i=1,6)/1.67e-4,2.79,304.72,-4.07,5e3,5e4/
data (CTRecomb(i,3,6),i=1,6)/3.25,0.21,0.19,-3.29,1e3,1e5/
data (CTRecomb(i,4,6),i=1,6)/332.46,-0.11,-9.95e-1,-1.58e-3,1e1,
1 1e5/
data (CTRecomb(i,1,7),i=1,6)/1.01e-3,-0.29,-0.92,-8.38,1e2,5e4/
data (CTRecomb(i,2,7),i=1,6)/3.05e-1,0.60,2.65,-0.93,1e3,1e5/
data (CTRecomb(i,3,7),i=1,6)/4.54,0.57,-0.65,-0.89,1e1,1e5/
data (CTRecomb(i,4,7),i=1,6)/2.95,0.55,-0.39,-1.07,1e3,1e6/
data (CTRecomb(i,1,8),i=1,6)/1.04,3.15e-2,-0.61,-9.73,1e1,1e4/
data (CTRecomb(i,2,8),i=1,6)/1.04,0.27,2.02,-5.92,1e2,1e5/
data (CTRecomb(i,3,8),i=1,6)/3.98,0.26,0.56,-2.62,1e3,5e4/
data (CTRecomb(i,4,8),i=1,6)/2.52e-1,0.63,2.08,-4.16,1e3,3e4/
data (CTRecomb(i,1,9),i=1,6)/6*0./
data (CTRecomb(i,2,9),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,3,9),i=1,6)/9.86,0.29,-0.21,-1.15,2e3,5e4/
data (CTRecomb(i,4,9),i=1,6)/7.15e-1,1.21,-0.70,-0.85,2e3,5e4/
data (CTRecomb(i,1,10),i=1,6)/6*0./
data (CTRecomb(i,2,10),i=1,6)/1.00e-5,0.,0.,0.,5e3,5e4/
data (CTRecomb(i,3,10),i=1,6)/14.73,4.52e-2,-0.84,-0.31,5e3,5e4/
data (CTRecomb(i,4,10),i=1,6)/6.47,0.54,3.59,-5.22,1e3,3e4/
data (CTRecomb(i,1,11),i=1,6)/6*0./
data (CTRecomb(i,2,11),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/
data (CTRecomb(i,3,11),i=1,6)/1.33,1.15,1.20,-0.32,2e3,5e4/
data (CTRecomb(i,4,11),i=1,6)/1.01e-1,1.34,10.05,-6.41,2e3,5e4/
data (CTRecomb(i,1,12),i=1,6)/6*0./
data (CTRecomb(i,2,12),i=1,6)/8.58e-5,2.49e-3,2.93e-2,-4.33,1e3,
1 3e4/
data (CTRecomb(i,3,12),i=1,6)/6.49,0.53,2.82,-7.63,1e3,3e4/
data (CTRecomb(i,4,12),i=1,6)/6.36,0.55,3.86,-5.19,1e3,3e4/
data (CTRecomb(i,1,13),i=1,6)/6*0./
data (CTRecomb(i,2,13),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,13),i=1,6)/7.11e-5,4.12,1.72e4,-22.24,1e3,3e4/
data (CTRecomb(i,4,13),i=1,6)/7.52e-1,0.77,6.24,-5.67,1e3,3e4/
data (CTRecomb(i,1,14),i=1,6)/6*0./
data (CTRecomb(i,2,14),i=1,6)/6.77,7.36e-2,-0.43,-0.11,5e2,1e5/
data (CTRecomb(i,3,14),i=1,6)/4.90e-1,-8.74e-2,-0.36,-0.79,1e3,
1 3e4/
data (CTRecomb(i,4,14),i=1,6)/7.58,0.37,1.06,-4.09,1e3,5e4/
data (CTRecomb(i,1,15),i=1,6)/6*0./
data (CTRecomb(i,2,15),i=1,6)/1.74e-4,3.84,36.06,-0.97,1e3,3e4/
data (CTRecomb(i,3,15),i=1,6)/9.46e-2,-5.58e-2,0.77,-6.43,1e3,3e4/
data (CTRecomb(i,4,15),i=1,6)/5.37,0.47,2.21,-8.52,1e3,3e4/
data (CTRecomb(i,1,16),i=1,6)/3.82e-7,11.10,2.57e4,-8.22,1e3,1e4/
data (CTRecomb(i,2,16),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,16),i=1,6)/2.29,4.02e-2,1.59,-6.06,1e3,3e4/
data (CTRecomb(i,4,16),i=1,6)/6.44,0.13,2.69,-5.69,1e3,3e4/
data (CTRecomb(i,1,17),i=1,6)/6*0./
data (CTRecomb(i,2,17),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,17),i=1,6)/1.88,0.32,1.77,-5.70,1e3,3e4/
data (CTRecomb(i,4,17),i=1,6)/7.27,0.29,1.04,-10.14,1e3,3e4/
data (CTRecomb(i,1,18),i=1,6)/6*0./
data (CTRecomb(i,2,18),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,18),i=1,6)/4.57,0.27,-0.18,-1.57,1e3,3e4/
data (CTRecomb(i,4,18),i=1,6)/6.37,0.85,10.21,-6.22,1e3,3e4/
data (CTRecomb(i,1,19),i=1,6)/6*0./
data (CTRecomb(i,2,19),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,19),i=1,6)/4.76,0.44,-0.56,-0.88,1e3,3e4/
data (CTRecomb(i,4,19),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,1,20),i=1,6)/6*0./
data (CTRecomb(i,2,20),i=1,6)/0.,0.,0.,0.,1e1,1e9/
data (CTRecomb(i,3,20),i=1,6)/3.17e-2,2.12,12.06,-0.40,1e3,3e4/
data (CTRecomb(i,4,20),i=1,6)/2.68,0.69,-0.68,-4.47,1e3,3e4/
data (CTRecomb(i,1,21),i=1,6)/6*0./
data (CTRecomb(i,2,21),i=1,6)/0.,0.,0.,0.,1e1,1e9/
data (CTRecomb(i,3,21),i=1,6)/7.22e-3,2.34,411.50,-13.24,1e3,3e4/
data (CTRecomb(i,4,21),i=1,6)/1.20e-1,1.48,4.00,-9.33,1e3,3e4/
data (CTRecomb(i,1,22),i=1,6)/6*0./
data (CTRecomb(i,2,22),i=1,6)/0.,0.,0.,0.,1e1,1e9/
data (CTRecomb(i,3,22),i=1,6)/6.34e-1,6.87e-3,0.18,-8.04,1e3,3e4/
data (CTRecomb(i,4,22),i=1,6)/4.37e-3,1.25,40.02,-8.05,1e3,3e4/
data (CTRecomb(i,1,23),i=1,6)/6*0./
data (CTRecomb(i,2,23),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,23),i=1,6)/5.12,-2.18e-2,-0.24,-0.83,1e3,3e4/
data (CTRecomb(i,4,23),i=1,6)/1.96e-1,-8.53e-3,0.28,-6.46,1e3,3e4/
data (CTRecomb(i,1,24),i=1,6)/6*0./
data (CTRecomb(i,2,24),i=1,6)/5.27e-1,0.61,-0.89,-3.56,1e3,3e4/
data (CTRecomb(i,3,24),i=1,6)/10.90,0.24,0.26,-11.94,1e3,3e4/
data (CTRecomb(i,4,24),i=1,6)/1.18,0.20,0.77,-7.09,1e3,3e4/
data (CTRecomb(i,1,25),i=1,6)/6*0./
data (CTRecomb(i,2,25),i=1,6)/1.65e-1,6.80e-3,6.44e-2,-9.70,1e3,
1 3e4/
data (CTRecomb(i,3,25),i=1,6)/14.20,0.34,-0.41,-1.19,1e3,3e4/
data (CTRecomb(i,4,25),i=1,6)/4.43e-1,0.91,10.76,-7.49,1e3,3e4/
data (CTRecomb(i,1,26),i=1,6)/6*0./
data (CTRecomb(i,2,26),i=1,6)/1.26,7.72e-2,-0.41,-7.31,1e3,1e5/
data (CTRecomb(i,3,26),i=1,6)/3.42,0.51,-2.06,-8.99,1e3,1e5/
data (CTRecomb(i,4,26),i=1,6)/14.60,3.57e-2,-0.92,-0.37,1e3,3e4/
data (CTRecomb(i,1,27),i=1,6)/6*0./
data (CTRecomb(i,2,27),i=1,6)/5.30,0.24,-0.91,-0.47,1e3,3e4/
data (CTRecomb(i,3,27),i=1,6)/3.26,0.87,2.85,-9.23,1e3,3e4/
data (CTRecomb(i,4,27),i=1,6)/1.03,0.58,-0.89,-0.66,1e3,3e4/
data (CTRecomb(i,1,28),i=1,6)/6*0./
data (CTRecomb(i,2,28),i=1,6)/1.05,1.28,6.54,-1.81,1e3,1e5/
data (CTRecomb(i,3,28),i=1,6)/9.73,0.35,0.90,-5.33,1e3,3e4/
data (CTRecomb(i,4,28),i=1,6)/6.14,0.25,-0.91,-0.42,1e3,3e4/
data (CTRecomb(i,1,29),i=1,6)/6*0./
data (CTRecomb(i,2,29),i=1,6)/1.47e-3,3.51,23.91,-0.93,1e3,3e4/
data (CTRecomb(i,3,29),i=1,6)/9.26,0.37,0.40,-10.73,1e3,3e4/
data (CTRecomb(i,4,29),i=1,6)/11.59,0.20,0.80,-6.62,1e3,3e4/
data (CTRecomb(i,1,30),i=1,6)/6*0./
data (CTRecomb(i,2,30),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/
data (CTRecomb(i,3,30),i=1,6)/6.96e-4,4.24,26.06,-1.24,1e3,3e4/
data (CTRecomb(i,4,30),i=1,6)/1.33e-2,1.56,-0.92,-1.20,1e3,3e4/
c
end
tlusty/extracted/cubic.f
+62
View File
@@ -0,0 +1,62 @@
SUBROUTINE CUBIC(DELTA)
C =======================
C
C Solution of the cubic equation for determination of
C the true gradient DELTA
C
C Input: A,B - coefficients; transmitted by COMMON/CUBCON
C DEL - DELTA(RAD) - DELTA(ADIAB); also transm. by CUBCON
C Output: DELTA - true gradient
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD
PARAMETER (THIRD = 0.333333333333333D0)
data ipri /0/
C
C first solve the cubic equation
C A*X**3 + X**2 + B*X = DEL
C where X = (DELTA - DELTA(ELEM))**(1/2)
C
AA=THIRD/A
BB=B/A
CC=-DEL/A
P=BB*THIRD-AA*AA
Q=AA**3-(BB*AA-CC)/2.D0
D=Q*Q+P*P*P
IF(D.GT.0.) THEN
D=SQRT(D)
if(d-abs(q).lt.1.e-14*d) then
SOL=(2.D0*D)**THIRD-AA
ELSE
D1=ABS(D-Q)
D2=ABS(D+Q)
SOL=D1/(D-Q)*D1**THIRD-D2/(D+Q)*D2**THIRD-AA
END IF
ELSE
COSF=-Q/SQRT(ABS(P*P*P))
TANF=SQRT(UN-COSF*COSF)/COSF
FI=ATAN(TANF)*THIRD
SOL=2.D0*SQRT(ABS(P))*COS(FI)-AA
END IF
C
C if the previous formalism gives an unphysical solution
C x > DEL, then find the physical solution in the range (0, DEL)
C by a Newton-Raphson solution of the cubic equation
C
DELDA=SOL*(B+SOL)
IF(DELDA.GT.DEL.OR.DELDA.LT.0.) THEN
X0=sol
J=0
10 DELX=(DEL-X0*(B+X0+A*X0*X0))/(3.D0*A*X0*X0+2.D0*X0+B)
X0=X0+DELX
J=J+1
IF(ABS(DELX/X0).GT.1D-6.AND.J.LT.50) GO TO 10
SOL=X0
END IF
C
C finally, the actual gradient delta
C
DELTA=GRDADB+B*SOL+SOL*SOL
RETURN
END
tlusty/extracted/dielrc.f
+379
View File
@@ -0,0 +1,379 @@
subroutine dielrc(iatom,iont,temp,xpx,dirt,sig0)
c ================================================
c
INCLUDE 'IMPLIC.FOR'
c
c
c Modification of Tim Kallman's XSTAR routine rrrec to calculate dielectronic
c recombination rates (only) to individual ionic species (modified by Omer
c Blaes 5-8-98)
c
c Here temp=temperature in K, xpx is the number density of atomic nuclei in
c cm^{-3} (hydrogen density=xpx/1.1, helium density=xpx*0.1/1.1),
c dirt =the dielectronic rate in cm^3/s,
c sig0 = the value of sigma_0, the corresponding pseudo-cross-section
c iatom - atomic number (1=H, 2=He, 6=C, etc.)
c iont - ionization stage (1 for neutrals, 2 for once ionized, etc.)
c
c this routine computes radiative recombination rates, both rr
c and dr. rates are output in units of cm**3/s for each ion
c stage, where ions are numbered from 1-168:
c 1=HI, 2=HeI, 3=HeII, 4=C I, 5=C II, ..., 9=C VI, 10=N I, ...,
c 16=N VII, 17=O I, ..., 24=O VIII, 25=Ne I, ..., 34=Ne X,
c 35=Mg I, ..., 46=Mg XII, 47=Si I, ..., 60=Si XIV, 61=S I, ...,
c 76=S XVI, 77=Ar I, ..., 94=Ar XVIII, 95=Ca I, ... 114=Ca XX,
c 115=Fe I, ..., 140=Fe XXVI, 141=Ni I, ... 168=Ni XXVIII.
c inputs are rate coefficients from Aldrovandi and Pequignot, Storey,
c and from Arnaud and Raymond for iron
c
parameter (nni=168)
parameter (cons=0.1239529*3.28805e15/13.595)
dimension inid(28,28),uu(28,28)
dimension adi(nni),bdi(nni),t0(nni),t1(nni),cdd(nni)
dimension dcfe(26,4),defe(26,4)
dimension gli(20),gfe(26),gni(28)
dimension istorey(13),rstorey(5,13)
c
c
c Each non-indented line in the following data statements corresponds
c to each of the elements H, He, C, N, O, Ne, Mg, Si, S, Ar, Ca, Fe,
c and Ni.
c
data inid/1, 27*0,
* 2, 3, 26*0,
* 28*0,
* 28*0,
* 28*0,
* 4, 5, 6, 7, 8, 9, 22*0,
* 10,11,12,13,14,15,16, 21*0,
* 17,18,19,20,21,22,23,24, 20*0,
* 28*0,
* 25,26,27,28,29,30,31,32,33,34, 18*0,
* 28*0,
* 35,36,37,38,39,40,41,42,43,44,45,46, 16*0,
* 28*0,
* 47,48,49,50,51,52,53,54,55,56,57,58,59,60,14*0,
* 28*0,
* 61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,12*0,
* 28*0,
* 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,
* 10*0,
* 28*0,
* 95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,
* 110,111,112,113,114,8*0,
* 28*0,
* 28*0,
* 28*0,
* 28*0,
* 28*0,
* 115,116,117,118,119,120,121,122,123,124,125,126,127,128,
* 129,130,131,132,133,134,135,136,137,138,139,140,2*0,
* 28*0,
* 141,142,143,144,145,146,147,148,149,150,151,152,153,154,
* 155,156,157,158,159,160,161,162,163,164,165,166,167,168/
data adi/0.,
% 1.9E-03,0.,
% 6.9E-04,7.0E-03,3.8E-03,4.8E-02,4.8E-02,0.,
% 5.2E-04,1.7E-03,1.2E-02,5.5E-03,7.6E-02,6.6E-02,0.,
% 1.4E-03,1.4E-03,2.8E-03,1.7E-02,7.1E-03,1.1E-01,8.6E-02,
% 0.0,
% 1.3E-03,3.1E-03,7.5E-03,5.7E-03,1.0E-02,4.0E-02,1.1E-02,
% 1.8E-01,1.3E-01,0.,
% 1.7E-3,3.5E-3,3.9E-3,9.3E-3,1.5E-2,1.2E-2,
% 1.4E-2,3.8E-2,1.4E-2,2.6E-1,1.7E-1,0.,
% 6.2E-03,1.4E-02,1.1E-02,1.4E-02,7.8E-03,1.6E-02,2.3E-02,
% 1.1E-02,1.1E-02,4.8E-02,1.8E-02,3.4E-01,2.1E-01,0.,
% 7.3E-05,4.9E-03,9.1E-03,4.3E-02,2.5E-02,3.1E-02,1.3E-02,
% 2.1E-02,3.5E-02,3.0E-02,3.1E-02,6.3E-02,2.3E-02,
% 4.2E-01,2.5E-01,0.,
% .0001,.011,.034,.0685,.090,.0635,.0260,.017,
% .0210,.0350,.0540,.0713,.0960,.0850,.0170,
% .476,.297,0.,
% 3.28E-4,5.84E-02,1.12E-01,1.32E-01,1.33E-01,1.26E-01,
% 1.39E-01,9.55E-02,4.02E-01,4.19E-02,2.57E-02,4.45E-02,
% 5.48E-02,7.13E-02,9.03E-02,1.10E-01,2.05E-02,5.49E-01,
% 3.55E-01,0.,
% 1.8E-3,3.6E-2,7.8E-2,2.2E-1,1.4E-1,1.4E-1,
% 1.1E-1,6.3E-1,5.5E-1,3.6E-1,2.6E-1,1.6E-1,
% 6.6E-2,2.5E-1,1.2E-1,5.0E+0,3.7E-2,6.3E-2,
% 7.0E-2,1.1E-1,1.0E-1,1.1E-1,3.6E-2,7.5E-1,
% 5.2E-1,0.,
% 1.41E-03, 5.20E-03, 1.38E-02, 2.30E-02, 4.19E-02,
% 6.83E-02, 1.22E-01, 3.00E-01, 1.50E-01, 6.97E-01,
% 7.09E-01, 6.44E-01, 5.25E-01, 4.46E-01, 3.63E-01,
% 3.02E-01, 1.02E-01, 2.70E-01, 4.67E-02, 8.35E-02,
% 9.96E-02, 1.99E-01, 2.40E-01, 1.15E-01, 3.16E-02,
% 8.03E-01, 5.75E-01, 0./
data bdi/0.,
% 0.3,0.,
% 3.0, 0.5, 2.0, 0.2, 0.2, 0.,
% 3.8, 4.1, 1.4, 3.0, 0.2, 0.2, 0.,
% 2.5, 3.3, 6.0, 2.0, 3.2, 0.2, 0.2,
% 0.,
% 1.9, 0.6, 0.7, 4.3, 4.8, 1.6, 5.0,
% 0.2, 0.2, 0.,
% 0., 0., 3., 3.2, 3.2, 6.7,
% 4.4, 3.5, 10., 0.2, 0.2, 0.,
% 0., 0., 0., 0., 10., 4., 8.,
% 6.3, 6., 5., 10.5, 0.2, 0.2, 0.,
% 0., 2.5, 6.0, 0., 0., 0., 22.,
% 6.4, 13., 6.8, 6.3, 4.1, 12., 0.2,
% 0.2, 0.,
% .005, .045, .057, .087, .0769, .140, .120, .100, 1.92,
% 1.66, 1.67, 1.40, 1.31, 1.02, .245, .294, .277, 0.,
% 0.0907,.110,.0174,.132,.114,.162,.0878,.263,.0627,
% .0616,2.77,2.23,2.00,1.82,.424,.243,.185,.292,.275,
% 0.,
% 6*0.,1.3,4*0.4, 0.8, 2.7, 0.1, 1.9, 0.1,
% 26., 23., 17., 8., 11.7, 15.4, 29.,
% 0.3, 0.3, 0.,
% .469, .357, .281, .128, .0417, .0558, .0346, 0.,
% 1.90, .277, .135, .134, .192, .332, .337, .121,
% .0514, .183, 7.56, 4.55, 4.87, 2.19, 1.15, 1.23,
% .132, .289, .286, 0./
data t0/0.,
% 47.,0.,
% 11., 15., 9.1, 340., 410., 0.,
% 13., 14., 18., 11., 470., 540., 0.,
% 17., 17., 18., 22., 13., 620., 700.,
% 0.,
% 31., 29., 26., 24., 24., 29., 17.,
% 980., 1100., 0.,
% 5.1, 61., 44., 39., 34., 31.,
% 31., 36., 21., 1400., 1500., 0.,
% 11., 12., 10., 120., 55., 49.,
% 42., 38., 37., 42., 25., 1900.,
% 2000., 0.,
% 11., 12., 13., 18., 15., 190.,
% 67., 59., 55., 47., 42., 50.,
% 30., 2400., 2500., 0.,
% 32., 29., 23.9, 25.6, 25.0, 21.0, 18., 270., 83.,
% 69.5, 60.5, 66.8, 65.0, 53.0, 35.5, 3010.,3130.,0.,
% 3.46,38.5,40.8,38.2,35.3,31.9,32.2,24.7,22.9,373.,92.6,
% 79.6,69.0,67.0,47.2,56.7,42.1,3650.,3780.,0.,
% 5.8, 13., 28., 37., 49., 63.,
% 68., 77., 73., 71., 68., 61., 59.,
% 43., 35., 770., 100., 87., 62., 69.,
% 68., 67., 41., 5800., 5900., 0.,
% 9.82, 20.1, 30.5, 42.0, 55.6, 67.2, 79.3, 90.0, 100.,
% 78.1, 76.4, 74.4, 66.5, 59.7, 52.4, 49.6, 44.6, 849.,
% 136., 123., 106., 125., 123., 33.2, 64.5, 6650.,
% 6810., 0./
data t1/0.,
% 9.4,0.,
% 4.9, 23., 37., 51., 76., 0.,
% 4.8, 6.8, 38., 59., 72., 98., 0.,
% 13., 5.8, 9.1, 59., 80., 95., 130.,
% 0.,
% 15., 17., 45., 17., 35., 110., 130.,
% 140., 260., 0.,
% 0., 0., 41., 87., 100., 54.,
% 36., 160.,210.,240.,350., 0.,
% 0., 0., 0., 0., 100., 130., 170.,
% 60., 110., 250., 280., 310., 440., 0.,
% 0., 8.8, 15., 0., 0., 0.,
% 180., 200., 230., 120., 130., 340.,
% 360., 460., 550., 0.,
% 31., 55., 60., 38.1, 33., 21.5, 21.5, 330., 350.,
% 360., 380., 290., 360., 280., 110., 605., 654., 0.,
% 1.64,24.5,42.7,69.2,87.8,74.3,69.9,44.3,28.1,584.,
% 489.,462.,452.,332.,137.,441.,227.,725.,768.,0.,
% 6*0.,36.,63., 85., 89., 100., 120., 190.,
% 190., 250., 90., 630., 770., 620., 510.,
% 870., 990., 1000., 980., 1200., 0.,
% 10.1, 19.1, 23.2, 31.8, 45.5, 55.1, 52.8, 0.00, 55.0,
% 88.7, 180.,125., 189., 88.4, 129., 62.4, 159., 801.,
% 932., 945., 945., 801., 757., 264., 193., 1190.,
% 908., 0./
data gli /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,6.,1.,
* 2.,1./
data gfe /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,
* 6.,1.,10.,21.,28.,25.,6.,25.,30.,25./
data gni /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,
* 6.,1.,10.,21.,28.,25.,6.,25.,28.,21.,10.,21./
c
c parameters for calculating density dependent correction ap from Raymond
c
DATA cdd/.24E-02,.1430E-01,.9094E-03,.3500E-01,.3050E-01,
$ .9043E-02,.1077E-01,.2585E-03,.1953E-03,.8000E-01,
$ .8715E-02,.1346E-01,.4753E-02,.6304E-02,.1601E-03,
$ .1574E-03,.5600E-01,.1610E-01,.4081E-02,.7718E-02,
$ .2910E-02,.4070E-02,.1059E-03,.1306E-03,.3370E-01,
$ .1023E-01,.4726E-02,.3410E-02,.1660E-02,.3649E-02,
$ .1412E-02,.2040E-02,.5280E-04,12*0.,.9555E-04,.8100E-01,
$ .4168E-01,.2792E-01,.2585E-01,.2137E-02,.7325E-03,
$ .8059E-03,.7821E-03,.6306E-03,.1501E-02,.5546E-03,
$ .7711E-03,.1760E-04,.5965E-04,.6600E-01,.2842E-01,
$ .1740E-01,.1579E-01,.1355E-01,.1221E-01,.1272E-02,
$ .3673E-03,.4921E-03,.4976E-03,.4592E-03,.1108E-02,
$ .3973E-03,.5326E-03,.1098E-04,.4948E-04,18*0.,20*0.,9*0.,
$ .2030E-02,.2299E-02,.2313E-02,.2233E-02,.2734E-02,
$ .2934E-02,.2319E-02,.3406E-03,.5245E-04,.1246E-03,
$ .1320E-03,.1711E-03,.4206E-03,.1339E-03,.1461E-03,
$ .1015E-05,.2508E-04,28*0./
c
data dcfe/2.2e-4,2.3e-3,1.5e-2,3.8e-2,8.0e-2,9.2e-2,
& 0.16,0.18,0.14,0.1,0.225,0.24,0.26,0.19,
& 0.12,1.23,2.53e-3,5.67e-3,1.6e-2,1.85e-2,9.2e-4,
& 0.131,1.1e-2,0.256,0.43,0.,1.e-4,2.7e-3,
& 4.7e-3,1.6e-2,2.4e-2,4.1e-2,3.6e-2,0.07,0.26,
& 0.28,0.231,0.17,0.16,0.09,0.12,0.,3.36e-2,
& 7.82e-2,7.17e-2,9.53e-2,0.129,8.49e-2,4.88e-2,
& 0.452,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
& 0.,0.,0.,0.,0.,0.,0.6,0.,0.181,3.18e-2,
& 9.06e-2,7.9e-2,0.192,0.613,8.01e-2,0.,0.,0.,
& 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
& 0.,0.,0.,0.,1.92,1.26,0.739,1.23,0.912,0.,
& 0.529,0.,0.,0./
data defe/5.12,16.7,28.6,37.3,54.2,45.5,66.7,66.1,
& 21.6,22.2,59.6,75.,36.3,39.4,24.6,560.,22.5,
& 16.2,23.7,13.2,39.1,73.2,0.1,4.625e3,5.3e3,
& 0.,12.9,31.4,52.1,67.4,100.,360.,123.,129.,
& 136.,144.,362.,205.,193.,198.,248.,0.,117.,
& 96.,85.1,66.6,80.3,316.,36.2,6.e3,0.,0.,
& 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
& 0.,0.,560.,0.,341.,330.,329.,297.,392.,
& 877.,306.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
& 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,683.,
& 729.,787.,714.,919.,0.,928.,0.,0.,0./
c
data istorey/5,6,7,11,12,13,14,18,19,20,21,22,0/
data rstorey/ 0.0108,-0.1075, 0.2810,-0.0193,-0.1127,
$ 1.8267, 4.1012, 4.8443, 0.2261, 0.5960,
$ 2.3196,10.7328, 6.8830,-0.1824, 0.4101,
$ 0.0000, 0.6310, 0.1990,-0.0197, 0.4398,
$ 0.0320,-0.6624, 4.3191, 0.0003, 0.5946,
$ -0.8806,11.2406,30.7066,-1.1721, 0.6127,
$ 0.4134,-4.6319,25.9172,-2.2290,-0.2360,
$ 0.0000, 0.0238, 0.0659, 0.0349, 0.5334,
$ -0.0036, 0.7519, 1.5252,-0.0838, 0.2769,
$ 0.0000,21.8790,16.2730,-0.7020, 1.1899,
$ 0.0061, 0.2269,32.1419, 1.9939,-0.0646,
$ -2.8425, 0.2283,40.4072,-3.4956, 1.7558,
$ 5*0./
c
data uu/109.6787, 27*0.,
* 198.3108,438.9089,26*0.,
* 28*0.,
* 28*0.,
* 28*0.,
* 90.82,196.665,386.241,520.178,3162.395,3952.06,
* 22*0.,
* 117.225,238.751,382.704,624.866,789.537,4452.758,
* 5380.089,21*0.,
* 109.837,283.24,443.086,624.384,918.657,1114.008,
* 5963.135,7028.393,20*0.,
* 28*0.,
* 173.93,330.391,511.8,783.3,1018.,1273.8,1671.792,
* 1928.462,9645.005,10986.876,18*0.,
* 28*0.,
* 61.671,121.268,646.41,881.1,1139.4,1504.3,1814.3,2144.7,
* 2645.2,2964.4,14210.261,15829.951,16*0.,
* 28*0.,
* 65.748,131.838,270.139,364.093,1345.1,1653.9,1988.4,
* 2445.3,2831.9,3237.8,3839.8,4222.4,19661.693,21560.63,
* 14*0.,
* 28*0.,
* 83.558,188.2,280.9,381.541,586.2,710.184,2265.9,2647.4,
* 3057.7,3606.1,4071.4,4554.3,5255.9,5703.6,26002.663,
* 28182.535,12*0.,
* 28*0.,
* 127.11,222.848,328.6,482.4,605.1,734.04,1002.73,1157.08,
* 3407.3,3860.9,4347.,4986.6,5533.8,6095.5,6894.2,7404.4,
* 33237.173,35699.936,10*0.,
* 28*0.,
* 49.306,95.752,410.642,542.6,681.6,877.4,1026.,1187.6,
* 1520.64,1704.047,4774.,5301.,5861.,6595.,7215.,7860.,
* 8770.,9338.,41366.,44177.4,8*0.,
* 28*0.,
* 28*0.,
* 28*0.,
* 28*0.,
* 28*0.,
* 63.737,130.563,247.22,442.,605.,799.,1008.,1218.38,
* 1884.,2114.,2341.,2668.,2912.,3163.,3686.,3946.82,
* 10180.,10985.,11850.,12708.,13620.,14510.,15797.,
* 16500.,71203.,74829.,2*0.,
* 28*0.,
* 61.6,146.542,283.8,443.,613.5,870.,1070.,1310.,1560.,
* 1812.,2589.,2840.,3100.,3470.,3740.,4020.,4606.,
* 4896.2,12430.,13290.,14160.,15280.,16220.,17190.,
* 18510.,19351.,82984.,86909.4/
c data hfrac/0.75/
data hfrac/1.0/
data ergsev/1.602192e-12/
data cc1/1.e-06/
c
c Tim Kallman works with temperatures in units of 10^4 K
c
t=temp/1.e4
c
dirt=0.
ini=inid(iont,iatom)
if(ini.le.0) return
c
ekt = t*(0.861707)
xst = sqrt(t)
hconst = hfrac*ekt*ergsev
t3s2=1./(t*xst)
tmr = 1.e-6*t3s2
alogt = log10(t)
kk = 0
ist=1
j=ini
dirt = 0.
c dr for iron from Arnaud and Raymond
if ( j.lt.115 .or. j.gt.139 ) go to 2901
kk = kk + 1
do 20 n = 1,4
dirt = dirt + dcfe(kk,n)*expo(-defe(kk,n)/ekt)
20 continue
dirt = dirt*tmr
go to 101
2901 continue
c aldrovandi and Pequignot rates
c The reference is Aldrovandi, S. M. V. and P\'equignot, D. (1973)
c A&A, 25, 137
c
c ap is the density dependent correction to dr from Raymond
c
enn = xpx**(0.2)
ap = 1./(1.+cdd(j)*enn)
dirt = adi(j)*ap*cc1*expo(-t0(j)/t)
& *(1.+bdi(j)*expo(-t1(j)/t))
$ /(t*sqrt(t))
dirtemp=0.
c storey dr rates
if ((j.ne.(istorey(ist)-1)).or.(t.gt.6.).or.(ist.gt.12))
$ go to 101
dirtemp=
$ (1.e-12)*(rstorey(1,ist)/t+rstorey(2,ist)
$ +t*(rstorey(3,ist)+t*rstorey(4,ist)))*t3s2
$ *expo(-rstorey(5,ist)/t)
dirt=dirt+dirtemp
ist=ist+1
101 continue
c
c pseudo cross-section
c
if(iatom.le.20) then
gp=gli(iont+1)
if(gp.le.0) gp=1.
gg=gp/gli(iont)
else if(iatom.le.26) then
gp=gfe(iont+1)
if(gp.le.0) gp=1.
gg=gp/gfe(iont)
else if(iatom.le.28) then
gp=gni(iont+1)
if(gp.le.0) gp=1.
gg=gp/gni(iont)
end if
frq0=cons*uu(iont,iatom)
frq1=1.1*frq0
delfr=frq1-frq0
fra=0.5*(frq0+frq1)
x=1.-expo(-4.79928e-11*delfr/temp)
sig0=dirt*8.47272e24*gg*sqrt(temp)/fra**2/x
return
end
tlusty/extracted/dietot.f
+28
View File
@@ -0,0 +1,28 @@
SUBROUTINE DIETOT
C =================
C
C modification of the photoionization cross-section
C for taking into account dielectronic recombination
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
C
do ion=1,nion
i=nfirst(ion)
ia=numat(iatm(i))
io=iz(ion)
do id=1,nd
t=temp(id)
xpx=dens(id)/wmm(id)/ytot(id)
call dielrc(ia,io,t,xpx,dirt,sig0)
diesig(ion,id)=sig0
if(id.eq.1.or.id.eq.35.or.id.eq.nd) then
write(99,699) ion,ia,io,id,i,nnext(ion),dirt,sig0
end if
end do
end do
699 format(6i5,1p2e12.4)
return
end
tlusty/extracted/divstr.f
+41
View File
@@ -0,0 +1,41 @@
SUBROUTINE DIVSTR(IAH)
C ======================
C
C Auxiliary procedure for STARKA - determination of the division
C point between Doppler and asymptotic Stark profiles
C
C Input: BETAD - Doppler width in beta units
C Output: A - auxiliary parameter
C A=1.5*LOG(BETAD)-1.671
C DIV - only for A > 1; division point between Doppler
C and asymptotic Stark wing, expressed in units
C of betad.
C DIV = solution of equation
C exp(-(beta/betad)**2)/betad/sqrt(pi)=3*beta**-5/2
C
C He II: different definition of parameter ADH !
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (UNQ=1.25,UNH=1.5,TWH=2.5,FO=4.,FI=5.)
PARAMETER (CA=1.671,BL=5.821,AL=1.26,CX=0.28,DX=0.0001)
PARAMETER (CA2=0.978,XA2=0.69314718)
C
ADH=UNH*LOG(BETAD)-CA
IF(IAH.EQ.2) ADH=ADH+XA2
IF(BETAD.LT.BL) RETURN
IF(ADH.GE.AL) THEN
X=SQRT(ADH)*(UN+UNQ*LOG(ADH)/(FO*ADH-FI))
ELSE
X=SQRT(CX+ADH)
ENDIF
DO I=1,5
X2=X*X
XN=X*(UN-(X2-TWH*LOG(X)-ADH)/(TWO*X2-TWH))
IF(ABS(XN-X).LE.DX) GO TO 10
X=XN
END DO
10 DIVH=X
RETURN
END
tlusty/extracted/dmder.f
+39
View File
@@ -0,0 +1,39 @@
SUBROUTINE DMDER
C ================
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
COMMON/DEPTDR/DDM(MDEPTH),DDP(MDEPTH),DD0(MDEPTH),
* DDMIN(MDEPTH),DDPLU(MDEPTH),DDA(MDEPTH),
* DDC(MDEPTH),DDB(MDEPTH)
C
DO ID=2,ND-1
DDM(ID)=DM(ID)-DM(ID-1)
DDP(ID)=DM(ID+1)-DM(ID)
DD0(ID)=DM(ID+1)-DM(ID-1)
DDMIN(ID)=DDP(ID)/DD0(ID)
DDPLU(ID)=DDM(ID)/DD0(ID)
DDA(ID)=DDMIN(ID)/DDM(ID)
DDC(ID)=DDPLU(ID)/DDP(ID)
END DO
C
DDM(1)=0.
DDM(ND)=DM(ND)-DM(ND-1)
DDP(1)=DM(2)-DM(1)
DDP(ND)=0.
DDMIN(1)=0.
DDMIN(ND)=1.
DDPLU(1)=1.
DDPLU(ND)=0.
DDA(1)=0.
DDA(ND)=UN/DDM(ND)
DDC(1)=UN/DDP(1)
DDC(ND)=0.
DO ID=1,ND
DDB(ID)=DDA(ID)-DDC(ID)
END DO
C
RETURN
END
tlusty/extracted/dmeval.f
+69
View File
@@ -0,0 +1,69 @@
SUBROUTINE DMEVAL
C =================
C
C Auxiliary procedure for RESOLV - for disks
C recomputation of the m-scale in the case where z-scale is the
C basic scale
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ITERAT.FOR'
INCLUDE 'ARRAY1.FOR'
dimension dma(mdepth),dmb(mdepth)
C
C total pressure and gas pressure
C
DO ID=1,ND
PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID)
PGS0=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID)
PGS(ID)=PGS0
PTOTL0=PGS(ID)+PRADT(ID)+PTURB
PTOTAL(ID)=PTOTL0
END DO
c
C mass at the first depth point
C
ID=1
GRD=0.
DO IJ=1,NFREQE
IJT=IJFR(IJ)
FLUXW=W(IJT)*FH(IJT)*RADEX(IJ,ID)
GRD=GRD+FLUXW*ABSOEX(IJ,ID)
END DO
HG1=SQRT(TWO*PGS(1)/DENS(1)/QGRAV)
HR1=PCK/QGRAV*(GRD+FPRD(1))/DENS(1)
if(iter.eq.1) pgas0=pgs(1)
X=(ZD(1)-HR1)/HG1
IF(X.LT.3.) THEN
IF(X.LT.0.) X=0.
F1=8.86226925D-1*EXP(X*X)*ERFCX(X)
ELSE
F1=HALF*(UN-HALF/X/X)/X
END IF
C
DMa(1)=HG1*DENS(1)*F1
DMb(1)=DMa(1)
c
c recompute the DM scale
C
write(6,600)
600 format(/' ID ZD DM(old) DMA DMB'/)
DO ID=1,ND
if(id.gt.1) then
dmb(id)=dm(id)
DMA(ID)=DMA(ID-1)-(ZD(ID)-ZD(ID-1))*TWO/
* (UN/DENS(ID)+UN/DENS(ID-1))
DMb(ID)=DMb(ID-1)-(ZD(ID)-ZD(ID-1))*
* (DENS(ID)+DENS(ID-1))*half
end if
write(6,601) id,zd(id),dm(id),dma(id),dmb(id)
c DM(ID)=DMB(ID)
DM(ID)=DMa(ID)
601 format(i5,1p4e12.4)
END DO
DMTOT=DM(ND)
EDISC=SIG4P*TEFF**4/DMTOT
RETURN
END
tlusty/extracted/dopgam.f
+120
View File
@@ -0,0 +1,120 @@
SUBROUTINE DOPGAM(ITR,ID,T,DOP,AGAM)
C ====================================
C
C Doppler width and the Voigt damping parameter for the line ITR
C
C Input:
C ITR - index of transition
C ID - depth index
C T - temperature
C Output:
C DOP - Doppler width
C AGAM - total damping parameter (in units of Doppler widths;
C ie. = gam/4pi/DOP, where gam is the "physical" damping
C parameter expresed in circular frequencies)
C
C Damping parameter is calculated only for transitions with
C |IPROF(ITR)| = 1 (ie. those for which either Voigt or some non-
C standard profile is assumed)
C Determination of AGAM:
C is controlled by input parameters transmitted by COMMON/VOIPAR:
C
C GAMAR(IP) - for > 0 - has the meaning of natural damping
C parameter (=Einstein coefficient for
C spontaneous emission)
C = 0 - classical natural damping assumed
C < 0 - damping is given by a non-standard,
C user supplied procedure GAMSP
C STARK1(IP) - = 0 - Stark broadening neglected
C < 0 - scaled classical expression
C (ie gam = -STARK1 * classical Stark)
C > 0 - Stark broadening given by
C n(el)*[STARK1*T**STARK2 + STARK3]
C STRAK2, STARK3 - see above
C VDWH(IP) - .le.0 - Van der Waals broadening neglected
C > 0 - scaled classical expression
C
C the corresponding index IP is given by ITRA(IUP(ITR),ILOW(ITR))
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (BOL2=2.76108D-16, CIN=UN/2.997925D10)
PARAMETER (R02=2.5,R12=45.,OP4=0.4,VW0=4.5E-9)
C
J=IUP(ITR)
IAT=IATM(J)
FR=FR0(ITR)
IE=IEL(J)
AM=BOL2/AMASS(IAT)*T
AGAM=0.
C
C Doppler width
C
DOP=FR*CIN*SQRT(AM+VTURBS(ID)*VTURBS(ID))
C
C -----------------
C damping parameter - only for IPROF = 1
C
IF(IABS(IPROF(ITR)).NE.1) RETURN
IP=ITRA(J,ILOW(ITR))
ANE=ELEC(ID)
C
C Natural (radiation) broadening
C
If(GAMAR(IP).GT.0.) THEN
AGAM=GAMAR(IP)
ELSE IF (GAMAR(IP).EQ.0.) THEN
AGAM=2.47342D-22*FR*FR
ELSE
C
C Non-standard expression - for the total damping parameter,
C not only for radiation damping
C
CALL GAMSP(ITR,T,ANE,AGAM)
END IF
C
C Stark broadening
C
Z=FLOAT(IZ(IE))
ANFF=Z*Z*EH/ENION(J)
IF(STARK1(IP).EQ.0.) THEN
AGAM=AGAM+1.D-8*ANFF**2.5*ANE
ELSE IF (STARK1(IP).GT.0.) THEN
AGAM=AGAM+ANE*(STARK1(IP)*T**STARK2(IP)+STARK3(IP))
END IF
C
C Van der Waals broadening
C
IF(IELH.GT.0) THEN
AH=POPUL(NFIRST(IELH),ID)
ELSE
AH=DENS(ID)/WMM(ID)/YTOT(ID)
END IF
IF(IELHE1.NE.0) THEN
AHE=AH*ABUND(IATHE,ID)
ELSE
AHE=AH*ABNDD(2,ID)
END IF
VDWC=(T*1.E-4)**0.3*(AH+0.42*AHE)
IF(VDWH(IP).GE.0.) THEN
IF(IAT.LT.21) THEN
R2=R02*(ANFF/Z)**2
ELSE IF(IAT.LT.45) then
R2=(R12-FLOAT(IAT))/Z
ELSE
R2=0.5
END IF
GW0=VDWC*VW0*R2**OP4
AGAM=AGAM+GW0
ELSE IF (VDWH(IP).LT.0.) THEN
GW0=VDWC*EXP(2.3025851*VDWH(IP))
AGAM=AGAM+GW0
END IF
c
C Total damping parameter in units of Doppler widths
C
AGAM=AGAM/DOP/12.566370614
RETURN
END
tlusty/extracted/dwnfr.f
+44
View File
@@ -0,0 +1,44 @@
SUBROUTINE DWNFR(MODE,N,FRE,A,ANE,Z,FR,DW)
C ==========================================
C
C Auxiliary routine to compute set of dissolved fractions
C for all frequencies
C MODE=0 -> DW=1
C MODE>0 -> DW=1-w
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.)
parameter (tkn=3.01,ckn=5.33333333,cb0=8.59d14,f23=-2./3.)
PARAMETER (FRH=3.28805D15,SQFRH=5.734152D7)
DIMENSION FR(N),DW(N)
C
cb=cb0*berfc
IF(MODE.EQ.0) THEN
DO IJ=1,N
DW(IJ)=UN
END DO
ELSE
DO IJ=1,N
IF(FR(IJ).LT.FRE) THEN
XN=SQFRH*Z/SQRT(FRE-FR(IJ))
if(xn.le.tkn) then
xkn=un
else
xn1=un/(xn+un)
xkn=ckn*xn*xn1*xn1
end if
beta=cb*z*z*z*xkn/(xn*xn*xn*xn)*exp(f23*log(ane))
x=exp(p4*log(un+p3*a))
c1=p1*(x+p5*(z-un)*a*a*a)
c2=p2*x
f=(c1*beta*beta*beta)/(un+c2*beta*sqrt(beta))
DW(IJ)=UN-f/(un+f)
ELSE
DW(IJ)=UN
END IF
END DO
END IF
RETURN
END
tlusty/extracted/dwnfr0.f
+25
View File
@@ -0,0 +1,25 @@
SUBROUTINE DWNFR0(ID)
C =====================
C
C Auxiliary quantities for dissolved fractions
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (SIXTH=UN/6.,CCOR=0.09)
parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.)
parameter (f23=-2./3.)
C
ANE=ELEC(ID)
ELEC23(ID)=EXP(F23*LOG(ANE))
ANES=EXP(SIXTH*LOG(ANE))
ACOR(ID)=CCOR*ANES/SQT1(ID)
X=EXP(P4*LOG(UN+P3*ACOR(ID)))
DWC2(ID)=P2*X
A3=ACOR(ID)*ACOR(ID)*ACOR(ID)
DO IZZ=1,MZZ
Z3(IZZ)=IZZ*IZZ*IZZ
DWC1(IZZ,ID)=P1*(X+P5*(IZZ-UN)*A3)
END DO
RETURN
END
tlusty/extracted/dwnfr1.f
+31
View File
@@ -0,0 +1,31 @@
SUBROUTINE DWNFR1(FR,FR0,ID,IZZ,DW1)
C ====================================
C
C dissolved fraction for frequency FR
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
PARAMETER (TKN=3.01,CKN=5.33333333,CB0=8.59d14)
PARAMETER (SQFRH=5.734152D7)
C
cb=cb0*bergfc
c
IF(FR.LT.FR0) THEN
XN=SQFRH*IZZ/SQRT(FR0-FR)
if(xn.le.tkn) then
xkn=un
else
xn1=un/(xn+un)
xkn=ckn*xn*xn1*xn1
end if
BETA=CB*Z3(IZZ)*XKN/(XN*XN*XN*XN)*ELEC23(ID)
BETA3=BETA*BETA*BETA
BETA32=SQRT(BETA3)
F=(DWC1(IZZ,ID)*BETA3)/(UN+DWC2(ID)*BETA32)
DW1=UN-F/(UN+F)
ELSE
DW1=UN
END IF
RETURN
END
tlusty/extracted/eint.f
+18
View File
@@ -0,0 +1,18 @@
subroutine eint(t,e1,e2,e3)
c ============================
c
c returns the values of the exponential integral function of order
c 1, 2, and 3
c
c a modification of Tim Kallman's XSTAR routine
c
INCLUDE 'IMPLIC.FOR'
e1=0.
e2=0.
e3=0.
call expinx(t,ss)
e1=ss/t/expo(t)
e2=exp(-t)-t*e1
e3=0.5*(expo(-t)-t*e2)
return
end
tlusty/extracted/elcor.f
+93
View File
@@ -0,0 +1,93 @@
SUBROUTINE ELCOR(ID)
C ====================
C
C Procedure for a reevaluation of the electron number density
C from the charge conservation equation in the formal solution
C step (RESOLV)
C This procedure is called only if LCHC=false, ie. if the charge
C conservation equation is not part of the rate matrix
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
COMMON/ADCHAR/QADD(MDEPTH)
c
if(ioptab.lt.0.or.ioptab.gt.0) return
C
T=TEMP(ID)
ANE=ELEC(ID)
AN0=DENS(ID)/WMM(ID)+ANE
C
C basic iteration loop for solving simultaneously a non-linear set
C of statistical equilibrium, charge conservation, and particle
C conservation equations
C
KKK=0
1 KKK=KKK+1
IF(IFIXDE.GT.0) THEN
AN=DENS(ID)/WMM(ID)+ANE
ELSE
AN=AN0
DENS(ID)=(AN-ANE)*WMM(ID)
END IF
C
C determine QQ, the total charge due to non-explicit atoms
C
QQ=0.
ANMNE1=WMM(ID)/DENS(ID)
if(ifmol.eq.0.or.t.ge.tmolim) then
CALL STATE(2,ID,T,ANE)
QQ=Q*ABUND(IATREF,ID)/YTOT(ID)*DENS(ID)/WMM(ID)
if(ioptab.gt.0) QQ=DENS(ID)/YTOT(ID)/WMM(ID)
else
aein=ane
call moleq(id,t,an,aein,ane,enrg,entt,wm,0)
qq=qadd(id)
end if
C
RHS=QFIX(ID)+QQ
DO IAT=1,NATOM
IF(IIFIX(IAT).NE.1) THEN
DO I=N0A(IAT),NKA(IAT)
IL=ILK(I)
CH=IZ(IEL(I))-1
IF(IL.GT.0) CH=IZ(IL)+(IZ(IL)-1)*USUM(IL)*ANE
IF(IMODL(I).GE.0) RHS=RHS+CH*POPUL(I,ID)
END DO
END IF
END DO
C
C new electron density
C
RHS=HALF*(ANE+RHS)
ELEC(ID)=RHS
IF(IFIXDE.EQ.0) DENS(ID)=WMM(ID)*(AN-ELEC(ID))
ANMA(ID)=DENS(ID)/WMM(ID)
ANTO(ID)=ANMA(ID)+ELEC(ID)
RELANE=(RHS-ANE)/ANE
ANE=RHS
C
C second part of the iteration loop - recalculation of all
C populations with new electron density
C
CALL STEQEQ(ID,POP,1)
C
C convergence criterion for electron density
C
IF(ABS(RELANE).LE.1.D-6) THEN
CALL WNSTOR(ID)
RETURN
ENDIF
C
C if convergence is not achieved
C
IF(KKK.LT.10) GO TO 1
WRITE(6,601) ID,RELANE
WRITE(10,601) ID,RELANE
601 FORMAT('0 SLOW CONVERGENCE OF ELCOR ID =',I4,' REL =',1PD10.3/)
CALL WNSTOR(ID)
RETURN
END
tlusty/extracted/eldenc.f
+150
View File
@@ -0,0 +1,150 @@
subroutine eldenc
C =================
C
C compare the actual electon density to that which follows
C from the values used in the opacity table, interpolated to
C the actual temperature and mass density
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ATOMIC.FOR'
common/eletab/elecgr(mtabt,mtabr)
common/eospar/anmol(600,mdepth),
* anato(100,mdepth),
* anion(100,mdepth)
common/hmolab/anh2(mdepth),anhm(mdepth)
dimension elcon(31,mdepth)
c
if(ipelch.gt.0) then
write(6,600)
600 format(/' -------------------------'/
* ' CHECK OF ELECTRON DENSITY'/
* ' -------------------------'/
* ' ID TEMP ACTUAL LTE EOS interpol.op.tab.'/)
c
do id=1,nd
t=temp(id)
rho=dens(id)
if(numtemp.eq.nd) then
opac=elecgr(id,1)
go to 10
end if
c
TTAB1=TEMPVEC(1)
TTAB2=TEMPVEC(NUMTEMP)
TL=LOG(T)
DELTAT=(TL-TTAB1)/(TTAB2-TTAB1)*FLOAT(numtemp-1)
JT = 1 + IDINT(DELTAT)
IF(JT.LT.1) JT = 1
IF(JT.GT.numtemp-1) JT = numtemp-1
ju = jt+1
t1i=tempvec(jt)
t2i=tempvec(jt+1)
dti=(TL-T1i)/(T2i-T1i)
if(deltat.lt.0.) dti = 0.d0
C
if(numrh(1).ne.1) then
c
c lower temperature
c
numrho=numrh(jt)
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=elecgr(jt,jr)+
* dri*(elecgr(jt,jr+1)-elecgr(jt,jr))
c
c higher temperature
c
ju=jt+1
numrho=numrh(ju)
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=elecgr(ju,jr)+
* dri*(elecgr(ju,jr+1)-elecgr(ju,jr))
opac=opr1+(opr2-opr1)*dti
else
jr=1
opac=elecgr(jt,jr)+(elecgr(ju,jr)-elecgr(jt,jr))*dti
end if
10 continue
elecg=exp(opac)
call rhonen(id,t,rho,an,ane)
write(6,601) id,t,elec(id),ane,elecg
601 format(i4,f10.1,1p3e12.4)
end do
end if
c
c electron donors
c
if(idisk.eq.0.or.ipeldo.eq.0) return
do id=1,nd
t=temp(id)
if(ifmol.gt.0.and.t.lt.tmolim) then
rho=dens(id)
call rhonen(id,t,rho,an,ane)
aein=ane
call moleq(id,t,an,aein,ane,enrg,entt,wm,1)
do ia=1,30
elcon(ia,id)=anion(ia,id)/elec(id)
end do
elcon(31,id)=-anhm(id)/elec(id)
else
call state(2,id,t,elec(id))
do ia=1,30
iat=iatex(ia)
if(iat.gt.0) then
qs=0.
n1=n0a(iat)
if(ia.eq.1) n1=nfirst(ielh)
do i=n1,nka(iat)
ch=iz(iel(i))-1
if(ilk(i).gt.0) ch=iz(ilk(i))
qs=qs+ch*popul(i,id)
end do
elcon(ia,id)=qs/elec(id)
else
elcon(ia,id)=rr(ia,99)/elec(id)
end if
end do
if(ielhm.gt.0) then
elcon(31,id)=-popul(nfirst(ielhm),id)/elec(id)
else
aref=dens(id)/wmm(id)/ytot(id)
elcon(31,id)=-qm*rr(1,1)*aref
end if
end if
end do
c
write(6,611)
do id=1,nd
write(6,612) id,temp(id),elcon(31,id),elcon(1,id),elcon(2,id),
* elcon(6,id),elcon(7,id),elcon(8,id),
* (elcon(i,id),i=11,15),elcon(20,id),elcon(26,id)
end do
611 format(/' RELATIVE CONTRIBUTIONS OF INDIVIDUAL ELECTRON DONORS'//
* ' ID TEMP H- H He C N O',
* ' Na Mg Al',
* ' Si S Ca Fe')
612 format(i3,f9.1,1pe10.2,0p12f7.3)
c
return
end
tlusty/extracted/eldens.f
+259
View File
@@ -0,0 +1,259 @@
SUBROUTINE ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,IPRI)
C ===============================================
C
C Evaluation of the electron density and the total hydrogen
C number density for a given total particle number density
C and temperature;
C by solving the set of Saha equations, charge conservation and
C particle conservation equations (by a Newton-Raphson method)
C
C Input parameters:
C T - temperature
C AN - total particle number density
C
C Output:
C ANE - electron density
C ANP - proton number density
C AHTOT - total hydrogen number density
C AHMOL - relativer number of hydrogen molecules with respect to the
C total number of hydrogens
C ENERG - part of the internal energy: excitation and ionization
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ATOMIC.FOR'
DIMENSION R(3,3),S(3),P(3)
common/terden/rhoter,anta,entrp
common/eospar/anmol(600,mdepth),
* anato(100,mdepth),
* anion(100,mdepth)
c
if(ioptab.lt.-1) return
C
if(anerel.le.0.) then
anerel=0.5
if(t.lt.9000.) anerel=0.4
if(t.lt.8000.) anerel=0.1
if(t.lt.7000.) anerel=0.01
if(t.lt.6000.) anerel=0.001
if(t.lt.5500.) anerel=0.0001
if(t.lt.5000.) anerel=1.e-5
if(t.lt.4000.) anerel=1.e-6
end if
c
if(ifmol.gt.0.and.t.lt.tmolim) then
aein=an*anerel
call moleq(id,t,an,aein,ane,enrg,entt,wm,ipri)
anerel=ane/an
return
end if
c
QMI=0.
Q2=0.
QP=0.
Q=0.
DQN=0.
TK=BOLK*T
THET=5.0404D3/T
anta=an
C
C Coefficients entering ionization (dissociation) balance of:
C atomic hydrogen - QH;
C negative hydrogen ion - QM (considered only if IHM>0);
C hydrogen molecule - QP (considered only if IH2>0);
C ion of hydrogen molecule - Q2 (considered only if IH2P>0).
C
IF(T.LE.9000.) THEN
QMI=1.0353D-16/T/SQRT(T)*EXP(8762.9/T)
QP=TK*EXP((-11.206998+THET*(2.7942767+THET*
* (0.079196803-0.024790744*THET)))*2.30258509299405)
call mpartf(1,1,0,t,uh,duh)
uh=max(uh,two)
call mpartf(0,0,2,t,uh2,duh2)
q2=1.47e-20/(t*sqrt(t))*uh2/uh/uh*exp(51951.8/t)
END IF
tkln15=log(bolk*t)*1.5
QH0=EXP((15.38287+1.5*LOG10(T)-13.595*THET)*2.30258509299405)*two
C
ANE=AN*ANEREL
IT=0
C
C Basic Newton-Raphson loop - solution of the non-linear set
C for the unknown vector P, consistiong of AH, ANH (neutral
C hydrogen number density) and ANE.
C
10 IT=IT+1
C
C procedure STATE determines Q (and DQN) - the total charge (and its
C derivative wrt temperature) due to ionization of all atoms which
C are considered (both explicit and non-explicit), by solving the set
C of Saha equations for the current values of T and ANE
C
CALL STATE(1,ID,T,ANE)
C
C Auxiliary parameters for evaluating the elements of matrix of
C linearized equations.
C Note that complexity of the matrix depends on whether the hydrogen
C molecule is taken into account
C Treatment of hydrogen ionization-dissociation is based on
C Mihalas, in Methods in Comput. Phys. 7, p.10 (1967)
C
IF(IATREF.EQ.IATH.or.ioptab.ge.-1) THEN
qh=qh0/pfhyd
G2=QH/ANE
G3=0.
G4=0.
G5=0.
D=0.
E=0.
G3=QMI*ANE
A=UN+G2+G3
D=G2-G3
IF(IT.GT.1) GO TO 60
IF(T.GT.9000.) THEN
F1=UN/A
FE=D/A+Q
AH=ANE/FE
ANH=AH*F1
else if(t.gt.4000.) then
E=G2*QP/Q2
B=TWO*(UN+E)
GG=ANE*Q2
C1=B*(GG*B+A*D)-E*A*A
C2=A*(TWO*E+B*Q)-D*B
C3=-E-B*Q
F1=(SQRT(C2*C2-4.*C1*C3)-C2)*HALF/C1
FE=F1*D+E*(UN-A*F1)/B+Q
AH=ANE/FE
ANH=AH*F1
else
c1=q2*(two*ytot(id)-un)
c2=ytot(id)
c3=-an
anh=(sqrt(c2*c2-4.*c1*c3)-c2)*half/c1
ah=anh*(un+two*anh*q2)
c1=un+qmi*anh
c2=-q*ah
c3=-qh*anh
ane=(sqrt(c2*c2-4.*c1*c3)-c2)*half/c1
end if
60 AE=ANH/ANE
GG=AE*QP
E=ANH*Q2
B=ANH*QMI
C
C Matrix of the linearized system R, and the rhs vector S
C
if(ifmol.eq.0.or.t.ge.tmolim) then
R(1,1)=YTOT(ID)
R(1,2)=0.
R(1,3)=UN
S(1)=AN-ANE-YTOT(ID)*AH
else
R(1,1)=YTOT(ID)-UN
R(1,2)=A+E+GG
R(1,3)=UN
S(1)=AN-ANE-ANH*(A+E+GG)-(YTOT(ID)-UN)*AH
end if
c
R(2,1)=-Q
R(2,2)=-D-TWO*GG
R(2,3)=UN+B+AE*(G2+GG)-DQN*AH
R(3,1)=-UN
R(3,2)=A+4.*(E+GG)
R(3,3)=B-AE*(G2+TWO*GG)
S(2)=ANH*(D+GG)+Q*AH-ANE
S(3)=AH-ANH*(A+TWO*(E+GG))
C
C Solution of the linearized equations for the correction vector P
C
CALL LINEQS(R,S,P,3,3)
C
C New values of AH, ANH, and ANE
C
AH=AH+P(1)
ANH=ANH+P(2)
DELNE=P(3)
ANE=ANE+DELNE
C
C hydrogen is not the reference atom
C
ELSE
C
C Matrix of the linearized system R, and the rhs vector S
C
IF(IT.EQ.1) THEN
ANE=AN*HALF
AH=ANE/YTOT(ID)
END IF
R(1,1)=YTOT(ID)
R(1,2)=UN
R(2,1)=-Q-QREF
R(2,2)=UN-(DQN+DQNR)*AH
S(1)=AN-ANE-YTOT(ID)*AH
S(2)=(Q+QREF)*AH-ANE
C
C Solution of the linearized equations for the correction vector P
C
CALL LINEQS(R,S,P,2,3)
AH=AH+P(1)
DELNE=P(2)
ANE=ANE+DELNE
END IF
C
C Convergence criterion
C
IF(ANE.LE.0.) ANE=1.D-6*AN
IF(ABS(DELNE/ANE).GT.1.D-3.AND.IT.LE.10) GO TO 10
C
C ANEREL is the exact ratio betwen electron density and total
C particle density, which is going to be used in the subseguent
C call of ELDENS
C
ANEREL=ANE/AN
AHTOT=AH
AHMOL=ANH*ANH*Q2
ANP=ANH/ANE*QH
ANHM=ANH*ANE*QMI
RHOTER=WMY(ID)*AH*HMASS
if(ipri.gt.0) then
dens(id)=rhoter
elec(id)=ane
wmm(id)=dens(id)/(an-ane)
end if
C
c internal energy and entropy
c
call entene(t,ah,anh,anp,ane,energ,entrop)
ener=energ
entr=entrop
c if(id.eq.1) write(6,602) id,t,an,ener,entr
c
c energy and entropy of H_2
c
if(t.lt.9000..and.ahmol.gt.0..and.uh2.gt.0.) then
ener=ener+(duh2-51951.8/t)*tk*ahmol
entr=entr+ahmol*(tkln15-log(ahmol)+log(uh2)+1.0487+
* 103.973)*bolk
end if
C
enrg=ener
entt=entr
wm=rhoter/an/hmass
c
if(ifmol.le.0.or.t.ge.tmolim) then
if(n0hn.gt.0) then
anato(1,id)=popul(n0hn,id)
else
anato(1,id)=dens(id)/wmm(id)/ytot(id)
end if
if(iathe.gt.0) then
anato(2,id)=popul(n0a(iathe),id)
else
anato(2,id)=dens(id)/wmm(id)/ytot(id)*abndd(2,id)
end if
end if
c
RETURN
END
tlusty/extracted/emat.f
+39
View File
@@ -0,0 +1,39 @@
SUBROUTINE EMAT(ID)
C ===================
C
C Auxiliary procedure for SOLVE
C
C sub-sub-diagonal band matrix E
C
C Input: ID - depth index
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ARRAY1.FOR'
INCLUDE 'ALIPAR.FOR'
C
IF(IFALI.LE.7) RETURN
IF(ID.LE.2) RETURN
NSE=NFREQE+INSE-1
IF(INHE.GT.0) THEN
NHE=NFREQE+INHE
IF(INRE.GT.0) E(NHE,NFREQE+INRE)=EHET(ID)*PCK
IF(INPC.GT.0) E(NHE,NFREQE+INPC)=EHEN(ID)*PCK
DO II=1,NLVEXP
E(NHE,NSE+II)=EHEP(II,ID)*PCK
END DO
END IF
C
IF(INRE.GT.0.AND.REDIF(ID).GT.0.) THEN
NRE=NFREQE+INRE
IF(INRE.GT.0) E(NRE,NRE)=ERET(ID)*REDIF(ID)
IF(INPC.GT.0) E(NRE,NFREQE+INPC)=EREN(ID)*REDIF(ID)
DO II=1,NLVEXP
E(NRE,NSE+II)=EREP(II,ID)*REDIF(ID)
END DO
END IF
RETURN
END
tlusty/extracted/entene.f
+59
View File
@@ -0,0 +1,59 @@
subroutine entene(t,ah,anh,anpr,ane,energ,entrop)
c =================================================
c
c internal energy and entropy of atoms and ions
c
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
parameter (ev2erg=1.6018d-12,
* entcon=103.973)
c
tk=bolk*t
tkk=tk*t
tkln15=1.5*log(tk)
natoms=30
energ=0.
entrop=0.
c
c hydrogen
c
call mpartf(1,1,0,t,u,dulog)
if(u.lt.2.) u=2.
if(dulog.lt.0.) dulog=0.
alm=1.5*log(amas(1))
energ=tk*dulog*anh
entrop=(tkln15-log(anh)+log(u)+alm+tkk*dulog+entcon)*anh
energ=energ+enev(1,1)*ev2erg*anpr
entrop=entrop+(tkln15-log(anpr)+alm+entcon)*anpr
c
c other species
c
xmax=2.154e4*sqrt(sqrt(t/ane))
do i=2,natoms
chip=0
do j=1,2
if(rr(i,j).gt.1.e-15) then
aden=rr(i,j)*ah
if(aden.lt.1.e-20) aden=1.e-20
call mpartf(i,j,0,t,u,dulog)
if(u.lt.un) u=un
if(dulog.lt.0.) dulog=0.
energ=energ+(chip*ev2erg+tk*dulog)*aden
entrop=entrop+(tkln15-log(aden)+log(u)+
* 1.5*log(amas(i))+tkk*dulog+entcon)*aden
end if
chip=chip+enev(i,j)
end do
end do
c
c entropy of electrons
c
c entel=tkln15-log(ane)+1.5*log(emass(99))+entcon
entel=tkln15-log(ane)-11.2622+entcon
entrop=entrop+entel*ane
entrop=entrop*bolk
C
return
end

Some files were not shown because too many files have changed in this diff Show More