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
synspec/extracted/LINDAT.FOR
+87
View File
@@ -0,0 +1,87 @@
PARAMETER (MLIN0 =1200000,
* MGRIEM = 10,
* MNLT = 2000,
* MSPHE2 = 20,
* MLIN = 190000,
* MPRF = MLIN0)
C
PARAMETER (MLINM0 =9000000,
* MLINM =1000000,
* MMLIST = 3)
C
REAL*4 EXCL0(MLIN0),
* EXCU0(MLIN0),
* GF0(MLIN0),
* EXTIN(MLIN0),
* BNUL(MLIN0),
* GAMR0(MPRF),
* GS0(MPRF),
* GW0(MPRF),
* WGR0(4,MGRIEM),
* EXCLM(MLINM0,MMLIST),
* GFM(MLINM0,MMLIST),
* EXTINM(MLINM0,MMLIST),
* GRM(MLINM0,MMLIST),
* GSM(MLINM0,MMLIST),
* GWM(MLINM0,MMLIST),
* GVDWH2(MLINM0,MMLIST),
* GEXPH2(MLINM0,MMLIST),
* GVDWHE(MLINM0,MMLIST),
* GEXPHE(MLINM0,MMLIST)
C
COMMON/LINTOT/FREQ0(MLIN0),
* EXCL0,
* EXCU0,
* GF0,
* EXTIN,
* BNUL,
* INDAT(MLIN0),
* INDNLT(MLIN0),
* ILOWN(MLIN0),
* IUPN(MLIN0),
* IJCONT(MLIN0),
* INDLIN(MLIN),
* INDLIP(MLIN),
* NLIN0,NLIN,IRLIST,
* NNLT,NGRIEM
C
COMMON/MOLTOT/FREQM(MLINM0,MMLIST),
* EXCLM,
* GFM,
* EXTINM,
* GRM,GSM,GWM,
* GVDWH2,GEXPH2,GVDWHE,GEXPHE,
* INDATM(MLINM0,MMLIST),
* INMLIN(MLINM,MMLIST),
* INMLIP(MLINM,MMLIST),
* NLINM0(MMLIST),
* NLINML(MMLIST),
* NLINMT(MMLIST),
* IUNITM(MMLIST),
* INACTM(MMLIST),
* IVDWLI(MMLIST),
* NMLIST
CHARACTER*40 AMLIST(0:MMLIST)
COMMON/LISPAR/AMLIST,
* IBIN(0:MMLIST)
C
COMMON/LINPRF/GAMR0,
* GS0,
* GW0,
* WGR0,
* IPRF0(MPRF),
* ISPRF(MPRF),
* IGRIEM(MPRF),
* ISP0(MSPHE2),NSP
C
COMMON/LINNLT/ABCENT(MNLT,MDEPTH),
* SLIN(MNLT,MDEPTH)
C
COMMON/LINDEP/PLAN(MDEPTH),
* STIM(MDEPTH),
* EXHK(MDEPTH)
C
COMMON/LINCTR/DFRCON,IJCNTR(MLIN),IJCMTR(MLINM,MMLIST)
COMMON/MLINRE/FRLASM(MMLIST),ALASTM(MMLIST),TMLIM(MMLIST),
* NXTSEM(MMLIST),IPRSEM(MMLIST),IREADM(MMLIST)
synspec/extracted/MODELP.FOR
+65
View File
@@ -0,0 +1,65 @@
C
C Basic parameters of the model atmosphere
C
COMMON/MODELP/DM(MDEPTH),
* TEMP(MDEPTH),
* ELEC(MDEPTH),
* DENS(MDEPTH),
* ZD(MDEPTH),
* VTURB(MDEPTH),VTB,
* ABSTD(MDEPTH),
* ABSTDW(MFREQC,MDEPTH),
* POPUL(MLEVEL,MDEPTH),
* POPREL(MLEVEL,MDEPTH),
* DMR0(MDEPTH),
* DMRP(MDEPTH),
* SBF(MLEVEL),
* USUM(MIOEX),
* WOP(MLEVEL,MDEPTH),
* WNHINT(NLMX,MDEPTH),
* WNHE2(NLMX,MDEPTH),
* RRR(MDEPTH,MION,MATOM),
* JT(MDEPTH),
* TI0(MDEPTH),
* TI1(MDEPTH),
* TI2(MDEPTH)
character*8 cmol(mmolec)
COMMON/MOLPAR/RRMOL(MMOLEC,MDEPTH),
* DOPMOL(MMOLEC,MDEPTH),
* AMMOL(MMOLEC),
* CMOL,
* anh2(mdepth),anch(mdepth),anoh(mdepth),
* anhm(mdepth)
C
COMMON/OPACAT/OPATM(MATOM,MFREQ,MDEPTH),
* EMATM(MATOM,MFREQ,MDEPTH),
* OPATML(MATOM,MFREQ),
* GRADAT(MATOM,MDEPTH),
* GRADFA(MATOM,MDEPTH),
* POPAT(MATOM,MDEPTH),
* DGRAD0(MATOM,MATOM,MDEPTH),
* DGRADP(MATOM,MATOM,MDEPTH)
C
COMMON/RADFLD/RAD(MFREQ,MDEPTH),
c * FAK(MFREQ,MDEPTH),
c * ALI(MFREQ,MDEPTH),
c * FLXH(MFREQ,MDEPTH),
* RAD0(MFREQ,MDEPTH),
* FLX0(MFREQ,MDEPTH),
* flxt(mdepth),
* flxi(mdepth)
C
COMMON/XENPRF/PRFXB(MLINH,MHWL,MHT,MHE),
* PRFXR(MLINH,MHWL,MHT,MHE),
* PRFB(MLINH,MDEPTH,MHWL),
* PRFR(MLINH,MDEPTH,MHWL),
* ALXEN(MLINH,MHWL),
* XTXEN(MHT,MLINH),
* XNEXEN(MHE,MLINH),XNEMIN,
* NWLXEN(MLINH),
* NTHXEN(MLINH),
* NEHXEN(MLINH),
* ILXEN(4,22),
* IHXENB
C
synspec/extracted/Makefile
+52
View File
@@ -0,0 +1,52 @@
# Makefile for SYNSPEC extracted modules
# 使用大内存模型支持大型 COMMON 数组
FC = gfortran
FFLAGS = -O3 -fno-automatic -mcmodel=large
# 编译输出目录
BUILD_DIR = build
# 目标可执行文件
MAIN = $(BUILD_DIR)/synspec_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
synspec/extracted/OPTPAR.FOR
+4
View File
@@ -0,0 +1,4 @@
PARAMETER (MFRTAB = 100000,
* MTTAB = 20,
* MRTAB = 20,
* MSFTAB = 2000000.
synspec/extracted/PARAMS.FOR
+223
View File
@@ -0,0 +1,223 @@
C
C Parameters that specify dimensions of arrays
C
IMPLICIT REAL*8 (A-H, O-Z),LOGICAL*1 (L)
character*4 typat
PARAMETER (MATEX = 30,
* MIOEX = 90,
* MLEVEL= 1650,
* MDEPTH= 100,
* MDEPF = 500,
* MFREQ = 2000,
c * MFREQ = 120,
* MFREQC= 2000,
* MFRQ = 2000,
* MOPAC = MFRQ,
* MMU = 20,
* MCROSS= MLEVEL,
* MFIT = 1650,
* MFCRA = 1200,
* MTRAD = 3,
* MATOM = 99,
* MATOMBIG = 99,
* MION = 90,
* MION0 = 9,
* MMOLEC=500,
* MPHOT = 10,
* MZZ = 2,
* MMER = 2,
* NLMX = 80,
* MI1 = MION0-1,
* MLINH = 78,
* MHT = 7,
* MHE = 20,
* MHWL = 55)
PARAMETER (MFGRID = 100000,
* MTTAB = 21,
* MRTAB = 20,
* MSFTAB = 6000000)
parameter (mfhtab=1000,
* mtabth=10,
* mtabeh=10)
c
C Basic physical constants
C
PARAMETER (H = 6.6256D-27,
* CL = 2.997925D10,
* BOLK = 1.38054D-16,
* HK = 4.79928144D-11,
* EH = 2.17853041D-11,
* BN = 1.4743D-2,
* SIGE = 6.6516D-25,
* PI4H = 1.8966D27,
* HMASS = 1.67333D-24)
C
C Unit number
C
PARAMETER (IBUFF=95)
C
C Variables to hold quantum numbers limits
C (see LEVLIMITS below)
C
INTEGER*4 SQUANT1(MLEVEL),SQUANT2(MLEVEL),
* LQUANT1(MLEVEL),LQUANT2(MLEVEL),
* PQUANT1(MLEVEL),PQUANT2(MLEVEL)
C
C Basic parameters
C
COMMON/BASNUM/NATOM,
* NION,
* NLEVEL,
* ND,NDSTEP,
* NFREQ,NFROBS,NFREQC,NFREQS,
* NMU
COMMON/LTESET/LTE,LTEGR
COMMON/INPPAR/TEFF,
* GRAV,
* YTOT(MDEPTH),
* WMM(MDEPTH),
* WMY(MDEPTH),
* vaclim,
* ATTOT(MATOM,MDEPTH)
COMMON/BASICM/IMODE,
* IMODE0,
* IFREQ,
* INLTE,
* IDSTD,
* IFWIN,
* IFEOS,
* IBFAC
COMMON/INTKEY/INMOD,INTRPL,ICHANG,ICHEMC,IATREF,ICONTL
COMMON/LBLANK/IBLANK,NBLANK
COMMON/NXTINI/ALM00,ALST00,NXTSET,INLIST,ALAMBE,DLAMLO
COMMON/IPRNTR/IPRIN
C
C Parameters for explicit atoms
C
COMMON/ATOPAR/AMASS(MATEX),
* ABUND(MATEX,MDEPTH),
* RELAB(MATEX,MDEPTH),
* NUMAT(MATEX),
* N0A(MATEX),
* NKA(MATEX),
* SABND(MATEX)
C
C Parameters for explicit ions
C
COMMON/IONPAR/FF(MIOEX),
* NFIRST(MIOEX),
* NLAST(MIOEX),
* NNEXT(MIOEX),
* IUPSUM(MIOEX),
* IZ(MIOEX),
* IFREE(MIOEX),
* INBFCS(MIOEX),
* ILIMITS(MIOEX)
C
C Parameters for explicit levels
C
COMMON/LEVPAR/ENION(MLEVEL),
* G(MLEVEL),
* NQUANT(MLEVEL),
* IATM(MLEVEL),
* IEL(MLEVEL),
* ILK(MLEVEL),
* ifwop(mlevel),
* isemex(matom)
C
C Limits for explicit levels
C
COMMON/LEVLIMITS/ENION1(MLEVEL),
* ENION2(MLEVEL),
* SQUANT1,
* SQUANT2,
* LQUANT1,
* LQUANT2,
* PQUANT1,
* PQUANT2
C
C Parameters for all considered transitions
C
COMMON/TRAPAR/IBF(MLEVEL),
* S0BF(MLEVEL),
* ALFBF(MLEVEL),
* BETBF(MLEVEL),
* GAMBF(MLEVEL)
C
COMMON/MRGPAR/SGM0(MMER),
* FRCH(MMER),
* SGEXT1(MMER,MDEPTH),
* GMER(MMER,MDEPTH),
* SGMSUM(NLMX,MMER,MDEPTH),
* SGMG(MMER,MDEPTH),
* IMRG(MLEVEL),
* IIMER(MMER)
C
COMMON/DWNPAR/ELEC23(MDEPTH),
* Z3(MZZ),
* DWC1(MZZ,MDEPTH),
* DWC2(MDEPTH)
C
C additional opacities
c
COMMON/OPCPAR/IOPADD,
* IOPHMI,
* IOPH2P,
* IOPHEM,
* IOPCH,
* IOPOH,
* IOPH2M,
* IOH2H2,IOH2HE,IOH2H1,IOHHE,
* IOPHLI,
* IRSCT,
* IRSCHE,
* IRSCH2
C
C Auxiliary parameters
C
COMMON/AUXIND/IATH,IELH,IELHM,N0H,N1H,NKH,N0HN,N0M,
* IATHE,IELHE1,IELHE2
COMMON/MOLFLG/TMOLIM,MOLIND(11000),NMOLEC,IFMOL,
* MOLTAB,IRWTAB,IIRWIN,IPFEXO
COMMON/QFLAGS/ERANGE,ISPICK,ILPICK,IPPICK
C
C Parameters for atoms considered in line blanketing opacity
C
LOGICAL LGR(MATOM),LRM(MATOM)
COMMON/PFSTDS/PFSTD(MION,MATOM),MODPF(MATOM)
COMMON/ADDPOP/RR(MATOM,MION)
COMMON/ATOBLN/ENEV(MATOM,MI1),AMAS(MATOM),ABND(MATOM),
* ABNDD(MATOM,MDEPTH),ABNREF(MDEPTH),TYPAT(MATOM),
* IATEX(MATOM),INPOT(MATOM,MION0)
COMMON/ATOINI/NATOMS,IONIZ(MATOM),LGR,LRM
c
c parameters for hydrogen Stark broadening tables
c
COMMON/HYDPRF/PRFHYD(MLINH,MDEPTH,MHWL),
* WLHYD(MLINH,MHWL),
* NWLHYD(MLINH),
* WL(MHWL,MLINH),
* XT(MHT,MLINH),
* XNE(MHE,MLINH),
* PRF(MHWL,MHT,MHE,MLINH),
* WLINE(4,22),
* NWLH(MLINH),
* NTH(MLINH),
* NEH(MLINH),
* ILIN0(4,22),
* ILEMKE,
* NLIHYD
COMMON/AUXHYD/XK,FXK,BETAD,DBETA,BERGFC,CUTLYM,CUTBAL
COMMON/HHEPRF/IHYDPR,IHE1PR,IHE2PR
COMMON/HYLPAR/IHYL,ILOWH,M10,M20
COMMON/HYLPAW/IHYLW(MFREQ),ILOWHW(MFREQ),
* M10W(MFREQ),M20W(MFREQ)
COMMON/HE2PAR/IFHE2,IHE2L,ILWHE2,MHE10,MHE20
COMMON/HE2PAW/IHE2LW(MFREQ),ILWHEW(MFREQ),
* MHE10W(MFREQ),MHE20W(MFREQ)
C
C parameters for the macroscopic velocity field and angles
C
COMMON/VELPAR/ANGL(MMU),WANGL(MMU),VELC(MDEPTH),NMU0,IFLUX
synspec/extracted/SYNTHP.FOR
+10
View File
@@ -0,0 +1,10 @@
COMMON/FREQSY/FREQ(MFREQ),W(MFREQ),WLAM(MFREQ),
* FRX1(MFREQ),FRX2(MFREQ),BNUE(MFREQ),
* FRQOBS(MFREQ),WLOBS(MFREQ),
* FREQC(MFREQC),WLAMC(MFREQC),
* IJCINT(MFREQ)
COMMON/CRSAVG/FRECR(MCROSS,MFCRA),CROSR(MCROSS,MFCRA),
* CRMX(MCROSS),NFCR(MCROSS),IASV
COMMON/CRSAVQ/FRECQ(MPHOT,MFCRA),QHOT(MPHOT,MFCRA),
* AQHT(MPHOT),EQHT(MPHOT),GQHT(MPHOT),
* CRMY(MPHOT),NFQHT(MPHOT),NQHT
synspec/extracted/WINCOM.FOR
+15
View File
@@ -0,0 +1,15 @@
PARAMETER (MRCORE=20,
* MKU=MDEPTH+MRCORE,
* MEXT=MKU)
COMMON/COMANG/BMU(MKU,MDEPTH),WMUJ(MKU,MDEPTH),WMUH(MKU)
COMMON/CORADI/RD(MDEPTH),RCORE,RFNORM,PIM(MKU),RAD1(MDEPTH),
* DELZ(MKU,MDEPTH),NUD(MKU),NUDF(MKU),KMU,NREXT,
* NRCORE,NFIRY,NDF
COMMON/CORAF/DELZF(MEXT,MDEPF ),DFRQF(MEXT,2*MDEPF )
COMMON/COVEL/VEL(MDEPTH),DFRQ(MKU,2*MDEPTH),DVD(MDEPTH),
* XMDOT,XMD4,BETAV,VINF
COMMON/EXTMOD/FFQ(MOPAC),FFQV(MOPAC),RDF(MDEPF ),DENSF(MDEPF ),
* VELF(MEXT,MDEPF ),DRAY(MEXT,2*MDEPF ),
* KRAY(MEXT,2*MDEPF ),NOPAC
COMMON/OPAVEL/WDIL(MDEPTH),PLANW(MDEPTH),TRAD(MTRAD,MDEPTH),
* DENSCON(MDEPTH)
synspec/extracted/_COMMON_ANALYSIS.txt
+249
View File
@@ -0,0 +1,249 @@
COMMON 块依赖分析
============================================================
有 COMMON 依赖的单元:
------------------------------------------------------------
ABNCHN: relabu
ALLARD: callardb, callardg, callarda, callardc
CHANGE: BLANK
CROSET: dissol
CROSEW: PHOPAR, dissol
ELDENS: hydmol, nerela, hydato
EOSPRI: hydmol, ioniz2, hydato, moltst
FINGRD: fintab, gridp0, tabout, gridf0, relabu
FRAC1: fracop
FRACTN: fracop
GETLAL: callarda, callardb, callardg, callardc, quasun
GHYDOP: GOMOPA
GOMINI: gompar, GOMOPA
GVDW: PRFQUA
HE1INI: PRO447, PROHE1
HE2INI: HE2DAT, HE2PRF
HE2LIN: HE2PRF
HE2LIW: HE2PRF, lasers
HYDLIN: gompar, hhebrd, quasun
HYDLIW: quasun, lasers
IDMTAB: REFDEP, RTEOPA
IDTAB: REFDEP, RTEOPA, PRFQUA
INGRID: alsave, fintab, elecm0, gridp0, timeta, prfrgr, tabout, gridf0, relabu, igrddd, initab
INIBL0: alsave, linrej, BLAPAR, lasers, velaux, LIMPAR
INIBL1: alsave, plaopa, conabs, BLAPAR, LIMPAR
INIBLA: PRFQUA
INIBLH: PRFQUA
INILIN: IPOTLS, BLAPAR, LIMPAR
INILIN_GRID: plaopa, conabs, BLAPAR, igrddd, LIMPAR
INIMOD: RRRVAL, BLAPAR, HPOPST
INISET: CTRFUN, BLAPAR, LIMPAR
INITIA: STRPAR, IONDAT, INUNIT, quasex, IONFIL, PRINTP, dissol
INKUR: BLANK
INMOLI: NXTINM, BLAPAR, brdstd, alendm, LIMPAR
INPMOD: NLTPOP, quasex, BLANK
INTHE2: HE2DAT
LINOP: NLTPOP, PRFQUA, lasers
LINOPW: velaux, linrej, IPOTLS, NLTPOP, PRFQUA, BLAPAR, lasers
LYAHHE: hhebrd, calhhe
MOLEQ: COMFH1, ioniz2, moltst
MOLINI: moltst
MOLSET: BLAPAR, alendm, LIMPAR
NLTE: NLTPOP
NLTSET: NL2PAR, PRINTP
NSTPAR: gompar, brdstd, hhebrd
OPAC: dissol, BLAPAR
OPACON: dissol, BLAPAR
OPACW: dissol, BLAPAR, lasers
OPDATA: TOPB
OUGRID: prfrgr, gridf0, initab
OUTPRI: EMFLUX
PHE1: PRO447, PROHE1
PHE2: HE2PRF, lasers
PHTION: PHOTCS
PRETAB: VOITAB
PROFIL: PRFQUA
RADTEM: velaux
RDATA: STRPAR, IONDAT, TOPCS, INUNIT, quasex, IONFIL, PRINTP, dissol
READPH: PHOTCS
RESOLV: RTEOPA, HPOPST
RESOLW: COPAC, CONOPA, EMFLUX, HPOPST, FRQSET, BLAPAR, LIMPAR
RHONEN: nerela
RTE: REFDEP, EMFLUX, CENTRL, BLAPAR, CTRFUN, RTEOPA
RTECD: RTEOPA, EMFLUX, CONSCA
RTEDFE: REFDEP, RTEOPA, EMFLUX, CONSCA
RTESCA: COPAC, EMFLUX, CONOPA, CONSCV, RTEOPA
RTEWIN: COPAC, REFDEP, EMFLUX, CONSCV
RUSSEL: COMFH1
SETWIN: velaux
SIGAVS: IONFIL
SIGK: TOPCS, PRINTP, dissol
START: quasun
STATE: ioniz2, moltst
TIMING: timeta
TODENS: hydmol
TOPBAS: TOPB
VOIGTK: VOITAB
共 77 个单元有 COMMON 依赖
共 77 个 COMMON 块被引用
唯一的 COMMON 块: ['BLANK', 'BLAPAR', 'CENTRL', 'COMFH1', 'CONOPA', 'CONSCA', 'CONSCV', 'COPAC', 'CTRFUN', 'EMFLUX', 'FRQSET', 'GOMOPA', 'HE2DAT', 'HE2PRF', 'HPOPST', 'INUNIT', 'IONDAT', 'IONFIL', 'IPOTLS', 'LIMPAR', 'NL2PAR', 'NLTPOP', 'NXTINM', 'PHOPAR', 'PHOTCS', 'PRFQUA', 'PRINTP', 'PRO447', 'PROHE1', 'REFDEP', 'RRRVAL', 'RTEOPA', 'STRPAR', 'TOPB', 'TOPCS', 'VOITAB', 'alendm', 'alsave', 'brdstd', 'calhhe', 'callarda', 'callardb', 'callardc', 'callardg', 'conabs', 'dissol', 'elecm0', 'fintab', 'fracop', 'gompar', 'gridf0', 'gridp0', 'hhebrd', 'hydato', 'hydmol', 'igrddd', 'initab', 'ioniz2', 'lasers', 'linrej', 'moltst', 'nerela', 'plaopa', 'prfrgr', 'quasex', 'quasun', 'relabu', 'tabout', 'timeta', 'velaux']
INCLUDE 文件依赖:
------------------------------------------------------------
ABNCHN: MODELP.FOR, PARAMS.FOR
ALLARD: PARAMS.FOR
CARBON: PARAMS.FOR
CHANGE: MODELP.FOR, PARAMS.FOR
CHCKAB: MODELP.FOR, PARAMS.FOR
CROSET: PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
CROSEW: PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
DENSIT: MODELP.FOR, PARAMS.FOR
DIVHE2: PARAMS.FOR
DIVSTR: PARAMS.FOR
DWNFR0: MODELP.FOR, PARAMS.FOR
DWNFR1: MODELP.FOR, PARAMS.FOR
ELDENS: MODELP.FOR, PARAMS.FOR
EOSPRI: MODELP.FOR, PARAMS.FOR
EPS: PARAMS.FOR
EXOPF: PARAMS.FOR
EXPINT: PARAMS.FOR
EXTPRF: PARAMS.FOR
FEAUTR: MODELP.FOR, PARAMS.FOR
FINGRD: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
FRAC1: MODELP.FOR, PARAMS.FOR
GAMHE: MODELP.FOR, PARAMS.FOR
GAUNT: PARAMS.FOR
GETLAL: PARAMS.FOR
GETWRD: IMPLIC.FOR
GFREE: PARAMS.FOR
GHYDOP: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
GNTK: PARAMS.FOR
GOMINI: MODELP.FOR, PARAMS.FOR
GRIEM: MODELP.FOR, PARAMS.FOR
GVDW: MODELP.FOR, PARAMS.FOR, LINDAT.FOR
H2MINUS: PARAMS.FOR
H2OPF: PARAMS.FOR
HE1INI: MODELP.FOR, PARAMS.FOR
HE2INI: MODELP.FOR, PARAMS.FOR
HE2LIN: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
HE2LIW: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
HE2SET: PARAMS.FOR, SYNTHP.FOR
HE2SEW: PARAMS.FOR, SYNTHP.FOR
HEPHOT: PARAMS.FOR
HESET: MODELP.FOR, PARAMS.FOR
HIDALG: PARAMS.FOR
HYDINI: MODELP.FOR, PARAMS.FOR
HYDLIN: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
HYDLIW: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
HYDTAB: MODELP.FOR, PARAMS.FOR
HYLSET: PARAMS.FOR, SYNTHP.FOR
HYLSEW: PARAMS.FOR, SYNTHP.FOR
IDMTAB: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
IDTAB: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INGRID: MODELP.FOR, PARAMS.FOR, LINDAT.FOR
INIBL0: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
INIBL1: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
INIBLA: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INIBLH: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INIBLM: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INILIN: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INILIN_GRID: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INIMOD: MODELP.FOR, PARAMS.FOR
INISET: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
INITIA: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
INKUR: MODELP.FOR, PARAMS.FOR
INMOLI: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
INPBF: MODELP.FOR, PARAMS.FOR
INPMOD: MODELP.FOR, PARAMS.FOR
INTERP: PARAMS.FOR
INTHE2: PARAMS.FOR
INTHYD: PARAMS.FOR
INTRP: PARAMS.FOR
INTXEN: MODELP.FOR, PARAMS.FOR
IRWPF: PARAMS.FOR
ISPEC: PARAMS.FOR
LEVSOL: MODELP.FOR, PARAMS.FOR
LINEQS: PARAMS.FOR
LINOP: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
LINOPW: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
LYAHHE: PARAMS.FOR
LYMLIN: MODELP.FOR, PARAMS.FOR
MATINV: PARAMS.FOR
MOLEQ: MODELP.FOR, PARAMS.FOR
MOLINI: MODELP.FOR, PARAMS.FOR
MOLOP: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
MOLSET: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
NLTE: MODELP.FOR, PARAMS.FOR, LINDAT.FOR
NLTSET: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
NSTPAR: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
OPAC: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
OPACON: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
OPACW: MODELP.FOR, SYNTHP.FOR, WINCOM.FOR, PARAMS.FOR, LINDAT.FOR
OPADD: MODELP.FOR, PARAMS.FOR
OPDATA: PARAMS.FOR
OUGRID: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
OUTPRI: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
PARTDV: PARAMS.FOR
PARTF: PARAMS.FOR
PFFE: PARAMS.FOR
PFHEAV: PARAMS.FOR
PFSPEC: PARAMS.FOR
PHE1: MODELP.FOR, PARAMS.FOR
PHE2: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
PHTION: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
PHTX: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
PRETAB: PARAMS.FOR
PROFIL: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
QUIT: PARAMS.FOR
RADTEM: MODELP.FOR, PARAMS.FOR, WINCOM.FOR
RATMAT: MODELP.FOR, PARAMS.FOR
RDATA: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
READBF: PARAMS.FOR
READPH: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
REIMAN: PARAMS.FOR
RESOLV: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
RESOLW: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
RHONEN: PARAMS.FOR
RTE: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
RTECD: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
RTEDFE: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
RTESCA: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
RTEWIN: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, WINCOM.FOR
RUSSEL: MODELP.FOR, PARAMS.FOR
SABOLF: MODELP.FOR, PARAMS.FOR
SBFCH: PARAMS.FOR
SBFHE1: PARAMS.FOR
SBFHMI: PARAMS.FOR
SBFHMI_OLD: PARAMS.FOR
SBFOH: PARAMS.FOR
SETRAY: MODELP.FOR, PARAMS.FOR, WINCOM.FOR
SETWIN: MODELP.FOR, PARAMS.FOR, WINCOM.FOR
SFFHMI: PARAMS.FOR
SFFHMI_OLD: PARAMS.FOR
SGHE12: PARAMS.FOR
SGMERG: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR
SIGAVS: PARAMS.FOR, SYNTHP.FOR
SIGK: PARAMS.FOR
SPSIGK: PARAMS.FOR
STARK0: PARAMS.FOR
STARKA: PARAMS.FOR
STARKIR: PARAMS.FOR
START: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
STATE: PARAMS.FOR, WINCOM.FOR
STATE0: PARAMS.FOR
SYNSPEC: MODELP.FOR, PARAMS.FOR, SYNTHP.FOR, LINDAT.FOR
TINT: MODELP.FOR, PARAMS.FOR
TODENS: MODELP.FOR, PARAMS.FOR
TOPBAS: PARAMS.FOR
TRIDAG: PARAMS.FOR, WINCOM.FOR
VELSET: MODELP.FOR, PARAMS.FOR, WINCOM.FOR
VOIGTE: PARAMS.FOR
VOIGTK: PARAMS.FOR
VOPF: PARAMS.FOR
WGTJH1: PARAMS.FOR, WINCOM.FOR
WN: MODELP.FOR, PARAMS.FOR
WNSTOR: MODELP.FOR, PARAMS.FOR
WTOT: MODELP.FOR, PARAMS.FOR
XENINI: MODELP.FOR, PARAMS.FOR
XK2DOP: PARAMS.FOR
YINT: PARAMS.FOR
YLINTP: PARAMS.FOR
synspec/extracted/_PURE_UNITS.txt
+94
View File
@@ -0,0 +1,94 @@
无 COMMON 依赖的纯函数/子程序
========================================
CARBON
CHCKAB
CIA_H2H
CIA_H2H2
CIA_H2HE
CIA_HHE
COUNT_WORDS
DENSIT
DIVHE2
DIVSTR
DWNFR0
DWNFR1
EPS
EXOPF
EXPINT
EXTPRF
FEAUTR
GAMHE
GAUNT
GETWRD
GFREE
GNTK
GRIEM
H2MINUS
H2OPF
HE2SET
HE2SEW
HEPHOT
HESET
HIDALG
HYDINI
HYDTAB
HYLSET
HYLSEW
INIBLM
INPBF
INTERP
INTHYD
INTRP
INTXEN
IRWPF
ISPEC
LEVSOL
LINEQS
LOCATE
LYMLIN
MATINV
MOLOP
MPARTF
OPADD
PARTDV
PARTF
PFFE
PFHEAV
PFNI
PFSPEC
PHTX
QUIT
RATMAT
READBF
REIMAN
SABOLF
SBFCH
SBFHE1
SBFHMI
SBFHMI_OLD
SBFOH
SETRAY
SFFHMI
SFFHMI_OLD
SGHE12
SGMERG
SPSIGK
STARK0
STARKA
STARKIR
STATE0
SYNSPEC
TINT
TRIDAG
VELSET
VOIGTE
VOPF
WGTJH1
WN
WNSTOR
WTOT
XENINI
XK2DOP
YINT
YLINTP
synspec/extracted/_SUMMARY.txt
+182
View File
@@ -0,0 +1,182 @@
SYNSPEC54.F 提取摘要
============================================================
源文件: synspec/synspec54.f
总单元数: 168
总行数: 23918
名称 类型 文件 行数
------------------------------------------------------------
SYNSPEC PROGRAM synspec.f 174
START SUBROUTINE start.f 107
INITIA SUBROUTINE initia.f 339
RDATA SUBROUTINE rdata.f 472
NSTPAR SUBROUTINE nstpar.f 136
COUNT_WORDS SUBROUTINE count_words.f 16
GETWRD SUBROUTINE getwrd.f 47
STATE0 SUBROUTINE state0.f 546
INIMOD SUBROUTINE inimod.f 68
STATE SUBROUTINE state.f 95
TINT SUBROUTINE tint.f 22
INIBL0 SUBROUTINE inibl0.f 456
INIBL1 SUBROUTINE inibl1.f 117
RESOLV SUBROUTINE resolv.f 86
RTE SUBROUTINE rte.f 594
OUTPRI SUBROUTINE outpri.f 116
CROSET SUBROUTINE croset.f 35
CROSEW SUBROUTINE crosew.f 33
SIGK FUNCTION sigk.f 171
GAUNT FUNCTION gaunt.f 42
GNTK FUNCTION gntk.f 18
SPSIGK SUBROUTINE spsigk.f 34
CARBON SUBROUTINE carbon.f 52
SGHE12 FUNCTION sghe12.f 17
HIDALG FUNCTION hidalg.f 74
REIMAN FUNCTION reiman.f 67
SBFHE1 FUNCTION sbfhe1.f 146
HEPHOT FUNCTION hephot.f 164
TOPBAS FUNCTION topbas.f 49
OPDATA SUBROUTINE opdata.f 65
YLINTP FUNCTION ylintp.f 29
OPAC SUBROUTINE opac.f 223
OPACW SUBROUTINE opacw.f 199
OPACON SUBROUTINE opacon.f 126
SGMERG FUNCTION sgmerg.f 34
GFREE FUNCTION gfree.f 21
SFFHMI_OLD FUNCTION sffhmi_old.f 9
LYMLIN SUBROUTINE lymlin.f 68
FEAUTR FUNCTION feautr.f 40
HYLSET SUBROUTINE hylset.f 64
HYLSEW SUBROUTINE hylsew.f 58
HYDLIN SUBROUTINE hydlin.f 369
HYDLIW SUBROUTINE hydliw.f 258
HE2SET SUBROUTINE he2set.f 92
HE2SEW SUBROUTINE he2sew.f 86
HE2LIN SUBROUTINE he2lin.f 201
HE2LIW SUBROUTINE he2liw.f 196
STARK0 SUBROUTINE stark0.f 90
STARKA FUNCTION starka.f 54
STARKIR FUNCTION starkir.f 33
DIVSTR SUBROUTINE divstr.f 34
HYDINI SUBROUTINE hydini.f 191
HYDTAB SUBROUTINE hydtab.f 48
INTHYD SUBROUTINE inthyd.f 92
YINT FUNCTION yint.f 17
HE1INI SUBROUTINE he1ini.f 55
WTOT FUNCTION wtot.f 40
EXTPRF FUNCTION extprf.f 21
PHE1 FUNCTION phe1.f 158
HE2INI SUBROUTINE he2ini.f 91
INTHE2 SUBROUTINE inthe2.f 82
DIVHE2 SUBROUTINE divhe2.f 29
PHE2 SUBROUTINE phe2.f 98
ISPEC FUNCTION ispec.f 59
HESET SUBROUTINE heset.f 150
INISET SUBROUTINE iniset.f 354
READPH SUBROUTINE readph.f 150
INILIN SUBROUTINE inilin.f 607
INILIN_GRID SUBROUTINE inilin_grid.f 383
INIBLA SUBROUTINE inibla.f 46
IDTAB SUBROUTINE idtab.f 97
INIBLH SUBROUTINE iniblh.f 125
NLTSET SUBROUTINE nltset.f 403
PHTION SUBROUTINE phtion.f 46
NLTE SUBROUTINE nlte.f 95
LINOP SUBROUTINE linop.f 158
LINOPW SUBROUTINE linopw.f 241
PROFIL SUBROUTINE profil.f 54
GRIEM SUBROUTINE griem.f 18
GAMHE SUBROUTINE gamhe.f 69
EPS FUNCTION eps.f 23
XK2DOP FUNCTION xk2dop.f 33
INKUR SUBROUTINE inkur.f 65
INPMOD SUBROUTINE inpmod.f 160
INPBF SUBROUTINE inpbf.f 35
LEVSOL SUBROUTINE levsol.f 37
CHANGE SUBROUTINE change.f 100
RATMAT SUBROUTINE ratmat.f 37
SABOLF SUBROUTINE sabolf.f 115
SBFHMI_OLD FUNCTION sbfhmi_old.f 22
OPADD SUBROUTINE opadd.f 210
WN FUNCTION wn.f 53
WNSTOR SUBROUTINE wnstor.f 39
QUIT SUBROUTINE quit.f 11
VOIGTE FUNCTION voigte.f 90
SIGAVS SUBROUTINE sigavs.f 202
PHTX SUBROUTINE phtx.f 101
GETLAL SUBROUTINE getlal.f 93
ALLARD SUBROUTINE allard.f 228
LYAHHE SUBROUTINE lyahhe.f 61
READBF SUBROUTINE readbf.f 20
PRETAB SUBROUTINE pretab.f 39
VOIGTK FUNCTION voigtk.f 41
RTECD SUBROUTINE rtecd.f 452
RTEDFE SUBROUTINE rtedfe.f 168
PARTF SUBROUTINE partf.f 845
PFFE SUBROUTINE pffe.f 298
MATINV SUBROUTINE matinv.f 76
LINEQS SUBROUTINE lineqs.f 63
EXPINT FUNCTION expint.f 18
INTERP SUBROUTINE interp.f 82
INTRP SUBROUTINE intrp.f 44
PFSPEC SUBROUTINE pfspec.f 1702
PARTDV SUBROUTINE partdv.f 29
PFNI SUBROUTINE pfni.f 326
PFHEAV SUBROUTINE pfheav.f 367
FRAC1 SUBROUTINE frac1.f 88
FRACTN SUBROUTINE fractn.f 155
DWNFR0 SUBROUTINE dwnfr0.f 24
DWNFR1 SUBROUTINE dwnfr1.f 41
CHCKAB SUBROUTINE chckab.f 49
MOLINI SUBROUTINE molini.f 78
INMOLI SUBROUTINE inmoli.f 346
MOLSET SUBROUTINE molset.f 143
INIBLM SUBROUTINE iniblm.f 31
IDMTAB SUBROUTINE idmtab.f 86
MOLOP SUBROUTINE molop.f 61
SBFHMI FUNCTION sbfhmi.f 42
SFFHMI FUNCTION sffhmi.f 70
MPARTF SUBROUTINE mpartf.f 134
MOLEQ SUBROUTINE moleq.f 262
RUSSEL SUBROUTINE russel.f 230
SETWIN SUBROUTINE setwin.f 70
SETRAY SUBROUTINE setray.f 211
WGTJH1 SUBROUTINE wgtjh1.f 102
TRIDAG SUBROUTINE tridag.f 24
RESOLW SUBROUTINE resolw.f 187
RTESCA SUBROUTINE rtesca.f 241
RTEWIN SUBROUTINE rtewin.f 248
VELSET SUBROUTINE velset.f 204
RADTEM SUBROUTINE radtem.f 55
SBFCH FUNCTION sbfch.f 279
SBFOH FUNCTION sbfoh.f 328
XENINI SUBROUTINE xenini.f 120
INTXEN SUBROUTINE intxen.f 49
GOMINI SUBROUTINE gomini.f 95
GHYDOP SUBROUTINE ghydop.f 50
INGRID SUBROUTINE ingrid.f 334
OUGRID SUBROUTINE ougrid.f 38
FINGRD SUBROUTINE fingrd.f 131
ABNCHN SUBROUTINE abnchn.f 52
DENSIT SUBROUTINE densit.f 57
TODENS SUBROUTINE todens.f 109
RHONEN SUBROUTINE rhonen.f 41
ELDENS SUBROUTINE eldens.f 210
TIMING SUBROUTINE timing.f 25
EOSPRI SUBROUTINE eospri.f 247
CIA_H2H2 SUBROUTINE cia_h2h2.f 89
LOCATE SUBROUTINE locate.f 26
CIA_H2HE SUBROUTINE cia_h2he.f 90
CIA_H2H SUBROUTINE cia_h2h.f 87
CIA_HHE SUBROUTINE cia_hhe.f 89
H2MINUS SUBROUTINE h2minus.f 99
H2OPF SUBROUTINE h2opf.f 22
VOPF SUBROUTINE vopf.f 22
GVDW FUNCTION gvdw.f 32
EXOPF SUBROUTINE exopf.f 78
IRWPF SUBROUTINE irwpf.f 165
按类型统计:
PROGRAM: 1
SUBROUTINE: 134
FUNCTION: 33
synspec/extracted/abnchn.f
+52
View File
@@ -0,0 +1,52 @@
subroutine abnchn(mode)
c =======================
c
c changing abundances (eliminating) species for an
c evaluating an opacity table
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
common/relabu/relabn(matom),popul0(mlevel,1)
data iread/1/
c
if(iread.eq.1) then
do ia=1,matom
relabn(ia)=1.
end do
10 continue
read(2,*,err=20,end=20) iatom,rela
relabn(iatom)=rela
write(*,*) 'ABUNDANCES CHANGED (AT.NUMBER, ABUND):',iatom,rela
go to 10
20 continue
if(relabn(1).eq.0.) then
iophmi=0
ioph2p=0
end if
iread=0
end if
c
if(mode.eq.0) then
do iat=1,natom
do ii=n0a(iat),nka(iat)
popul0(ii,1)=popul(ii,1)
end do
end do
return
end if
c
do iat=1,natom
ia=numat(iat)
do ii=n0a(iat),nka(iat)
popul(ii,1)=popul0(ii,1)*relabn(ia)
end do
end do
c
do ia=1,matom
do io=1,mion0
rrr(1,io,ia)=rrr(1,io,ia)*relabn(ia)
end do
end do
c
return
end
synspec/extracted/allard.f
+228
View File
@@ -0,0 +1,228 @@
subroutine allard(xl,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 'PARAMS.FOR'
parameter (NXMAX=1400,NNMAX=5)
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
c
prof=0.
c
c Lyman alpha
c
if(iq.eq.1.and.jq.eq.2) then
c if(xl.lt.xlalp(1).or.xl.gt.xlalp(nxalp)) return
if(xl.lt.xlalp(1)) 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
if(xl.le.xlalp(nxalp)) then
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
c
else
j=nxalp-1
c a1=(xl-xlalp(j))/(xlalp(j+1)-xlalp(j))
a1=1.
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))
pro0=(p1+p2+p11+p22+p12)*xnorm*xnorma
xlas=xlalp(nxalp)
x0=1215.67
dxlas=xlalp(nxalp)-x0
dx=xl-x0
prof=pro0/(dx/dxlas)**2.5
c
end if
return
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
c vn1=hneutr/stnnec
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
synspec/extracted/carbon.f
+52
View File
@@ -0,0 +1,52 @@
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 'PARAMS.FOR'
DIMENSION FR2(34),SG2(34),FR3(45),SG3(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/
DATA NC2,NC3/34,45/
DATA FR0/3.28805E15/
F=FR/FR0
IF(IB.NE.-602) GO TO 25
J=2
IF(F.LE.FR2(1)) GO TO 20
DO 10 I=2,NC2
J=I
IF(F.GT.FR2(I-1).AND.F.LE.FR2(I)) GO TO 20
10 CONTINUE
20 SG=(F-FR2(J-1))/(FR2(J)-FR2(J-1))*(SG2(J)-SG2(J-1))+SG2(J-1)
SG=SG*1.E-18
25 IF(IB.NE.-603) GO TO 50
J=2
IF(F.LE.FR3(1)) GO TO 40
DO 30 I=2,NC3
J=I
IF(F.GT.FR3(I-1).AND.F.LE.FR3(I)) GO TO 40
30 CONTINUE
40 SG=(F-FR3(J-1))/(FR3(J)-FR3(J-1))*(SG3(J)-SG3(J-1))+SG3(J-1)
SG=SG*1.E-18
50 CONTINUE
RETURN
END
synspec/extracted/change.f
+100
View File
@@ -0,0 +1,100 @@
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 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 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),POPLTE(MLEVEL)
COMMON ESEMAT,BESE,POPLTE,POPUL0(MLEVEL,MDEPTH),
* POPULL(MLEVEL,MDEPTH),POPL(MLEVEL)
C
PARAMETER (S = 2.0706E-16)
IFESE=0
DO 100 II=1,NLEVEL
READ(ICHANG,*) IOLD,MODE,NXTOLD,ISINEW,ISIOLD,NXTSIO,REL
IF(MODE.GE.3) IFESE=IFESE+1
IF(REL.EQ.0.) REL=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
CALL SABOLF(ID)
CALL RATMAT(ID,ESEMAT,BESE)
CALL LINEQS(ESEMAT,BESE,POPLTE,NLEVEL,MLEVEL)
DO 50 III=1,NLEVEL
50 POPULL(III,ID)=POPLTE(III)
END IF
POPUL0(II,ID)=POPULL(II,ID)
90 CONTINUE
100 CONTINUE
DO 110 I=1,NLEVEL
DO 110 ID=1,ND
POPUL(I,ID)=POPUL0(I,ID)
110 CONTINUE
RETURN
END
synspec/extracted/chckab.f
+49
View File
@@ -0,0 +1,49 @@
SUBROUTINE CHCKAB
C
C check input abumdances of explicit atoms (unit 5) and those
C which follow from the models atmosphere (unit 7) obtained by
C summing all populations and upper sums
C The program stops if it finds discrepancy more than 10 %
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
dimension sumpop(matom),sumiat(matom)
c
IST=0
DO ID1=1,3
IF(ID1.EQ.1) ID=1
IF(ID1.EQ.2) ID=46
IF(ID1.EQ.3) ID=ND
CALL WNSTOR(ID)
ANE=ELEC(ID)
CALL SABOLF(ID)
DO IAT=1,NATOM
SUM=0.
sump=0.
DO I=N0A(IAT),NKA(IAT)
IL=ILK(I)
A=1.
IF(IL.GT.0) A=1.+ANE*USUM(IL)
SUM=SUM+A*POPUL(I,ID)
SUMP=SUMP+POPUL(I,ID)
END DO
SUMIAT(IAT)=SUM
SUMPOP(IAT)=SUMP
END DO
WRITE(6,600) ID
DO IAT=1,NATOM
X=SUMIAT(IAT)/SUMIAT(IATREF)
WRITE(6,601) IAT,X,abund(iat,id),SUMPOP(IAT)/SUMPOP(IATREF)
IF(X/abund(iat,id).GT.1.1.OR.X/abund(iat,id).LT.0.9) ist=ist+1
END DO
END DO
IF(IST.GT.0) THEN
WRITE(6,602)
STOP
END IF
600 FORMAT(' check of abundances (id =',i3/
* ' computed from model atmosphere - input abundances'/)
601 format(i5,1p3e20.3)
602 format(' ERROR !!! - inconsistent abundances'/)
RETURN
END
synspec/extracted/cia_h2h.f
+87
View File
@@ -0,0 +1,87 @@
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,*)
enddo
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
enddo
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))
enddo
enddo
ifirst=1
endif
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-H opacity set to 0'
write(*,*)
opac=0.
return
endif
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
endif
alp=exp(alp)
c final opacity
opac=fac*ah2*ah*alp
c
return
end
synspec/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,*)
enddo
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
enddo
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))
enddo
enddo
ifirst=1
endif
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
endif
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
endif
alp=exp(alp)
c final opacity
opac=fac*ah2*ah2*alp
c
return
end
synspec/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,*)
enddo
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
enddo
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))
enddo
enddo
ifirst=1
endif
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
endif
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
endif
alp=exp(alp)
c final opacity
opac=fac*ah2*ahe*alp
c
return
end
synspec/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,*)
enddo
do i=1,nlines
read (10,*) freq(i),(alpha(i,j),j=1,ntemp)
enddo
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))
enddo
enddo
ifirst=1
endif
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
endif
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
endif
alp=exp(alp)
c final opacity
opac=fac*ah*ahe*alp
c
return
end
synspec/extracted/count_words.f
+16
View File
@@ -0,0 +1,16 @@
subroutine count_words(cadena,n)
C
C Counts the number of words separated by blanks in a string
C
character*1000 cadena
character*1 a,b
n=0
a=cadena(1:1)
if (a.ne.' ') n=1
do i=2,len(cadena)
b=cadena(i:i)
if(b.ne.' '.and.a.eq.' ') n=n+1
a=b
enddo
end
synspec/extracted/croset.f
+35
View File
@@ -0,0 +1,35 @@
SUBROUTINE CROSET(CROSS)
C
C SET UP ARRAY CROSS - PHOTOIONIZATION CROSS-SECTIONS
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
DIMENSION CROSS(MCROSS,MFRQ)
common/dissol/fropc(mlevel),indexp(mlevel)
C
IJ0=2
IF(NFREQ.EQ.1) IJ0=1
IF(IMODE.EQ.2) IJ0=NFREQ
DO IJ=1,IJ0
DO IT=1,MCROSS
CROSS(IT,IJ)=0.
END DO
END DO
DO IT=1,NLEVEL
IF(INDEXP(IT).NE.5) THEN
DO IJ=1,IJ0
FR=FREQ(IJ)
CROSS(IT,IJ)=SIGK(FR,IT,0)
END DO
ELSE
DO IJ=1,IJ0
FR=FREQ(IJ)
CROSS(IT,IJ)=SIGK(FR,IT,1)
IF(FR.LT.FROPC(IT)) CROSS(IT,IJ)=0.
END DO
END IF
END DO
C
RETURN
END
synspec/extracted/crosew.f
+33
View File
@@ -0,0 +1,33 @@
SUBROUTINE CROSEW(CROSS)
C
C SET UP COMMON/PHOPAR/ - PHOTOIONIZATION CROSS-SECTIONS
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
DIMENSION CROSS(MCROSS,MFRQ)
common/dissol/fropc(mlevel),indexp(mlevel)
C
IJ0=NFREQC
DO IJ=1,IJ0
DO IT=1,MCROSS
CROSS(IT,IJ)=0.
END DO
END DO
DO IT=1,NLEVEL
IF(INDEXP(IT).NE.5) THEN
DO IJ=1,IJ0
FR=FREQC(IJ)
CROSS(IT,IJ)=SIGK(FR,IT,0)
END DO
ELSE
DO IJ=1,IJ0
FR=FREQC(IJ)
CROSS(IT,IJ)=SIGK(FR,IT,1)
IF(FR.LT.FROPC(IT)) CROSS(IT,IJ)=0.
END DO
END IF
END DO
C
RETURN
END
synspec/extracted/densit.f
+57
View File
@@ -0,0 +1,57 @@
subroutine densit(rho,idens)
C ============================
C
C determining the state parameters for the opacity grid
C calculations
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION ES(MLEVEL,MLEVEL),BS(MLEVEL),POPLTE(MLEVEL)
c
id=1
dm(id)=0.
IF(IFMOL.EQ.0.OR.TEMP(ID).GT.TMOLIM)
* WMM(ID)=WMY(ID)*HMASS/YTOT(ID)
if(idens.eq.0) then
ELEC(ID)=rho
ane=elec(id)
call todens(id,temp(id),an,ane)
DENS(ID)=(an-ane)*wmm(id)
p=an*bolk*temp(id)
c WRITE(6,602) ID,TEMP(ID),DENS(ID),ELEC(ID)
else if(idens.lt.0) then
AN=rho/TEMP(ID)/BOLK
CALL ELDENS(ID,TEMP(ID),AN,ANE)
ELEC(ID)=ANE
DENS(ID)=WMM(ID)*(AN-ELEC(ID))
c WRITE(6,601) ID,TEMP(ID),DENS(ID),ELEC(ID),ane0,an
else if(idens.eq.1) then
DENS(ID)=RHO
CALL RHONEN(ID,TEMP(ID),RHO,AN,ANE)
ELEC(ID)=ANE
DENS(ID)=RHO
rho0=WMM(ID)*(AN-ANE)
c WRITE(6,601) IDens,TEMP(ID),DENS(ID),ane,rho0,an
else if(idens.eq.2) then
CALL RHONEN(ID,TEMP(ID),RHO,AN,ANE)
DENS(ID)=RHO
ANE=ELEC(ID)
rho0=WMM(ID)*(AN-ANE)
c WRITE(6,601) idens,TEMP(ID),DENS(ID),ane,rho0,an
end if
c 601 FORMAT(' **densit** t,rho,ne,rho0,an',I3,0PF10.1,1P5D11.3)
c 602 FORMAT(' **densit** t,rho,ne',I3,0PF10.1,1P5D11.3)
CALL INIMOD
c
CALL WNSTOR(ID)
CALL SABOLF(ID)
CALL RATMAT(ID,ES,BS)
CALL LEVSOL(ES,BS,POPLTE,NLEVEL)
DO J=1,NLEVEL
POPUL(J,ID)=POPLTE(J)
END DO
c
return
end
synspec/extracted/divhe2.f
+29
View File
@@ -0,0 +1,29 @@
SUBROUTINE DIVHE2(A,DIV)
C ========================
C
C Auxiliary procedure for evaluating approximate Stark profile
C for He II lines
C This procedure is quite analogous to DIVSTR for hydrogen;
C the only difference is a somewhat different definition
C of the parameter A ,ie. A for He II is equal to A for hydrogen
C minus ln(2)
C
INCLUDE 'PARAMS.FOR'
PARAMETER (UN=1.,TWO=2.,UNQ=1.25,UNH=1.5,TWH=2.5,FO=4.,FI=5.)
PARAMETER (CA=0.978,BL=5.821,AL=1.26,CX=0.28,DX=0.0001)
C
A=UNH*LOG(BETAD)-CA
IF(BETAD.LT.BL) RETURN
IF(A.GE.AL) THEN
X=SQRT(A)*(UN+UNQ*LOG(A)/(FO*A-FI))
ELSE
X=SQRT(CX+A)
ENDIF
DO 10 I=1,5
XN=X*(UN-(X*X-TWH*LOG(X)-A)/(TWO*X*X-TWH))
IF(ABS(XN-X).LE.DX) GO TO 20
X=XN
10 CONTINUE
20 DIV=X
RETURN
END
synspec/extracted/divstr.f
+34
View File
@@ -0,0 +1,34 @@
SUBROUTINE DIVSTR(A,DIV)
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
INCLUDE 'PARAMS.FOR'
PARAMETER (UN=1.,TWO=2.,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)
C
A=UNH*LOG(BETAD)-CA
IF(BETAD.LT.BL) RETURN
IF(A.GE.AL) THEN
X=SQRT(A)*(UN+UNQ*LOG(A)/(FO*A-FI))
ELSE
X=SQRT(CX+A)
ENDIF
DO I=1,5
XN=X*(UN-(X*X-TWH*LOG(X)-A)/(TWO*X*X-TWH))
IF(ABS(XN-X).LE.DX) GO TO 20
X=XN
END DO
20 DIV=X
RETURN
END
synspec/extracted/dwnfr0.f
+24
View File
@@ -0,0 +1,24 @@
SUBROUTINE DWNFR0(ID)
C =====================
C
C Auxiliary quantities for dissolved fractions
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
PARAMETER (UN=1.,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=CCOR*ANES/SQRT(TEMP(ID))
X=EXP(P4*LOG(UN+P3*ACOR))
DWC2(ID)=P2*X
A3=ACOR*ACOR*ACOR
DO 10 IZZ=1,MZZ
Z3(IZZ)=IZZ*IZZ*IZZ
DWC1(IZZ,ID)=P1*(X+P5*(IZZ-1.)*A3)
10 CONTINUE
RETURN
END
synspec/extracted/dwnfr1.f
+41
View File
@@ -0,0 +1,41 @@
SUBROUTINE DWNFR1(FR,FR0,ID,IZZ,DW1)
C ====================================
C
C dissolved fraction for frequency FR
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
PARAMETER (UN=1.,TKN=3.01,CKN=5.33333333,CB=8.59d14)
PARAMETER (SQFRH=5.734152D7)
parameter (a0=0.529177e-8,wa0=-3.1415926538/6.*a0*a0*a0)
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)
beta=beta*bergfc
BETA3=BETA*BETA*BETA
BETA32=SQRT(BETA3)
F=(DWC1(IZZ,ID)*BETA3)/(UN+DWC2(ID)*BETA32)
c
c contribution from neutral particles
c
xn2=xn*xn+un
xnh=0.
xnhe1=0.
if(ielh.gt.0) xnh=popul(nfirst(ielh),id)
if(ielhe1.gt.0) xnhe1=popul(nfirst(ielhe1),id)
w0=exp(wa0*xn2*xn2*xn2*(xnh+xnhe1))
W0=1.
c
DW1=UN-F/(UN+F)*w0
ELSE
DW1=UN
END IF
RETURN
END
synspec/extracted/eldens.f
+210
View File
@@ -0,0 +1,210 @@
SUBROUTINE ELDENS(ID,T,AN,ANE)
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 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
common/hydmol/anhmi,ahmol
common/hydato/ah,anh,anp
common/nerela/anerel
parameter (un=1.d0,two=2.d0,half=0.5d0)
DIMENSION R(3,3),S(3),P(3)
C
TK=BOLK*T
if(ifmol.gt.0.and.t.lt.tmolim) then
aein=an*anerel
call moleq(id,t,an,aein,ane,0)
anerel=ane/an
return
end if
c
QM=0.
Q2=0.
QP=0.
Q=0.
DQN=0.
TK=BOLK*T
THET=5.0404D3/T
C
C Coefficients entering ionization (dissociation) balance of:
C atomic hydrogen - QH;
C negative hydrogen ion - QM
C hydrogen molecule - Q2
C ion of hydrogen molecule - QP
C
IF(IATREF.EQ.IATH) THEN
QM=1.0353D-16/T/SQRT(T)*EXP(8762.9/T)
QH0=EXP((15.38287+1.5*LOG10(T)-13.595*THET)*2.30258509299405)
c
if(t.gt.16000.) then
ih2=0
else
ih2=1
QP=TK*EXP((-11.206998+THET*(2.7942767+THET*
* (0.079196803-0.024790744*THET)))*2.30258509299405)
Q2=TK*EXP((-12.533505+THET*(4.9251644+THET*
* (-0.056191273+0.0032687661*THET)))*2.30258509299405)
end if
END IF
C
C Initial estimate of the electron density
C
if(anerel.le.0.) then
if(t.gt.1.e4) then
anerel=0.5
else
if(elec(id).gt.0..and.dens(id).gt.0.) then
anerel=elec(id)/(elec(id)+dens(id)/wmm(id))
else
anerel=0.1
end if
end if
end if
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(ID,T,ANE,Q)
QH=QH0*2./PFSTD(1,1)
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) THEN
G2=QH/ANE
G3=0.
G4=0.
G5=0.
D=0.
E=0.
G3=QM*ANE
A=UN+G2+G3
D=G2-G3
IF(IT.LE.1) THEN
IF(IH2.EQ.0) THEN
F1=UN/A
FE=D/A+Q
ELSE
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
END IF
AH=ANE/FE
ANH=AH*F1
END IF
AE=ANH/ANE
GG=AE*QP
E=ANH*Q2
B=ANH*QM
C
C Matrix of the linearized system R, and the rhs vector S
C
R(1,1)=YTOT(ID)
c R(1,2)=0.
r(1,2)=-two*(anh*q2+gg)
R(1,3)=UN
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.*(anh*q2+GG)
R(3,3)=B-AE*(G2+TWO*GG)
S(1)=AN-ANE-YTOT(ID)*AH+anh*(anh*q2+gg)
S(2)=ANH*(D+GG)+Q*AH-ANE
S(3)=AH-ANH*(A+TWO*(anh*q2+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-7*AN
IF(ABS(DELNE/ANE).GT.1.D-6.AND.IT.LE.20) 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
IF(IATREF.EQ.IATH) THEN
c AHMOL=TWO*ANH*(ANH*Q2+ANH/ANE*QP)/AH
AHMOL=ANH*ANH*Q2
ANP=ANH/ANE*QH
ANHMI=ANH*ANE*QM
anhn=anh+anp+anhmi+2.*ahmol
wmm(id)=wmy(id)/(ytot(id)-ahmol/anhn)*hmass
END IF
C
RETURN
END
synspec/extracted/eospri.f
+247
View File
@@ -0,0 +1,247 @@
subroutine eospri
c =================
c
c Outprint of Equation of State parameters
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
common/moltst/pfmol(600,mdepth),anmol(600,mdepth),
* pfato(100,mdepth),anato(100,mdepth),
* pfion(100,mdepth),anion(100,mdepth)
common/hydmol/anhmi,ahmol
common/hydato/ah,anh,anp
common/ioniz2/anion2(30,mdepth)
dimension nelemx(38)
dimension amh2(5),xml(20),insm(20)
data nelemx/ 1, 2, 3, 4, 5, 6, 7, 8, 9,
* 11,12,13,14,15,16,17,19,20,
* 21,22,23,24,25,26,28,29,32,
* 35,37,38,39,40,41,53,56,57,58,60/
data amh2/1.13390E+01,-2.97499E+00,4.10842E-02,-3.58550E-03,
* 1.31844E-04/
data insm/2,3,4,5,6,7,8,12,17,25,29,30,32,34,122,126,134,
* 179,198,214/
data init/1/
c
c id=idstd
istp=1
if(ifeos.lt.0) istp=-ifeos
c
do id=1,nd,istp
t=temp(id)
ane=elec(id)
rho=dens(id)
ann = dens(id)/wmm(id)+elec(id)
c
if(ifmol.eq.0.or.t.gt.tmolim) then
it=0
10 continue
ann0=ann
it=it+1
call eldens(id,t,ann,ane)
anmol(1,id)=anhmi
anmol(2,id)=ahmol
anato(1,id)=anh
anion(1,id)=anp
hpop=dens(id)/wmy(id)/hmass
do i=1,nmetal
j=nelemx(i)
anato(j,id)=anato(j,id)*hpop
anion(j,id)=anion(j,id)*hpop
if(j.ge.2.and.j.le.30) anion2(j,id)=anion2(j,id)*hpop
end do
anato(1,id)=anh
anion(1,id)=anp
c wmm(id)=(wmy(id)+2.*anmol(2,id)/hpop)/ytot(id)*hmass
wmm(id)=wmy(id)/(ytot(id)-anmol(2,id)/hpop)*hmass
ann=dens(id)/wmm(id)+ane
if((ann-ann0)/ann0.gt.1.e-5) go to 10
end if
c
nmetal=38
write(*,*) ''
write(*,*) 'atomic number densities and partition functions'
write(*,*) ''
atot=0.
do i=1,nmetal
j=nelemx(i)
if(j.le.28)
* write(6,621) j,typat(j),anato(j,id),pfato(j,id)
atot=atot+anato(j,id)
end do
write(*,*) ''
write(*,*) 'ionic number densities and partition functions'
write(*,*) ''
ctot=0.
do i=1,nmetal
j=nelemx(i)
if(j.le.28)
* write(6,622) j,typat(j),anion(j,id),pfion(j,id)
atot=atot+anion(j,id)
ctot=ctot+anion(j,id)
end do
621 format(i4,a3,3x,1p2e12.4)
622 format(i4,a3,'+',2x,1p2e12.4)
c
if(ifmol.gt.0.and.t.le.tmolim) then
write(6,600)
do i=1,nmolec
if(anmol(i,id).gt.ann*1.e-15)
* write(6,601) i, cmol(i), anmol(i,id), pfmol(i,id)
atot=atot+anmol(i,id)
end do
end if
600 format(/ 'Molecular number densities and partition functions'/)
601 format(i4,1x,A8,1x,1pe12.4,1x,e12.4)
c
ahmi=1.0353e-16/t/sqrt(t)*exp(8762.9/t)*
* anato(1,id)*ane
c
c original B&C H2+
c
APLOGJ=amh2(5)
te=5040./t
DO K=1,4
KM5=5-K
APLOGJ=APLOGJ*TE + amh2(KM5)
END DO
tk=1.38054e-16*t
ph2=-aplogj+log10(anato(1,id)*anion(1,id))+2.*log10(tk)
anh2b=(10.**ph2)/tk
htot=anato(1,id)+anion(1,id)+anmol(1,id)+
* 2.*(anmol(2,id)+anmol(3,id))+anmol(4,id)+anmol(5,id)+
* anmol(12,id)+2.*anmol(13,id)+anmol(14,id)+
* anmol(15,id)+
* anmol(16,id)+anmol(17,id)+anmol(32,id)+anmol(34,id)+
* 4.*anmol(37,id)+2.*anmol(38,id)+3.*anmol(39,id)+
* 2.*anmol(40,id)+3.*anmol(41,id)+2.*anmol(57,id)+
* anmol(118,id)+anmol(133,id)+
* 2.*anmol(140,id)+3.*anmol(141,id)+4.*anmol(142,id)+
* anmol(148,id)+2.*anmol(149,id)+anmol(222,id)
ahe= (anato(2,id)+anion(2,id)+anion2(2,id))/htot
aca= (anato(6,id)+anion(6,id)+anion2(6,id))/htot
acm= (anmol(5,id)+anmol(6,id)+
* anmol(7,id)+2.*(anmol(8,id)+2.*anmol(13,id))+
* anmol(14,id)+2.*anmol(15,id)+anmol(20,id)+
* anmol(37,id)+anmol(38,id)+anmol(39,id)+
* anmol(44,id)+anmol(118,id)+anmol(119,id)+
* anmol(437,id)+anmol(453,id)
* )/htot
ana= (anato(7,id)+anion(7,id)+anion2(7,id))/htot
anm= (anmol(7,id)+2.*anmol(9,id)+anmol(11,id)+
* anmol(12,id)+anmol(14,id)+anmol(23,id)+
* anmol(24,id)+anmol(40,id)+anmol(41,id)+
* anmol(109,id)+anmol(152,id)+anmol(347,id)+
* anmol(438,id)+anmol(452,id)+anmol(454,id)
* )/htot
aoa= (anato(8,id)+anion(8,id)+anion2(8,id))/htot
aom= (anmol(3,id)+anmol(4,id)+
* anmol(6,id)+2.*anmol(10,id)+anmol(11,id)+anmol(25,id)+
* anmol(26,id)+anmol(29,id)+anmol(30,id)+anmol(31,id)+
* anmol(35,id)+2.*anmol(44,id)+anmol(49,id)+anmol(51,id)+
* anmol(54,id)+2.*anmol(56,id)+anmol(65,id)+
* 2.*anmol(66,id)+anmol(84,id)+anmol(109,id)+
* anmol(113,id)+anmol(115,id)+anmol(118,id)+
* anmol(119,id)+anmol(126,id)+anmol(134,id)+
* anmol(153,id)+anmol(179,id)+anmol(184,id)+
* 2.*anmol(185,id)+anmol(200,id)+anmol(216,id)+
* anmol(221,id)+2.*anmol(247,id)+anmol(292,id)+
* anmol(439,id)+anmol(453,id)+anmol(454,id)
* )/htot
ac=aca+acm
an=ana+anm
ao=aoa+aom
write(6,623) t,dens(id),ann,atot+ane,ane,ctot-anmol(1,id),
* anato(1,id),anion(1,id),
* anmol(1,id),anmol(2,id),
* anmol(312,id),anmol(426,id),anh2b,
* htot,
* anmol(1,id),ahmi,anmol(1,id)/ahmi,
* anato(6,id),anion(6,id),anmol(6,id),anmol(37,id),
* anato(7,id),anion(7,id),anmol(9,id),anmol(41,id),
* anato(8,id),anion(8,id),anmol(3,id),anmol(6,id),
* ahe,ahe/abndd(2,id),
* ac,ac/abndd(6,id),
* an,an/abndd(7,id),
* ao,ao/abndd(8,id)
act=ac*htot
ant=an*htot
aot=ao*htot
623 format(/'EOS useful quantities - summary'//
* 'T,rho ',f13.2,1pe13.5/
* 'N ',1p2e13.5/
* 'n_e ',1p2e13.5/
* 'H,H+,H-,H2 ',1p4e13.5/
* 'H2-,H2+,H2+b',1p3e13.5/
* 'Htot ',1pe13.5/
* 'H- ',1p3e13.5/
* 'C,C+,CO,CH4 ',1p4e13.5/
* 'N,N+,N2,NH3 ',1p4e13.5/
* 'O,O+,H2O,CO ',1p4e13.5/
* 'He/H ',1p2e13.5/
* 'C/H ',1p2e13.5/
* 'N/H ',1p2e13.5/
* 'O/H ',1p2e13.5/)
c
if(init.eq.1) then
write(52,625)
write(51,626)
write(53,653) (cmol(insm(i)),i=1,20)
write(54,654) (cmol(insm(i)),i=1,20)
c
625 format(' T rho w_mol Ne/Ntot N(Htot) '
* 'n(H) n(H2)',6x,
* 'a(He) a(C) a(N) a(O) molfr(C) molfr(N) molfr(O)'/)
c * 'a(He) a(C) a(N) a(O) n(C) n(CO) n(CH4)',5x,
c * 'n(N) n(N2) n(NH3) n(O) n(H2O) n(CO)'/)
init=0
end if
c
c write(51,624) t,dens(id),wmm(id)/hmass,ane/ann,
c * htot,anato(1,id)/htot,2.*anmol(2,id)/htot,
c * ahe/abndd(2,id),ac/abndd(6,id),an/abndd(7,id),ao/abndd(8,id),
c * anato(6,id)/act,anmol(6,id)/act,anmol(37,id)/act,
c * anato(7,id)/ant,2.*anmol(9,id)/ant,anmol(41,id)/ant,
c * anato(8,id)/aot,anmol(3,id)/aot,anmol(6,id)/aot
write(52,624) t,dens(id),wmm(id)/hmass,ane/ann,
* htot,anato(1,id),2.*anmol(2,id),
* ahe/abndd(2,id),ac/abndd(6,id),an/abndd(7,id),ao/abndd(8,id),
* acm/ac,anm/an,aom/ao
c * anato(6,id),anmol(6,id),anmol(37,id),
c * anato(7,id),anmol(9,id),anmol(41,id),
c * anato(8,id),anmol(3,id),anmol(6,id)
624 format(f8.1,1pe9.2,0pf8.5,1x,1p4e9.2,1x,0p4f8.5,1x,1p3e9.2,1x,
* 3e9.2,1x,3e9.2)
c
write(51,627) t,dens(id),wmm(id)/hmass,ann,ane,htot,
* anato(1,id),anion(1,id),anmol(1,id),anmol(2,id),anmol(312,id),
* anmol(426,id)
c * anmol(426,id),anh2b
626 format(' T rho w_mol N Ne N(Htot) ',
* 'N(H) N(H+) N(H-) N(H2) N(H2-) N(H2+)'/)
c * 'N(H) N(H+) N(H-) N(H2) N(H2-) N(H2+) N(H2+b)'/)
627 format(f8.1,1pe9.2,0pf8.5,1x,1p10e9.2)
c
if(ifmol.gt.0.and.t.le.tmolim) then
do i=1,20
im=insm(i)
xml(i)=log10(anmol(im,id)/pfmol(im,id))
end do
write(53,655) t,log10(dens(id)),(xml(i),i=1,20)
do i=1,20
im=insm(i)
xml(i)=log10(anmol(im,id)/htot)
c xml(i)=log10(anmol(im,id))
end do
write(54,655) t,log10(dens(id)),(xml(i),i=1,20)
end if
c
653 format(' log10(N/U)'/' T rho ',20a6/)
654 format(' log10[N/n(H)]'/' T rho ',20a6/)
655 format(2f6.1,1x,20f6.1)
c
end do
return
end
synspec/extracted/eps.f
+23
View File
@@ -0,0 +1,23 @@
FUNCTION EPS(T,ANE,ALAM,ION,N)
C ==============================
C
C NLTE PARAMETER EPSILON (COLLISIONAL/SPONTANEOUS DEEXCITATION)
C AFTER KASTNER, 1981, J.Q.S.R.T. 26, 377
C
INCLUDE 'PARAMS.FOR'
DATA CK0,CK1 /7.75E-8, 2.58E-8/
X=1.438E8/ALAM/T
XKT=12390./ALAM
TT=0.75*X
T1=TT+1.
A=4.36E7*XKT*XKT/(1.-EXP(-X))
IF(ION.EQ.1) GO TO 10
B=1.1+LOG(T1/TT)-0.4/T1/T1
C=X*B*SQRT(T)/XKT/XKT*ANE
IF(N.EQ.0) C=CK0*C
IF(N.NE.0) C=CK1*C
GO TO 20
10 C=2.16/T/SQRT(T)/X**1.68*ANE
20 EPS=C/(C+A)
RETURN
END
synspec/extracted/exopf.f
+78
View File
@@ -0,0 +1,78 @@
subroutine exopf(indmol,t,u)
c ============================
c
c oartition functions from EXOMOL for 32 molewcular species
c
INCLUDE 'PARAMS.FOR'
parameter (nmol=32)
character*4 filpf(nmol)
character*7 fil
character*6 fil1
character*1 fil0
character*17 fil5
character*18 fil6
dimension indtsu(nmol),ntemp(nmol),pf(nmol,10000)
c
data filpf/
* ' AlO',' C2',' CH',' CN',' CO',
* ' CS',' CaH',' CaO',' CrH',' FeH',
* ' H2',' HCl',' HF',' MgH',' MgO',
* ' N2',' NH',' NO',' NS',' NaH',
* ' OH',' PH',' SH',' SiH',' SiO',
* ' SiS',' TiH',' TiO',' VO',
^ ' H2O',' H2S',' CO2'/
data ntemp/
* 9, 10, 8, 3, 9, 3, 3, 8, 3, 10,
* 10, 5, 5, 3, 5, 9, 5, 5, 5, 5,
* 5, 4, 5, 5, 9, 5, 48, 8, 8, 10,
* 3, 5/
data indtsu/
* 134, 8, 5, 7, 6, 20, 34, 179, 198, 214,
* 2, 36, 33, 32, 126, 9, 12, 11, 23, 122,
* 4, 148, 16, 17, 25, 28, 315, 29, 30, 3,
* 57, 44/
data iread /1/
c
if(iread.eq.1) then
do i=1,nmol
ntemp(i)=ntemp(i)*1000
end do
ntemp(27)=ntemp(27)/10
do i=1,nmol
fil=filpf(i)//'.pf'
fil1=fil(2:)
fil0=fil1(:1)
if(fil0.eq.' ') then
fil5='data/EXOMOL/'//fil1(2:)
open(unit=67,file=fil5,status='old')
else
fil6=fil1
open(unit=67,file='data/EXOMOL/'//fil6,status='old')
end if
do j=1,ntemp(i)
read(67,*) tt,pf(i,j)
end do
close(67)
end do
iread=0
end if
c
ie=0
u=0.
do i=1,nmol
if(indtsu(i).eq.indmol) ie=i
end do
if(ie.eq.0) return
c
tmax=float(ntemp(ie))
if(t.le.tmax) then
j=int(t)
u=pf(ie,j)
else
call irwpf(0,0,indmol,tmax,umx)
call irwpf(0,0,indmol,t,uirw)
u=pf(ie,ntemp(ie))/umx*uirw
end if
c
return
end
synspec/extracted/expint.f
+18
View File
@@ -0,0 +1,18 @@
FUNCTION EXPINT(X)
C ==================
C
C First exponential integral function E1(X)
C
INCLUDE 'PARAMS.FOR'
C
IF(X.LE.1.0) THEN
EXPINT=-LOG(X)-0.57721566+X*(0.99999193+X*(-0.24991055
* +X*(0.05519968+X*(-0.00976004+X*0.00107857))))
ELSE
EXPINT=EXP(-X)*((0.2677734343+X*(8.6347608925+X*
* (18.059016973+X*(8.5733287401+X))))/
* (3.9584969228+X*(21.0996530827+X*
* (25.6329561486+X*(9.5733223454+X)))))/X
END IF
RETURN
END
synspec/extracted/extprf.f
+21
View File
@@ -0,0 +1,21 @@
FUNCTION EXTPRF(DLAM,IT,ILINE,ANEL,DLAST,PLAST)
C ===============================================
C
C Extrapolation in wavelengths in Shamey, or Barnard, Cooper,
C Smith tables
C Special formula suggested by Cooper
C
INCLUDE 'PARAMS.FOR'
DIMENSION W0(4,4)
DATA W0 / 1.460, 1.269, 1.079, 0.898,
* 6.130, 5.150, 4.240, 3.450,
* 4.040, 3.490, 2.960, 2.470,
* 2.312, 1.963, 1.624, 1.315/
C
WE=W0(IT,ILINE)*EXP(ANEL*2.3025851)*1.E-16
DLASTA=ABS(DLAST)
D52=DLASTA*DLASTA*SQRT(DLASTA)
F=D52*(PLAST-WE/3.14159/DLAST/DLAST)
EXTPRF=(WE/3.14159+F/SQRT(ABS(DLAM)))/DLAM/DLAM
RETURN
END
synspec/extracted/feautr.f
+40
View File
@@ -0,0 +1,40 @@
FUNCTION FEAUTR(FREQ,ID)
C ========================
C
C LYMAN-ALPHA STARK BROADENING AFTER N.FEAUTRIER
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION DL(20),F05(20),F10(20),F20(20),F40(20),X(4)
DATA F05 / 0.0537, 0.0964, 0.1330, 0.3105, 0.4585, 0.6772, 0.8229,
* 0.8556, 0.9250, 0.9618, 0.9733, 1.1076, 1.0644, 1.0525,
* 0.8841, 0.8282, 0.7541, 0.7091, 0.7164, 0.7672/
DATA F10 / 0.1986, 0.2764, 0.3959, 0.5740, 0.7385, 0.9448, 1.0292,
* 1.0317, 0.9947, 0.8679, 0.8648, 0.9815, 1.0660, 1.0793,
* 1.0699, 1.0357, 0.9245, 0.8603, 0.8195, 0.7928/
DATA F20 / 0.4843, 0.5821, 0.7003, 0.8411, 0.9405, 1.0300, 1.0029,
* 0.9753, 0.8478, 0.6851, 0.6861, 0.8554, 0.9916, 1.0264,
* 1.0592, 1.0817, 1.0575, 1.0152, 0.9761, 0.9451/
DATA F40 / 0.7862, 0.8566, 0.9290, 0.9915, 1.0066, 0.9878, 0.8983,
* 0.8513, 0.6881, 0.5277, 0.5302, 0.6920, 0.8607, 0.9111,
* 0.9651, 1.0793, 1.1108, 1.1156, 1.1003, 1.0839/
DATA DL / -150., -120., -90., -60., -40., -20., -10., -8., -4.,
* -2., 2., 4., 8., 10., 20., 40., 60., 90., 120., 150./
DLAM=2.997925E18/FREQ-1215.685
DO 10 I=2,20
IF(DLAM.LE.DL(I)) GO TO 20
10 CONTINUE
I=20
20 J=I-1
C=DL(J)-DL(I)
A=(DLAM-DL(I))/C
B=(DL(J)-DLAM)/C
X(1)=F05(J)*A+F05(I)*B
X(2)=F10(J)*A+F10(I)*B
X(3)=F20(J)*A+F20(I)*B
X(4)=F40(J)*A+F40(I)*B
J=JT(ID)
Y=TI0(ID)*X(J)+TI1(ID)*X(J-1)+TI2(ID)*X(J-2)
FEAUTR=0.5*(Y+1.)
RETURN
END
synspec/extracted/fingrd.f
+131
View File
@@ -0,0 +1,131 @@
subroutine fingrd
c =================
c
c storing the complete, interpolated, opacity table
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
real*4 absgrd(mttab,mrtab,mfgrid)
common/gridp0/tempg(mttab),densg(mttab,mrtab),elecgr(mttab,mrtab),
* densg0(mttab),temp1,ntemp,ndens,nden(mttab)
common/gridf0/wlgrid(mfgrid),nfgrid
common/fintab/absgrd
common/relabu/relabn(matom),popul0(mlevel,1)
character*(80) tabname
common/tabout/tabname,ibingr,idens
c
if(ifeos.gt.0) return
c
close(53)
iophmp=iophmi
if(ielhm.gt.0.and.relabn(1).gt.0.) iophmp=1
if(ibingr.eq.0) then
open(53,file=tabname,status='unknown')
write(53,600)
do iat=1,92
write(53,601) typat(iat),abnd(iat),abnd(iat)*relabn(iat)
end do
write(53,602) ifmol,tmolim
write(53,603) iophmp,ioph2p,iophem,iopch,iopoh,ioph2m,
* ioh2h2,ioh2he,ioh2h1,iohhe
if(idens.lt.10) then
ndens=nden(1)
write(53,611) nfgrid,ntemp,nden(1)
write(53,612) (log(tempg(i)),i=1,ntemp)
write(53,613) (log(densg(1,j)),j=1,nden(1))
write(53,614) ((log(elecgr(i,j)),j=1,nden(1)),i=1,ntemp)
do k = 1, nfgrid
write(53,615) k,wlgrid(k),2.997925e18/wlgrid(k)
do j = 1,ndens
write(53,616) (absgrd(i,j,k),i=1,ntemp)
end do
end do
else
write(53,611) nfgrid,ntemp,-nden(1)
write(53,610) (nden(i),i=1,ntemp)
write(53,612) (log(tempg(i)),i=1,ntemp)
write(53,622)
do i=1,ntemp
ndens=nden(i)
write(53,623) (log(densg(i,j)),j=1,ndens)
end do
write(53,624)
do i=1,ntemp
ndens=nden(i)
write(53,623) (log(elecgr(i,j)),j=1,ndens)
end do
do k = 1,nfgrid
write(53,615) k,wlgrid(k),2.997925e18/wlgrid(k)
do i=1,ntemp
ndens=nden(i)
write(53,616) (absgrd(i,j,k),j=1,ndens)
end do
end do
end if
600 format('opacity table with element abundances:'/
* 'element for EOS for opacities')
601 format(' ',a4,1p2e12.3)
602 format(/'molecules - ifmol,tmolim:'/,i4,f10.1)
603 format('additional opacities'/
* ' H- H2+ He- CH OH H2- CIA: H2H2 H2He H2H HHe'/
* 6i4,4x,4i4)
610 format(30i3)
611 format(/'number of frequencies, temperatures, densities:'
* /10x,3i10)
612 format('log temperatures'/(6F11.6))
613 format('log densities'/(6F11.6))
614 format('log electron densities from EOS'/(6f11.6))
615 format(/' *** frequency # : ',i8,f15.5/1pe20.8)
616 format((1p6e14.6))
c 621 format('log temperatures')
622 format('log densities')
623 format(6f14.6)
624 format('log electron densities from EOS')
end if
do iat=1,92
write(63) typat(iat),abnd(iat),abnd(iat)*relabn(iat)
end do
write(63) ifmol,tmolim
write(63) iophmp,ioph2p,iophem,iopch,iopoh,ioph2m,
* ioh2h2,ioh2he,ioh2h1,iohhe
if(idens.lt.10) then
ndens=nden(1)
write(63) nfgrid,ntemp,nden(1)
write(63) (log(tempg(i)),i=1,ntemp)
write(63) (log(densg(1,j)),j=1,nden(1))
write(63) ((log(elecgr(i,j)),j=1,nden(1)),i=1,ntemp)
do k = 1, nfgrid
write(63) 2.997925e18/wlgrid(k)
do j = 1,ndens
write(63) (absgrd(i,j,k),i=1,ntemp)
end do
end do
else
write(63) nfgrid,ntemp,-nden(1)
write(63) (nden(i),i=1,ntemp)
write(63) (log(tempg(i)),i=1,ntemp)
do i=1,ntemp
ndens=nden(i)
write(63) (log(densg(i,j)),j=1,ndens)
end do
do i=1,ntemp
ndens=nden(i)
write(63) (log(elecgr(i,j)),j=1,ndens)
end do
do k = 1,nfgrid
write(63) 2.997925e18/wlgrid(k)
do i=1,ntemp
ndens=nden(i)
write(63) (absgrd(i,j,k),j=1,ndens)
if(k.le.100) write(*,*) 'abs(1)',i,ndens,
* (absgrd(i,j,k),j=1,ndens)
end do
end do
end if
c end if
c
close(63)
return
end
synspec/extracted/frac1.f
+88
View File
@@ -0,0 +1,88 @@
subroutine frac1
c ================
c
include 'PARAMS.FOR'
include 'MODELP.FOR'
parameter (mtemp=100,melec=60,mion1=30)
dimension xxt(mdepth),xxe(mdepth)
dimension kt0(mdepth),kn0(mdepth)
common/fracop/frac(mtemp,melec,mion1),fracm(mtemp,melec),
* itemp(mtemp),ntt
c
do id=1,nd
xxt(id)=dlog10(temp(id))
kt0(id)=2*int(20.*xxt(id))
xxe(id)=dlog10(elec(id))
kn0(id)=int(2.*xxe(id))
end do
c
DO 20 IAT=1,30
iatnum=iat
call fractn(iatnum)
if(iatnum.le.0) goto 20
do id=1,nd
if(kt0(id).lt.itemp(1)) then
kt1=1
write(6,611) id,temp(id)
611 format(' (FRACOP) Extrapol. in T (low)',i4,f7.0)
goto 41
endif
if(kt0(id).ge.itemp(ntt)) then
kt1=ntt-1
write(6,612) id,temp(id)
612 format(' (FRACOP) Extrapol. in T (high)',i4,f12.0)
goto 41
endif
do 40 it=1,ntt
if(kt0(id).eq.itemp(it)) then
kt1=it
goto 41
endif
40 continue
41 continue
if(kn0(id).lt.1) then
kn1=1
goto 49
endif
if(kn0(id).ge.60) then
kn1=59
write(6,614) id,xxe(id)
614 format(' (FRACOP) Extrapol. in Ne (high)',i4,f9.4)
goto 49
endif
kn1=kn0(id)
49 continue
xt1=0.025*itemp(kt1)
dxt=0.05
at1=(xxt(id)-xt1)/dxt
xn1=0.5*kn1
dxn=0.5
an1=(xxe(id)-xn1)/dxn
do ion=1,mion1
x11=frac(kt1,kn1,ion)
x21=frac(kt1+1,kn1,ion)
x12=frac(kt1,kn1+1,ion)
x22=frac(kt1+1,kn1+1,ion)
x1221=x11*x21*x12*x22
if(x1221.eq.0.) then
xx1=x11+at1*(x21-x11)
xx2=x12+at1*(x22-x12)
rrx=xx1+an1*(xx2-xx1)
else
x11=dlog10(x11)
x21=dlog10(x21)
x12=dlog10(x12)
x22=dlog10(x22)
xx1=x11+at1*(x21-x11)
xx2=x12+at1*(x22-x12)
rrx=xx1+an1*(xx2-xx1)
rrx=exp(2.3025851*rrx)
endif
rrr(id,ion,iat)=rrx*abndd(iat,id)*
* dens(id)/wmm(id)/ytot(id)
end do
end do
20 CONTINUE
c
return
end
synspec/extracted/fractn.f
+155
View File
@@ -0,0 +1,155 @@
subroutine fractn(iatnum)
c =========================
c
implicit double precision (a-h,o-z)
parameter (mtemp=100,
* melec= 60,
* mion1=30,
* mdat = 17)
parameter (inp=71)
dimension frac0(-1:mion1),ioo(-1:mion1),idat(mion1)
dimension gg(mion1,mdat),g0(mion1),z0(-1:mion1)
dimension uu(mion1,mdat),u0(mion1)
dimension u6(6),u7(7),u8(8),u10(10),u11(11)
dimension u12(12),u13(13),u14(14),u16(16),u18(18),u20(20)
dimension u24(24),u25(25),u26(26),u28(28)
equivalence (u6(1),uu(1,3)),(u7(1),uu(1,4)),(u8(1),uu(1,5))
equivalence (u10(1),uu(1,6)),(u11(1),uu(1,7)),(u12(1),uu(1,8))
equivalence (u13(1),uu(1,9)),(u14(1),uu(1,10)),(u16(1),uu(1,11))
equivalence (u18(1),uu(1,12)),(u20(1),uu(1,13)),(u24(1),uu(1,14))
equivalence (u25(1),uu(1,15)),(u26(1),uu(1,16)),(u28(1),uu(1,17))
common/fracop/frac(mtemp,melec,mion1),fracm(mtemp,melec),
* itemp(mtemp),ntt
data idat / 1, 2, 0, 0, 0, 3, 4, 5, 0, 6,
* 7, 8, 9,10, 0,11, 0,12, 0,13,
* 0, 0, 0,14,15,16, 0,17, 0, 0/
data gg/2.,29*0.,2.,1.,28*0.,
* 2.,1.,2.,1.,6.,9.,24*0.,2.,1.,2.,1.,6.,9.,4.,23*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,22*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,20*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,19*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,18*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,17*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,16*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,14*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,6.,1.,
* 12*0.,2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,
* 6.,1.,2.,1.,10*0.,2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,
* 6.,9.,4.,9.,6.,1.,10.,21.,28.,25.,6.,7.,6*0.,
* 2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,
* 6.,1.,10.,21.,28.,25.,6.,7.,6.,5*0.,
* 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.,4*0.,
* 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.,0.,0./
data uu(1,1)/109.6787/
data uu(1,2)/198.3108/
data uu(2,2)/438.9089/
data u6/90.82,196.665,386.241,520.178,3162.395,3952.061/
data u7/117.225,238.751,382.704,624.866,789.537,4452.758,5380.089/
data u8/109.837,283.24,443.086,624.384,918.657,1114.008,5963.135,
* 7028.393/
data u10/173.93,330.391,511.8,783.3,1018.,1273.8,1671.792,
* 1928.462,9645.005,10986.876/
data u11/41.449,381.395,577.8,797.8,1116.2,1388.5,1681.5,2130.8,
* 2418.7,11817.061,13297.676/
data u12/61.671,121.268,646.41,881.1,1139.4,1504.3,1814.3,2144.7,
* 2645.2,2964.4,14210.261,15829.951/
data u13/48.278,151.86,229.446,967.8,1239.8,1536.3,1947.3,2295.4,
* 2663.4,3214.8,3565.6,16825.022,18584.138/
data u14/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/
data u16/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/
data u18/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/
data u20/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.41/
data u24/54.576,132.966,249.7,396.5,560.2,731.02,1291.9,1490.,
* 1688.,1971.,2184.,2404.,2862.,3098.52,8151.,8850.,
* 9560.,10480.,11260.,12070.,13180.,13882.,60344.,63675.9/
data u25/59.959,126.145,271.55,413.,584.,771.1,961.44,1569.,
* 1789.,2003.,2307.,2536.,2771.,3250.,3509.82,9152.,
* 9872.,10620.,11590.,12410.,13260.,14420.,15162.,
* 65660.,69137.4/
data u26/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.6/
data u28/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
if(idat(iatnum).eq.0) then
write(6,600) iatnum
600 format(' OP data for element no. ',i3,' do not exist')
iatnum=-1
return
end if
c
g0(iatnum+1)=1.
do i=1,iatnum
ig0=iatnum-i+1
g0(ig0)=gg(i,idat(iatnum))
u0(i)=uu(i,idat(iatnum))*1000.
enddo
c
if(iatnum.eq.1) open(inp,file='ioniz.dat',status='old')
do 10 it=1,mtemp
do 10 ie=1,melec
fracm(it,ie)=0.
do 10 ion=1,mion1
frac(it,ie,ion)=0.
10 continue
c
read(inp,*)
read(inp,*) it0,it1,itstp
ntt=(it1-it0)/itstp+1
c
do it=1,ntt
read(inp,*) itt,ie0,ie1,iestp
itemp(it)=itt
net=(ie1-ie0)/iestp+1
t=exp(2.3025851*0.025*itt)
safac0=sqrt(t)*t/2.07d-16
tkcm=0.69496*t
do ie=1,net
read(inp,601) iee,ion0,ion1,
* (ioo(i),frac0(i),i=ion0,min(ion1,ion0+3))
ane=exp(2.3025851*0.25*iee)
safac=safac0/ane
nio=ion1-ion0
if(nio.ge.3) then
nlin=nio/4
do ilin=1,nlin
read(inp,602) (ioo(i),frac0(i),
* i=ion0+4*ilin,min(ion1,ion0+4*ilin+3))
end do
end if
ieind=iee/2
do ion=ion0,ion1
if(ion.lt.iatnum) then
if(ion.eq.ion0) then
z0(ion)=g0(iatnum-ion)
else
z0(ion)=frac0(ion)/frac0(ion-1)*safac*z0(ion-1)
z0(ion)=z0(ion)*exp(-u0(iatnum-ion)/tkcm)
endif
frac(it,ieind,iatnum-ion)=frac0(ion)/z0(ion)
else
u0hm=6090.5
z0hm=frac0(ion)/frac0(ion-1)*safac
z0hm=z0hm*exp(-u0hm/tkcm)
fracm(it,ieind)=frac0(ion)/z0hm
end if
end do
end do
end do
601 format(3i4,2x,4(i4,1x,e9.3))
602 format(14x,4(i4,1x,e9.3))
return
end
synspec/extracted/gamhe.f
+69
View File
@@ -0,0 +1,69 @@
SUBROUTINE GAMHE(IND,T,ANE,ANP,ID,GAM)
C ======================================
C
C NEUTRAL HELIUM STARK BROADENING PARAMETERS
C AFTER DIMITRIJEVIC AND SAHAL-BRECHOT, 1984, J.Q.S.R.T. 31, 301
C OR FREUDENSTEIN AND COOPER, 1978, AP.J. 224, 1079 (FOR C(IND).GT.0)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION W(5,20),V(4,20),C(20)
C
C ELECTRONS T= 5000 10000 20000 40000 LAMBDA
C
DATA W / 5.990, 6.650, 6.610, 6.210, 3819.60,
* 2.950, 3.130, 3.230, 3.300, 3867.50,
* 0.000, 0.000, 0.000, 0.000, 3871.79,
* 0.142, 0.166, 0.182, 0.190, 3888.65,
* 0.000, 0.000, 0.000, 0.000, 3926.53,
* 1.540, 1.480, 1.400, 1.290, 3964.73,
* 41.600, 50.500, 57.400, 65.800, 4009.27,
* 1.320, 1.350, 1.380, 1.460, 4120.80,
* 7.830, 8.750, 8.690, 8.040, 4143.76,
* 5.830, 6.370, 6.820, 6.990, 4168.97,
* 0.000, 0.000, 0.000, 0.000, 4437.55,
* 1.630, 1.610, 1.490, 1.350, 4471.50,
* 0.588, 0.620, 0.641, 0.659, 4713.20,
* 2.600, 2.480, 2.240, 1.960, 4921.93,
* 0.627, 0.597, 0.568, 0.532, 5015.68,
* 1.050, 1.090, 1.110, 1.140, 5047.74,
* 0.277, 0.298, 0.296, 0.293, 5875.70,
* 0.714, 0.666, 0.602, 0.538, 6678.15,
* 3.490, 3.630, 3.470, 3.190, 4026.20,
* 4.970, 5.100, 4.810, 4.310, 4387.93/
C
C PROTONS T= 5000 10000 20000 40000
C
DATA V / 1.520, 4.540, 9.140, 10.200,
* 0.607, 0.710, 0.802, 0.901,
* 0.000, 0.000, 0.000, 0.000,
* 0.0396, 0.0434, 0.0476, 0.0526,
* 0.000, 0.000, 0.000, 0.000,
* 0.507, 0.585, 0.665, 0.762,
* 0.930, 1.710, 13.600, 27.200,
* 0.288, 0.325, 0.365, 0.410,
* 1.330, 6.800, 12.900, 14.300,
* 1.100, 1.370, 1.560, 1.760,
* 0.000, 0.000, 0.000, 0.000,
* 1.340, 1.690, 1.820, 1.630,
* 0.128, 0.143, 0.161, 0.181,
* 2.040, 2.740, 2.950, 2.740,
* 0.187, 0.210, 0.237, 0.270,
* 0.231, 0.260, 0.291, 0.327,
* 0.0591, 0.0650, 0.0719, 0.0799,
* 0.231, 0.260, 0.295, 0.339,
* 2.180, 3.760, 4.790, 4.560,
* 1.860, 5.320, 7.070, 7.150/
DATA C /2*0.,1.83E-4,0.,1.13E-4,5*0.,1.6E-4,9*0./
C
IF(W(1,IND).EQ.0.) GO TO 10
J=JT(ID)
GAM=((TI0(ID)*W(J,IND)+TI1(ID)*W(J-1,IND)+TI2(ID)*W(J-2,IND))
* *ANE
* +(TI0(ID)*V(J,IND)+TI1(ID)*V(J-1,IND)+TI2(ID)*V(J-2,IND))
* *ANP)*1.884E3/W(5,IND)**2
IF(GAM.LT.0.) GAM=0.
RETURN
10 GAM=C(IND)*T**0.16667*ANE
RETURN
END
synspec/extracted/gaunt.f
+42
View File
@@ -0,0 +1,42 @@
FUNCTION GAUNT(I,FR)
C ====================
C
C Hydrogenic bound-free Gaunt factor for the principal quantum
C number I and frequency FR
C
INCLUDE 'PARAMS.FOR'
X=FR/2.99793E14
GAUNT=1.
IF(I.EQ.1) THEN
GAUNT=1.2302628+X*(-2.9094219E-3+X*(7.3993579E-6-8.7356966E-9*X))
*+(12.803223/X-5.5759888)/X
ELSE IF(I.EQ.2) THEN
GAUNT=1.1595421+X*(-2.0735860E-3+2.7033384E-6*X)+(-1.2709045+
*(-2.0244141/X+2.1325684)/X)/X
ELSE IF(I.EQ.3) THEN
GAUNT=1.1450949+X*(-1.9366592E-3+2.3572356E-6*X)+(-0.55936432+
*(-0.23387146/X+0.52471924)/X)/X
ELSE IF(I.EQ.4) THEN
GAUNT=1.1306695+X*(-1.3482273E-3+X*(-4.6949424E-6+2.3548636E-8*X))
*+(-0.31190730+(0.19683564-5.4418565E-2/X)/X)/X
ELSE IF(I.EQ.5) THEN
GAUNT=1.1190904+X*(-1.0401085E-3+X*(-6.9943488E-6+2.8496742E-8*X))
*+(-0.16051018+(5.5545091E-2-8.9182854E-3/X)/X)/X
ELSE IF(I.EQ.6) THEN
GAUNT=1.1168376+X*(-8.9466573E-4+X*(-8.8393133E-6+3.4696768E-8*X))
*+(-0.13075417+(4.1921183E-2-5.5303574E-3/X)/X)/X
ELSE IF(I.EQ.7) THEN
GAUNT=1.1128632+X*(-7.4833260E-4+X*(-1.0244504E-5+3.8595771E-8*X))
*+(-9.5441161E-2+(2.3350812E-2-2.2752881E-3/X)/X)/X
ELSE IF(I.EQ.8) THEN
GAUNT=1.1093137+X*(-6.2619148E-4+X*(-1.1342068E-5+4.1477731E-8*X))
*+(-7.1010560E-2+(1.3298411E-2 -9.7200274E-4/X)/X)/X
ELSE IF(I.EQ.9) THEN
GAUNT=1.1078717+X*(-5.4837392E-4+X*(-1.2157943E-5+4.3796716E-8*X))
*+(-5.6046560E-2+(8.5139736E-3-4.9576163E-4/X)/X)/X
ELSE IF(I.EQ.10) THEN
GAUNT=1.1052734+X*(-4.4341570E-4+X*(-1.3235905E-5+4.7003140E-8*X))
*+(-4.7326370E-2+(6.1516856E-3-2.9467046E-4/X)/X)/X
END IF
RETURN
END
synspec/extracted/getlal.f
+93
View File
@@ -0,0 +1,93 @@
subroutine getlal
c =================
c
c getlal reads in the profile functions for Lyman alpha, beta, gamma,
c and Balmer alpha, including the quasi-molecular satellites;
c valid for first and second order in neutral and ionized H density
c modified routine provided originally by D. Koester
c
c
INCLUDE 'PARAMS.FOR'
parameter (NXMAX=1400,NNMAX=5)
common/quasun/nunalp,nunbet,nungam,nunbal
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
c
c Lyman alpha
c
nxalp=0
if(nunalp.gt.0) then
nunalp=67
open(unit=nunalp,file='./data/laquasi.dat',status='old')
read(nunalp,*) nxalp,stnnea,stncha,vneua,vchaa
do i=1,nxalp
read(nunalp,*) xlalp(i),(plalp(i,j),j=1,NNMAX)
end do
close(nunalp)
stnnea=10.0**stnnea
stncha=10.0**stncha
iwarna=0
close(nunalp)
write(*,*)
write(*,*) ' read quasi-molecular data for L alpha'
end if
c
c Lyman beta
c
nxbet=0
if(nunbet.gt.0) then
nunbet=67
open(unit=nunbet,file='./data/lbquasi.dat',status='old')
read(nunbet,*) nxbet,stnneb,stnchb,vneub,vchab
do i=1,nxbet
read(nunbet,*) xlbet(i),(plbet(i,j),j=1,NNMAX)
end do
close(nunbet)
stnneb=10.0**stnneb
stnchb=10.0**stnchb
iwarnb=0
write(*,*) ' read quasi-molecular data for L beta'
end if
c
c Lyman gamma
c
nxgam=0
if(nungam.gt.0) then
nungam=67
open(unit=nunalp,file='./data/lgquasi.dat',status='old')
read(nungam,*) nxgam,stnneg,stnchg,vneug,vchag
do i=1,nxgam
read(nungam,*) xlgam(i),(plgam(i,j),j=1,NNMAX)
end do
close(nungam)
stnneg=10.0**stnneg
stnchg=10.0**stnchg
iwarng=0
write(*,*) ' read quasi-molecular data for L gamma'
end if
c
c Balmer alpha
c
nxbal=0
if(nunbal.gt.0) then
nunbal=67
open(unit=nunalp,file='./data/lhquasi.dat',status='old')
read(nunbal,*) nxbal,stnnec,stnchc,vneuc,vchac
do i=1,nxbal
read(nunbal,*) xlbal(i),(plbal(i,j),j=1,NNMAX)
end do
close(nunbal)
stnnec=10.0**stnnec
stnchc=10.0**stnchc
iwarnc=0
write(*,*) ' read quasi-molecular data for H alpha'
end if
write(*,*)
return
end
synspec/extracted/getwrd.f
+47
View File
@@ -0,0 +1,47 @@
SUBROUTINE GETWRD(TEXT,K0,K1,K2)
C
C FINDS NEXT WORD IN TEXT FROM INDEX K0. NEXT WORD IS TEXT(K1:K2)
C THE NEXT WORD STARTS AT THE FIRST ALPHANUMERIC CHARACTER AT K0
C OR AFTER. IT ENDS WITH THE LAST ALPHANUMERIC CHARACTER IN A ROW
C FROM THE START
C
C TAKEN FROM MULTI - M. CARLSSON (1976)
C
C INCLUDE 'IMPLIC.FOR'
PARAMETER (MSEPAR=7)
CHARACTER*(*) TEXT
CHARACTER SEPAR(MSEPAR)
DATA SEPAR/' ','(',')','=','*','/',','/
C
K1=0
DO 400 I=K0,LEN(TEXT)
IF(K1.EQ.0) THEN
DO 100 J=1,MSEPAR
IF(TEXT(I:I).EQ.SEPAR(J)) GOTO 200
100 CONTINUE
K1=I
C
C NOT START OF WORD
C
200 CONTINUE
ELSE
DO 300 J=1,MSEPAR
IF(TEXT(I:I).EQ.SEPAR(J)) GOTO 500
300 CONTINUE
ENDIF
400 CONTINUE
C
C NO NEW WORD. RETURN K1=K2=0
C
K1=0
K2=0
GOTO 999
C
C NEW WORD IN TEXT(K1:I-1)
C
500 CONTINUE
K2=I-1
C
999 CONTINUE
RETURN
END
synspec/extracted/gfree.f
+21
View File
@@ -0,0 +1,21 @@
FUNCTION GFREE(T,FR)
C ====================
C
C Hydrogenic free-free Gaunt factor, for temperature T and
C frequency FR
C
INCLUDE 'PARAMS.FOR'
THET=5040.4/T
IF(THET.LT.4.E-2) THET=4.E-2
X=FR/2.99793E14
IF(X.GT.1) GO TO 10
IF(X.LT.0.2) X=0.2
GFREE=(1.0823+2.98E-2/THET)+(6.7E-3+1.12E-2/THET)/X
RETURN
10 C1=(3.9999187E-3-7.8622889E-5/THET)/THET+1.070192
C2=(6.4628601E-2-6.1953813E-4/THET)/THET+2.6061249E-1
C3=(1.3983474E-5/THET+3.7542343E-2)/THET+5.7917786E-1
C4=3.4169006E-1+1.1852264E-2/THET
GFREE=((C4/X-C3)/X+C2)/X+C1
RETURN
END
synspec/extracted/ghydop.f
+50
View File
@@ -0,0 +1,50 @@
subroutine ghydop(id,i0,i1,pj,absoh,emish)
c ==========================================
c
c hydrogen opacity -- lines + pseudocontinuum from Gomez tables
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
COMMON/GOMOPA/frgtab(mfhtab),wlgtab(mfhtab),hydopg(mfhtab,mdepth),
* nugfreq
dimension absoh(mfreq),emish(mfreq),pj(40)
c
frg1=frgtab(1)
frg2=frgtab(nugfreq)
do 20 ij=i0,i1
fr=freq(ij)
if(fr.lt.frg1.or.fr.gt.frg2) go to 20
wla=2.997925e18/fr
frl=log10(fr)
c
if(ij.eq.i0) igf=nugfreq
10 continue
if(wla.gt.wlgtab(igf)) then
igf=igf-1
go to 10
end if
ig0=igf
if(ig0.le.2) ig0=2
ig1=igf-1
abl=(hydopg(ig1,id)-hydopg(ig0,id))*(wla-wlgtab(ig0))/
* (wlgtab(ig1)-wlgtab(ig0))+hydopg(ig0,id)
c
ii=1
if(freq(ij).gt.8.22013e14) then
pp=pj(1)*2.
else
pp=pj(2)*8.
end if
c
F15=FR*1.E-15
XKF=EXP(-4.79928e-11*FR/TEMP(ID))
XKFB=XKF*1.4743E-2*F15*F15*F15
oph=exp(abl)*pp
absoh(ij)=absoh(ij)+oph
emish(ij)=emish(ij)+oph*xkfb/(1.-xkf)
20 continue
c
return
end
synspec/extracted/gntk.f
+18
View File
@@ -0,0 +1,18 @@
FUNCTION GNTK(I,FR)
C ===================
C
C Hydrogenic bound-free Gaunt factor for the principal quantum
C number I and frequency FR (from Klaus Werner)
C
INCLUDE 'PARAMS.FOR'
GNTK=1.
IF(I.GT.3) GO TO 16
Y=1./FR
GO TO (1,2,3),I
1 GNTK=0.9916+Y*(2.71852D13-Y*2.26846D30)
GO TO 16
2 GNTK=1.1050-Y*(2.37490D14-Y*4.07677D28)
GO TO 16
3 GNTK=1.1010-Y*(0.98632D14-Y*1.03540D28)
16 RETURN
END
synspec/extracted/gomini.f
+95
View File
@@ -0,0 +1,95 @@
SUBROUTINE GOMINI
C =================
C
C Initialization and reading of the opacity table for thermal processe
C and Rayleigh scattering
c raytab: scattering opacities in cm^2/gm at 5.0872638d14 Hz (sodium D)
c (NOTE: Quantities in rayleigh.tab are in log_e)
C
c tempvec: array of temperatures
c rhovec: array of densities (gm/cm^3)
c nu: array of frequencies
c table: absorptive opacities in cm^2/gm
c (NOTE: Quantities in absorption.tab are in log_e)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
COMMON/GOMOPA/frgtab(mfhtab),wlgtab(mfhtab),hydopg(mfhtab,mdepth),
* nugfreq
common/gompar/hglim,ihgom
dimension temvec(mtabth),elevec(mtabeh),
* hydcrs(mtabth,mtabeh,mfhtab)
c
if(ihgom.eq.0) return
C
open(53,file='gomhyd.dat',status='old')
c
read(53,*) nugfreq,nugtemp,nugele
read(53,*)
read(53,*) (temvec(i),i=1,nugtemp)
read(53,*)
read(53,*) (elevec(j),j=1,nugele)
do it=1,nugtemp
temvec(it)=log(temvec(it)*1.161e4)
end do
c write(6,600) ihgom,nugfreq,nugtemp,nugele
c 600 format(' ihgom,nugfr,nugt,nuge ',4i4)
c
EGTAB1 = elevec(1)
EGTAB2 = elevec(nugele)
TGTAB1 = temvec(1)
TGTAB2 = temvec(nugtemp)
c
do k = 1, nugfreq
read(53,501) eneev
frgtab(k)=3.28805e15/13.595*eneev
wlgtab(k)=2.997925e18/frgtab(k)
do i = 1, nugtemp
read(53,*) (hydcrs(i,j,k),j=1,nugele)
end do
end do
frg1=frgtab(1)
frg2=frgtab(nugfreq)
c
501 format(40x,f17.14)
close(53)
C
c Interpolate to the actual temperature and electron density
c at the individual depth points
C
do 10 id=1,nd
if(elec(id).lt.HGLIM) go to 10
rl=log(elec(id))
tl=log(temp(id))
c
DELTAR=(RL-EGTAB1)/(EGTAB2-EGTAB1)*FLOAT(nugele-1)
JR = 1 + IDINT(DELTAR)
IF(JR.LT.1) JR = 1
IF(JR.GT.(nugele-1)) JR = nugele-1
r1i=elevec(jr)
r2i=elevec(jr+1)
dri=(RL-R1i)/(R2i-R1i)
if(JR .eq. 1) dri = 0.d0
C
DELTAT=(TL-TGTAB1)/(TGTAB2-TGTAB1)*FLOAT(nugtemp-1)
JP = 1 + IDINT(DELTAT)
IF(JP.LT.1) JP = 1
IF(JP.GT.nugtemp-1) JP = nugtemp-1
t1i=temvec(jp)
t2i=temvec(jp+1)
dti=(TL-T1i)/(T2i-T1i)
if(JP .eq. 1) dti = 0.d0
C
c loop over tabular frequencies
c
do jf=1,nugfreq
opr1=hydcrs(jp,jr,jf)+dti*
* (hydcrs(jp+1,jr,jf)-hydcrs(jp,jr,jf))
opr2=hydcrs(jp,jr+1,jf)+dti*
* (hydcrs(jp+1,jr+1,jf)-hydcrs(jp,jr+1,jf))
opac=opr1+dri*(opr2-opr1)
hydopg(jf,id)=opac+log(0.02654*4.1347e-15)
end do
10 continue
return
end
synspec/extracted/griem.f
+18
View File
@@ -0,0 +1,18 @@
SUBROUTINE GRIEM(ID,T,ANE,ION,FR,WGR,GAM)
C =========================================
C
C STARK DAMPING PARAMETER (GAM) CALCULATED FROM INPUT VALUES
C OF STARK WIDTHS FOR T=5000, 10000, 20000, 40000 K,
C AND FOR NE=1.E16 (FOR NEUTRALS) OR NE = 1.E17 (FOR IONS)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION WGR(4)
if(t.le.0.) return
J=JT(ID)
GAM=(TI0(ID)*WGR(J)+TI1(ID)*WGR(J-1)+TI2(ID)*WGR(J-2))
* *ANE*1.E-10*FR*1.E-10*FR*4.2E-14
IF(ION.GT.1) GAM=GAM*0.1
IF(GAM.LT.0.) GAM=0.
RETURN
END
synspec/extracted/gvdw.f
+32
View File
@@ -0,0 +1,32 @@
function gvdw(il,ilist,id)
c ==========================
c
c evaluation of the Van der Waals broadening parameter
c
c currently, two possibilities, determined by the value of the parameter
c ivdwli(ilist) - the mode of evaluation is the same for the whole line list
c = 0 - standard expression
c > 0 - evaluation using EXOMOL data, assuming breadening by H2 and He
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
c
c clasical, original expression
c
if(ivdwli(ilist).eq.0) then
gvdw=gwm(il,ilist)*vdwc(id)
return
end if
c
c EXOMOL form - broadening by H2 and He
c
c con= 1.e-6*c*k
con=4.1388e-12
t=temp(id)
anhe=rrr(id,1,2)
gvdw=con*t*((296./t)**gexph2(il,ilist)*gvdwh2(il,ilist)*anh2(id)+
* (296./t)**gexphe(il,ilist)*gvdwhe(il,ilist)*anhe)
return
end
synspec/extracted/h2minus.f
+99
View File
@@ -0,0 +1,99 @@
subroutine h2minus(t,anh2,ane,fr,oph2m)
C =======================================
C
C H- free-free opacity
C
C data from K L Bell 1980 J. Phys. B: At. Mol. Phys. 13 1859, Table 1
C The first column is theta=5040/T(K)
C The first row are names for each row corresponding to lambda (angstroms)
C The last row for 10.0 is linearly extrapolated
C The units of everything else is 10^26 cm4/dyn-1
C
INCLUDE 'PARAMS.FOR'
dimension FFthet(9),FFlamb(18),FFkapp(18,9)
data FFthet / 0.5, 0.8, 1.0, 1.2, 1.6, 2.0,
* 2.8, 3.6, 10.0 /
data nthet /9/
data FFlamb /151883., 113913., 91130., 60753.,
* 45565., 36452., 30377., 22783.,
* 18226., 15188., 11391., 9113., 7594.,
* 6509., 5696., 5063., 4142., 3505./
data nlamb /18/
data FFkapp /
* 7.16e+01,4.03e+01,2.58e+01,1.15e+01,6.47e+00,
* 4.15e+00,2.89e+00,1.63e+00,1.05e+00,7.36e-01,
* 4.20e-01,2.73e-01,1.92e-01,1.43e-01,1.10e-01,
* 8.70e-02,5.84e-02,4.17e-02,9.23e+01,5.20e+01,
* 3.33e+01,1.48e+01,8.37e+00,5.38e+00,3.76e+00,
* 2.14e+00,1.39e+00,9.75e-01,5.64e-01,3.71e-01,
* 2.64e-01,1.98e-01,1.54e-01,1.24e-01,8.43e-02,
* 6.10e-02,1.01e+02,5.70e+01,3.65e+01,1.63e+01,
* 9.20e+00,5.92e+00,4.14e+00,2.36e+00,1.54e+00,
* 1.09e+00,6.35e-01,4.22e-01,3.03e-01,2.30e-01,
* 1.80e-01,1.46e-01,1.01e-01,7.34e-02,1.08e+02,
* 6.08e+01,3.90e+01,1.74e+01,9.84e+00,6.35e+00,
* 4.44e+00,2.55e+00,1.66e+00,1.18e+00,6.97e-01,
* 4.67e-01,3.39e-01,2.59e-01,2.06e-01,1.67e-01,
* 1.17e-01,8.59e-02,1.18e+02,6.65e+01,4.27e+01,
* 1.91e+01,1.08e+01,6.99e+00,4.91e+00,2.84e+00,
* 1.87e+00,1.34e+00,8.06e-01,5.52e-01,4.08e-01,
* 3.17e-01,2.55e-01,2.10e-01,1.49e-01,1.11e-01,
* 1.26e+02,7.08e+01,4.54e+01,2.04e+01,1.16e+01,
* 7.50e+00,5.28e+00,3.07e+00,2.04e+00,1.48e+00,
* 9.09e-01,6.33e-01,4.76e-01,3.75e-01,3.05e-01,
* 2.53e-01,1.82e-01,1.37e-01,1.38e+02,7.76e+01,
* 4.98e+01,2.24e+01,1.28e+01,8.32e+00,5.90e+00,
* 3.49e+00,2.36e+00,1.74e+00,1.11e+00,7.97e-01,
* 6.13e-01,4.92e-01,4.06e-01,3.39e-01,2.49e-01,
* 1.87e-01,1.47e+02,8.30e+01,5.33e+01,2.40e+01,
* 1.38e+01,9.02e+00,6.44e+00,3.90e+00,2.68e+00,
* 2.01e+00,1.32e+00,9.63e-01,7.51e-01,6.09e-01,
* 5.07e-01,4.27e-01,3.16e-01,2.40e-01,2.19e+02,
* 1.26e+02,8.13e+01,3.68e+01,2.18e+01,1.46e+01,
* 1.08e+01,7.18e+00,5.24e+00,4.17e+00,3.00e+00,
* 2.29e+00,1.86e+00,1.55e+00,1.32e+00,1.13e+00,
* 8.52e-01,6.64e-01/
c locate position in temperature array
theta=5040./t
call locate(FFthet,nthet,theta,j,nthet)
if (j.eq.0) then
write(*,*)
write(*,'(a,f6.0,a)')
* 'Error: requested temperature is outside the ranges'
write(*,'(a)') 'h2minus:Stop'
write(*,*)
stop
endif
flamb=CL*1.D8/fr
c locate position in wavelength array
call locate(FFlamb,nlamb,flamb,i,nlamb)
c linearly interpolate in frequency and temperature
if (j.eq.nthet) then
c hold values constant if off high temperature end of table
y1=FFkapp(i,j)
y2=FFkapp(i+1,j)
tt=(flamb-FFlamb(i))/(FFlamb(i+1)-FFlamb(i))
Fkappa=(1.-tt)*y1 + tt*y2
else if (i.eq.0 .or. i.eq.nlines) then
c set values to 0 if off frequency table
Fkappa=0.0
else
c interpolate linearly within table
y1=FFkapp(i,j)
y2=FFkapp(i+1,j)
y3=FFkapp(i+1,j+1)
y4=FFkapp(i,j+1)
tt=(flamb-FFlamb(i))/(FFlamb(i+1)-FFlamb(i))
uu=(theta-FFthet(j))/(FFthet(j+1)-FFthet(j))
Fkappa=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 +
* (1.-tt)*uu*y4
endif
pe=ane*BOLK*t
oph2m= anh2 * 1.0E-26 *pe * Fkappa
return
end
synspec/extracted/h2opf.f
+22
View File
@@ -0,0 +1,22 @@
subroutine h2opf(t,pf)
c
c partition function for H2Ofrom EXOMOILA data
c
INCLUDE 'PARAMS.FOR'
dimension ttab(10000),pftab(10000)
c
data init /1/
c
if(init.eq.1) then
open(67,file='./data/h2o_exomol.pf',status='old')
do i=1,10000
read(67,*) ttab(i),pftab(i)
end do
close(67)
init=0
end if
c
itab=ifix(real(t))
pf=pftab(itab)+(t-ttab(itab))*(pftab(itab+1)-pftab(itab))
return
end
synspec/extracted/he1ini.f
+55
View File
@@ -0,0 +1,55 @@
SUBROUTINE HE1INI
C =================
C
C Initializes necessary arrays for evaluating the He I line
C absorption profiles using data calculated by Barnard, Cooper
C and Smith JQSRT 14, 1025, 1974 (for 4471)
C or Shamey, unpublished PhD thesis, 1969 (for other lines)
C
C This procedure is quite analogous to HYDINI for hydrogen lines
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
COMMON/PROHE1/PRFHE1(50,4,8,3),DLMHE1(50,8,3),XNEHE1(8),
* NWLAM(8,4)
COMMON/PRO447/PRF447(80,4,7),DLM447(80,7),XNE447(7)
DATA NT /4/
C
IH=67
OPEN(UNIT=IH,FILE='./data/he1prf.dat',STATUS='OLD')
C
C read the Barnard, Cooper, Smith tables for He I 4471 line,
C which have to be stored in file unit IH
C
NE=7
DO IE=1,NE
READ(IH,501) IL,WL0,IE1,XXNE,NWL
NWLAM(IE,1)=NWL
XNE447(IE)=LOG10(XXNE)
DO I=1,NWL
READ(IH,502) DLM447(I,IE),
* (PRF447(I,IT,IE),IT=1,NT)
END DO
END DO
C
C read Shamey's tables for He I 4387, 4026, and 4922 lines
C which have to be stored in file unit IH
C
NE=8
DO ILN=1,3
DO IE=1,NE
READ(IH,501) IL,WL0,IE1,XXNE,NWL
NWLAM(IE,ILN+1)=NWL
XNEHE1(IE)=LOG10(XXNE)
DO I=1,NWL
READ(IH,*) DLMHE1(I,IE,ILN),
* (PRFHE1(I,IT,IE,ILN),IT=1,NT)
END DO
END DO
END DO
CLOSE(IH)
C
501 FORMAT(/9X,I2,7X,F10.3,13X,I2,6X,E8.1,7X,I3/)
502 FORMAT(5E10.2)
RETURN
END
synspec/extracted/he2ini.f
+91
View File
@@ -0,0 +1,91 @@
SUBROUTINE HE2INI
C =================
C
C Initializes necessary arrays for evaluating the He II line
C absorption profiles using data calculated by Schoening and
C Butler
C
C This procedure is quite analogous to HYDINI for hydrogen lines
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
COMMON/HE2PRF/PRFHE2(19,MDEPTH,36),WLHE2(19,36),NWLHE2(19),
* ILHE2(19),IUHE2(19)
COMMON/HE2DAT/WL2(36,19),XT2(6),XNE2(11,19),PRF2(36,6,11),
* NWL2,NT2,NE2
DATA NLINE1 /19/
C
IH=67
OPEN(UNIT=IH,FILE='./data/he2prf.dat',STATUS='OLD')
C
DO ILINE=1,NLINE1
C
C read the Schoening and Butler tables, which have to be stored
C in file he23prf.dat
C
READ(IH,501) ILHE2(ILINE),IUHE2(ILINE)
IF(ILHE2(ILINE).LE.2) THEN
WL00=227.838
ELSE
WL00=227.7776
END IF
WL0=WL00/(1./ILHE2(ILINE)**2-1./IUHE2(ILINE)**2)
READ(IH,*) NWL2,(WL2(I,ILINE),I=1,NWL2)
READ(IH,503) NT2,(XT2(I),I=1,NT2)
READ(IH,504) NE2,(XNE2(I,ILINE),I=1,NE2)
READ(IH,500)
NWLHE2(ILINE)=NWL2
C
DO I=1,NWL2
IF(WL2(I,ILINE).LT.1.E-4) WL2(I,ILINE)=1.E-4
WLHE2(ILINE,I)=LOG10(WL2(I,ILINE))
END DO
C
DO IE=1,NE2
DO IT=1,NT2
READ(IH,500)
READ(IH,505) (PRF2(IWL,IT,IE),IWL=1,NWL2)
END DO
END DO
C
C coefficient for the asymptotic profile is determined from
C the input data
C
XCLOG=PRF2(NWL2,1,1)+2.5*LOG10(WL2(NWL2,ILINE))+31.831-
* XNE2(1,ILINE)-2.*LOG10(WL0)
XKLOG=0.6666667*(XCLOG-0.176)
XK=EXP(XKLOG*2.3025851)
DO ID=1,ND
T=TEMP(ID)+2.42E-8*VTURB(ID)
ANE=ELEC(ID)
TL=LOG10(T)
ANEL=LOG10(ANE)
F00=1.25E-9*ANE**0.666666667
FXK=F00*XK
DOP=1.E8/WL0*SQRT(4.12E7*T)
DBETA=WL0*WL0/2.997925E18/FXK
BETAD=DBETA*DOP
C
C interpolation to the actual values of temperature and electron
C density. The result is stored at array PRFHE2, which has indices
C ILINE - index of line
C ID - depth index
C IWL - wavelength index (notice that the wavelength grid may
C generally be different for different lines
C
DO IWL=1,NWL2
CALL INTHE2(PROF,TL,ANEL,IWL,ILINE)
PRFHE2(ILINE,ID,IWL)=PROF
END DO
END DO
END DO
CLOSE(IH)
C
500 FORMAT(1X)
501 FORMAT(//14X,I2,9X,I2/)
c 502 FORMAT(2X,I4,1P6E10.3,4(/5X,0P6F10.4)/5X,5F10.4)
503 FORMAT(2X,I4,F10.3,5F12.3)
504 FORMAT(2X,I4,F10.2,5F12.2/4X,5F12.2)
505 FORMAT(10F8.3)
RETURN
END
synspec/extracted/he2lin.f
+201
View File
@@ -0,0 +1,201 @@
SUBROUTINE HE2LIN(ID,I0,I1,ABSOH,EMISH)
C
C opacity and emissivity of He II lines (these which are not considered
C explicitly)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
PARAMETER (UN=1.,SIXTH=1./6.)
PARAMETER (CPP=4.1412E-16,CPJ=631479.)
PARAMETER (C00=1.25E-9,CDOP=1.284523E12,CID=0.02654,TWO=2.)
PARAMETER (CPJ4=CPJ/4.,AL10=2.3025851,CINV=UN/2.997925E18)
PARAMETER (CID1=0.01497)
DIMENSION PJ(80),FRHE(12),OSCHE2(19),PRF0(36),
* ABSO(MFREQ),EMIS(MFREQ),ABSOH(MFREQ),EMISH(MFREQ)
COMMON/HE2PRF/PRFHE2(19,MDEPTH,36),WLHE2(19,36),NWLHE2(19),
* ILHE2(19),IUHE2(19)
DATA FRHE /1.3158153D+16, 3.2895381D+15, 1.4624854D+15,
* 8.2261878D+14, 5.2647201D+14, 3.6560459D+14,
* 2.6860713D+14, 2.0565220D+14, 1.6249055D+14,
* 1.3161730D+14, 1.0877460D+14, 9.1400851D+13/
DATA OSCHE2/6.407E-1, 1.506E-1, 5.584E-2, 2.768E-2,
* 1.604E-2, 1.023E-2, 6.980E-3,
* 8.421E-1, 3.230E-2, 1.870E-2, 1.196E-2, 8.187E-3,
* 5.886E-3, 4.393E-3, 3.375E-3, 2.656E-3,
* 1.038, 1.793E-1, 6.549E-2/
C
I=ILWHE2
izz=2
DO IJ=I0,I1
ABSO(IJ)=0.
EMIS(IJ)=0.
ABSOH(IJ)=0.
EMISH(IJ)=0.
END DO
T=TEMP(ID)
T1=UN/T
SQT=SQRT(T)
ANE=ELEC(ID)
ANES=EXP(SIXTH*LOG(ANE))
C
C He III populations (either LTE or NLTE, depending on input model)
C
IF(IELHE2.GT.0) THEN
ANP=POPUL(NNEXT(IELHE2),ID)
NLHE2=NLAST(IELHE2)-NFIRST(IELHE2)+1
ELSE
ANP=RRR(ID,3,2)
NLHE2=0
END IF
C
C populations of the first 60 levels of He II
C
PP=CPP*ANE*ANP*T1/SQT
DO IL=1,60
X=IL*IL
IIL=NFIRST(IELHE2)+IL-1
IF(IL.LE.NLHE2) PJ(IL)=POPUL(IIL,ID)
IF(IL.GT.NLHE2) PJ(IL)=PP*EXP(CPJ/X*T1)*X*wnhe2(il,id)
END DO
C
C Frequency- and line-independent parameters for evaluating the
C asymptotic Stark profile
C
F00=3.906e-11*ANES*ANES*ANES*ANES
DOP0=1.E8*SQRT(4.12E7*T+VTURB(ID))
C
C -------------------------------------------------------------------
C overall loop over spectral series (only in the infrared region)
C -------------------------------------------------------------------
C
ISERU=ILWHE2
IF(ILWHE2.LE.3) THEN
ISERL=ILWHE2
ELSE IF(ILWHE2.LE.5) THEN
ISERL=ILWHE2-1
ELSE IF(ILWHE2.LE.7) THEN
ISERL=ILWHE2-2
ELSE IF(ILWHE2.LE.9) THEN
ISERL=ILWHE2-3
ELSE
ISERL=ILWHE2-4
END IF
C
DO IJ=I0,I1
ABSO(IJ)=0.
EMIS(IJ)=0.
END DO
C
DO 200 I=ISERL,ISERU
II=I*I
XII=UN/II
POPI=PJ(I)
C
C determination of which He II lines contribute in a current
C frequency region
C
M1=MHE10
IF(I.LT.ILWHE2.AND.FRHE(I).GT.FREQ(2)) THEN
M1=int(SQRT(FRHE(I)*II/(FRHE(I)-FREQ(2))))
END IF
M2=M1+1
IF(M1.LT.I+1) M1=I+1
IF(grav.lt.6..and.M1.LE.6.AND.I.EQ.2) GO TO 10
IF(grav.lt.6..and.M1.LE.4.AND.I.EQ.1) GO TO 10
M1=M1-1
M2=MHE20+3
IF(M2.GT.60) M2=60
10 CONTINUE
if(grav.gt.6.) then
m2=m2+5
m1=m1-3
if(m1.gt.i+6) m1=m1-3
end if
IF(M1.LT.I+1) M1=I+1
IF(M2.GT.60) M2=60
c A=0.
c E=0.
C
C loop over lines which contribute at given wavelength region
C
DO 100 J=M1,M2
ILINE=0
JJ=J*J
XJJ=UN/JJ
ABTRA=PJ(I)*WNHE2(J,ID)
EMTRA=PJ(J)*WNHE2(I,ID)*II*XJJ*EXP(CPJ*(XII-XJJ)*T1)
IF(I.LE.2) THEN
WLIN=227.838/(XII-1./JJ)
ELSE
WLIN=227.7776/(XII-1./JJ)
END IF
IF(I.EQ.2) THEN
IF(J.EQ.3.AND.IHE2PR.GT.0) ILINE=1
ELSE IF(I.EQ.3) THEN
IF(J.EQ.4.AND.IHE2PR.GT.0) ILINE=8
IF(J.GT.5.AND.J.LE.10.AND.IHE2PR.GT.0) ILINE=J-3
ELSE IF(I.EQ.4) THEN
IF(J.LE.7.AND.IHE2PR.GT.0) ILINE=J+12
IF(J.GE.8.AND.J.LE.15.AND.IHE2PR.GT.0) ILINE=J+1
END IF
IF(ILINE.GT.0) THEN
NWL=NWLHE2(ILINE)
DO IWL=1,NWL
PRF0(IWL)=PRFHE2(ILINE,ID,IWL)
END DO
FID=CID*OSCHE2(ILINE)
DO 50 IJ=I0,I1
AL=ABS(WLAM(IJ)-WLIN)
IF(AL.LT.1.E-4) AL=1.E-4
AL=LOG10(AL)
DO IWL=1,NWL-1
IW0=IWL
IF(AL.LE.WLHE2(ILINE,IWL+1)) GO TO 40
END DO
40 IW1=IW0+1
PRFF=(PRF0(IW0)*(WLHE2(ILINE,IW1)-AL)+PRF0(IW1)*
* (AL-WLHE2(ILINE,IW0)))/
* (WLHE2(ILINE,IW1)-WLHE2(ILINE,IW0))
SG=EXP(PRFF*AL10)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
50 CONTINUE
ELSE
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
c FID0=CID1*FIJ0/DOP
CALL DIVHE2(AD,DIV)
DO IJ=I0,I1
BETA=ABS(WLAM(IJ)-WL0)*FXK1
SG=STARKA(BETA,AD,DIV,UN)*FID
c if(fid0.gt.0.) then
c xd=beta/betad
c if(xd.lt.5.) sg=sg+exp(-xd*xd)*fid0
c end if
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END DO
END IF
100 CONTINUE
200 CONTINUE
C
C ----------------------------
C total opacity and emissivity
C ----------------------------
C
DO IJ=I0,I1
F=FREQ(IJ)
F15=F*1.E-15
XKF=EXP(-4.79928e-11*F*T1)
XKFB=XKF*1.4743E-2*F15*F15*F15
ABSOH(IJ)=ABSO(IJ)-XKF*EMIS(IJ)
EMISH(IJ)=XKFB*EMIS(IJ)
END DO
RETURN
END
synspec/extracted/he2liw.f
+196
View File
@@ -0,0 +1,196 @@
SUBROUTINE HE2LIW(ID,ABSOH,EMISH)
C =================================
C
C opacity and emissivity of He II lines (these which are not considered
C explicitly)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
PARAMETER (UN=1.,SIXTH=1./6.)
PARAMETER (CPP=4.1412E-16,CPJ=631479.)
PARAMETER (C00=1.25E-9,CDOP=1.284523E12,CID=0.02654,TWO=2.)
PARAMETER (CPJ4=CPJ/4.,AL10=2.3025851,CINV=UN/2.997925E18)
PARAMETER (CID1=0.01497)
DIMENSION PJ(80),FRHE(12),OSCHE2(19),PRF0(36),
* ABSO(MFREQ),EMIS(MFREQ),ABSOH(MFREQ),EMISH(MFREQ)
COMMON/HE2PRF/PRFHE2(19,MDEPTH,36),WLHE2(19,36),NWLHE2(19),
* ILHE2(19),IUHE2(19)
common/lasers/lasdel
DATA FRHE /1.3158153D+16, 3.2895381D+15, 1.4624854D+15,
* 8.2261878D+14, 5.2647201D+14, 3.6560459D+14,
* 2.6860713D+14, 2.0565220D+14, 1.6249055D+14,
* 1.3161730D+14, 1.0877460D+14, 9.1400851D+13/
DATA OSCHE2/6.407E-1, 1.506E-1, 5.584E-2, 2.768E-2,
* 1.604E-2, 1.023E-2, 6.980E-3,
* 8.421E-1, 3.230E-2, 1.870E-2, 1.196E-2, 8.187E-3,
* 5.886E-3, 4.393E-3, 3.375E-3, 2.656E-3,
* 1.038, 1.793E-1, 6.549E-2/
C
I=ILWHE2
izz=2
DO IJ=1,NFREQ
ABSO(IJ)=0.
EMIS(IJ)=0.
ABSOH(IJ)=0.
EMISH(IJ)=0.
END DO
IF(IFHE2.LE.0) RETURN
T=TEMP(ID)
T1=UN/T
SQT=SQRT(T)
ANE=ELEC(ID)
ANES=EXP(SIXTH*LOG(ANE))
C
C He III populations (either LTE or NLTE, depending on input model)
C
IF(IELHE2.GT.0) THEN
ANP=POPUL(NNEXT(IELHE2),ID)
NLHE2=NLAST(IELHE2)-NFIRST(IELHE2)+1
ELSE
ANP=RRR(ID,3,2)
NLHE2=0
END IF
C
C populations of the first 60 levels of He II
C
PP=CPP*ANE*ANP*T1/SQT
DO IL=1,60
X=IL*IL
IIL=NFIRST(IELHE2)+IL-1
IF(IL.LE.NLHE2) PJ(IL)=POPUL(IIL,ID)
IF(IL.GT.NLHE2) PJ(IL)=PP*EXP(CPJ/X*T1)*X*wnhe2(il,id)
END DO
C
C Frequency- and line-independent parameters for evaluating the
C asymptotic Stark profile
C
F00=3.906e-11*ANES*ANES*ANES*ANES
DOP0=1.E8*SQRT(4.12E7*T+VTURB(ID))
C
C -------------------------------------------------------------------
C overall loop over spectral series (only in the infrared region)
C -------------------------------------------------------------------
C
DO 300 IJ=1,NFREQ
ABSO(IJ)=0.
EMIS(IJ)=0.
IF(IHE2LW(IJ).le.0) GO TO 300
I=ILWHEW(IJ)
FR=FREQ(IJ)
ISERU=ILWHEW(IJ)
IF(ILWHEW(IJ).LE.3) THEN
ISERL=ILWHEW(IJ)
ELSE IF(ILWHEW(IJ).LE.5) THEN
ISERL=ILWHEW(IJ)-1
ELSE IF(ILWHEW(IJ).LE.7) THEN
ISERL=ILWHEW(IJ)-2
ELSE IF(ILWHEW(IJ).LE.9) THEN
ISERL=ILWHEW(IJ)-3
ELSE
ISERL=ILWHEW(IJ)-4
END IF
C
C
DO 200 I=ISERL,ISERU
II=I*I
XII=UN/II
PLTEI=PP*EXP(CPJ*T1*XII)*II
POPI=PJ(I)
C
C determination of which He II lines contribute in a current
C frequency region
C
M1=MHE10W(IJ)
IF(I.LT.ILWHEW(IJ).AND.FRHE(I).GT.FR) THEN
M1=int(SQRT(FRHE(I)*II/(FRHE(I)-FR)))
END IF
M2=M1+1
IF(M1.LT.I+1) M1=I+1
IF(grav.lt.6..and.M1.LE.6.AND.I.EQ.2) GO TO 10
IF(grav.lt.6..and.M1.LE.4.AND.I.EQ.1) GO TO 10
M1=M1-1
M2=MHE20W(IJ)+3
IF(M2.GT.60) M2=60
10 CONTINUE
if(grav.gt.6.) then
m2=m2+5
m1=m1-3
if(m1.gt.i+6) m1=m1-3
end if
IF(M1.LT.I+1) M1=I+1
IF(M2.GT.60) M2=60
C
C loop over lines which contribute at given wavelength region
C
DO 100 J=M1,M2
ILINE=0
JJ=J*J
XJJ=UN/JJ
ABTRA=PJ(I)*WNHE2(J,ID)
EMTRA=PJ(J)*WNHE2(I,ID)*II*XJJ*EXP(CPJ*(XII-XJJ)*T1)
IF(I.LE.2) THEN
WLIN=227.838/(XII-1./JJ)
ELSE
WLIN=227.7776/(XII-1./JJ)
END IF
IF(I.EQ.2) THEN
IF(J.EQ.3.AND.IHE2PR.GT.0) ILINE=1
ELSE IF(I.EQ.3) THEN
IF(J.EQ.4.AND.IHE2PR.GT.0) ILINE=8
IF(J.GT.5.AND.J.LE.10.AND.IHE2PR.GT.0) ILINE=J-3
ELSE IF(I.EQ.4) THEN
IF(J.LE.7.AND.IHE2PR.GT.0) ILINE=J+12
IF(J.GE.8.AND.J.LE.15.AND.IHE2PR.GT.0) ILINE=J+1
END IF
IF(ILINE.GT.0) THEN
NWL=NWLHE2(ILINE)
DO IWL=1,NWL
PRF0(IWL)=PRFHE2(ILINE,ID,IWL)
END DO
FID=CID*OSCHE2(ILINE)
AL=ABS(WLAM(IJ)-WLIN)
IF(AL.LT.1.E-4) AL=1.E-4
AL=LOG10(AL)
DO IWL=1,NWL-1
IW0=IWL
IF(AL.LE.WLHE2(ILINE,IWL+1)) GO TO 40
END DO
40 IW1=IW0+1
PRFF=(PRF0(IW0)*(WLHE2(ILINE,IW1)-AL)+PRF0(IW1)*
* (AL-WLHE2(ILINE,IW0)))/
* (WLHE2(ILINE,IW1)-WLHE2(ILINE,IW0))
SG=EXP(PRFF*AL10)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
ELSE
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
CALL DIVHE2(AD,DIV)
BETA=ABS(WLAM(IJ)-WL0)*FXK1
SG=STARKA(BETA,AD,DIV,UN)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END IF
100 CONTINUE
200 CONTINUE
C
C ----------------------------
C total opacity and emissivity
C ----------------------------
C
F=FREQ(IJ)
F15=F*1.E-15
XKF=EXP(-4.79928e-11*F*T1)
XKFB=XKF*1.4743E-2*F15*F15*F15
ABSOH(IJ)=ABSO(IJ)-XKF*EMIS(IJ)
EMISH(IJ)=XKFB*EMIS(IJ)
300 CONTINUE
RETURN
END
synspec/extracted/he2set.f
+92
View File
@@ -0,0 +1,92 @@
SUBROUTINE HE2SET
C =================
C
C Initialization procedure for treating the He II line opacity
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
dimension frhe(12)
DATA FRHE /1.3158153D+16, 3.2895381D+15, 1.4624854D+15,
* 8.2261878D+14, 5.2647201D+14, 3.6560459D+14,
* 2.6860713D+14, 2.0565220D+14, 1.6249055D+14,
* 1.3161730D+14, 1.0877460D+14, 9.1400851D+13/
C
C IHE2L=-1 - He II lines are excluded a priori
C
IHE2L=-1
IF(IFHE2.LE.0) RETURN
IF(FREQ(2).GE.1.315812E16) RETURN
AL0=2.997925E17/FREQ(1)
AL1=2.997925E17/FREQ(2)
c IF(AL0.GT.390.) RETURN
if(grav.lt.6.) then
IF(AL0.GT.31..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.26.1.AND.AL1.LT.29.8) RETURN
IF(AL0.GT.24.8.AND.AL1.LT.25.1) RETURN
IF(AL0.GT.122.1.AND.AL1.LT.162.9) RETURN
IF(AL0.GT.165.1.AND.AL1.LT.204.9) RETURN
IF(AL0.GT.109..AND.AL1.LT.120.9) RETURN
IF(AL0.GT.103..AND.AL1.LT.107.9) RETURN
IF(AL0.GT.99.7.AND.AL1.LT.102.) RETURN
IF(AL0.GT.320.8.AND.AL1.LT.364.4) RETURN
IF(AL0.GT.273.8.AND.AL1.LT.319.8) RETURN
IF(AL0.GT.251.6.AND.AL1.LT.272.8) RETURN
IF(AL0.GT.239.0.AND.AL1.LT.250.6) RETURN
IF(AL0.GT.231.1.AND.AL1.LT.238.0) RETURN
IF(AL0.GT.225.8.AND.AL1.LT.230.1) RETURN
else if(grav.lt.7.) then
IF(AL0.GT.33..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.124.1.AND.AL1.LT.160.9) RETURN
IF(AL0.GT.167.1.AND.AL1.LT.202.9) RETURN
IF(AL0.GT.111..AND.AL1.LT.118.9) RETURN
IF(AL0.GT.322.8.AND.AL1.LT.364.4) RETURN
IF(AL0.GT.275.8.AND.AL1.LT.317.8) RETURN
IF(AL0.GT.253.6.AND.AL1.LT.270.8) RETURN
IF(AL0.GT.241.0.AND.AL1.LT.248.6) RETURN
IF(AL0.GT.233.1.AND.AL1.LT.236.0) RETURN
else
IF(AL0.GT.39..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.134.1.AND.AL1.LT.150.9) RETURN
IF(AL0.GT.177.1.AND.AL1.LT.202.9) RETURN
end if
C
C otherwise, He II lines are included
C
IHE2L=1
MHE10=60
MHE20=60
IF(AL1.LT.91.) THEN
ILWHE2=1
ELSE IF(AL0.LT.204.) THEN
ILWHE2=2
ELSE IF(AL0.LT.364.) THEN
ILWHE2=3
ELSE IF(AL0.LT.569.) THEN
ILWHE2=4
ELSE IF(AL0.LT.819.) THEN
ILWHE2=5
ELSE IF(AL0.LT.1116.) THEN
ILWHE2=6
ELSE IF(AL0.LT.1457.) THEN
ILWHE2=7
ELSE IF(AL0.LT.1844.) THEN
ILWHE2=8
ELSE IF(AL0.LT.2277.) THEN
ILWHE2=9
ELSE IF(AL0.LT.2756.) THEN
ILWHE2=10
ELSE IF(AL0.LT.3279.) THEN
ILWHE2=11
ELSE
ILWHE2=12
END IF
FRION=FRHE(ILWHE2)
FR1=FRION*ILWHE2*ILWHE2
IF(FRION.GT.FREQ(2)) MHE10=int(SQRT(FR1/(FRION-FREQ(2))))
IF(FRION.GT.FREQ(1)) MHE20=int(SQRT(FR1/(FRION-FREQ(1))) )
WRITE(6,601) ILWHE2,MHE20+1
601 FORMAT(1H0/ ' *** HE II LINES CONTRIBUTE'/
* ' THE NEAREST LINE ON THE SHORT-WAVELENGTH SIDE IS',
* I3,' TO ',I3/)
RETURN
END
synspec/extracted/he2sew.f
+86
View File
@@ -0,0 +1,86 @@
SUBROUTINE HE2SEW(IJ)
C =====================
C
C Initialization procedure for treating the He II line opacity
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
dimension frhe(12)
DATA FRHE /1.3158153D+16, 3.2895381D+15, 1.4624854D+15,
* 8.2261878D+14, 5.2647201D+14, 3.6560459D+14,
* 2.6860713D+14, 2.0565220D+14, 1.6249055D+14,
* 1.3161730D+14, 1.0877460D+14, 9.1400851D+13/
C
C IHE2L=-1 - He II lines are excluded a priori
C
IHE2LW(IJ)=-1
IF(IFHE2.LE.0) RETURN
FR=FREQ(IJ)
AL0=2.997925E17/FR
AL1=2.997925E17/FR
if(grav.lt.6.) then
IF(AL0.GT.31..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.26.1.AND.AL1.LT.29.8) RETURN
IF(AL0.GT.24.8.AND.AL1.LT.25.1) RETURN
IF(AL0.GT.122.1.AND.AL1.LT.162.9) RETURN
IF(AL0.GT.165.1.AND.AL1.LT.204.9) RETURN
IF(AL0.GT.109..AND.AL1.LT.120.9) RETURN
IF(AL0.GT.103..AND.AL1.LT.107.9) RETURN
IF(AL0.GT.99.7.AND.AL1.LT.102.) RETURN
IF(AL0.GT.320.8.AND.AL1.LT.364.4) RETURN
IF(AL0.GT.273.8.AND.AL1.LT.319.8) RETURN
IF(AL0.GT.251.6.AND.AL1.LT.272.8) RETURN
IF(AL0.GT.239.0.AND.AL1.LT.250.6) RETURN
IF(AL0.GT.231.1.AND.AL1.LT.238.0) RETURN
IF(AL0.GT.225.8.AND.AL1.LT.230.1) RETURN
else if(grav.lt.7.) then
IF(AL0.GT.33..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.124.1.AND.AL1.LT.160.9) RETURN
IF(AL0.GT.167.1.AND.AL1.LT.202.9) RETURN
IF(AL0.GT.111..AND.AL1.LT.118.9) RETURN
IF(AL0.GT.322.8.AND.AL1.LT.364.4) RETURN
IF(AL0.GT.275.8.AND.AL1.LT.317.8) RETURN
IF(AL0.GT.253.6.AND.AL1.LT.270.8) RETURN
IF(AL0.GT.241.0.AND.AL1.LT.248.6) RETURN
IF(AL0.GT.233.1.AND.AL1.LT.236.0) RETURN
else
IF(AL0.GT.39..AND.AL1.LT.91.1) RETURN
IF(AL0.GT.134.1.AND.AL1.LT.150.9) RETURN
IF(AL0.GT.177.1.AND.AL1.LT.202.9) RETURN
end if
C
C otherwise, He II lines are included
C
IHE2LW(IJ)=1
MHE10W(IJ)=60
MHE20W(IJ)=60
IF(AL1.LT.91.) THEN
ILWHEW(IJ)=1
ELSE IF(AL0.LT.204.) THEN
ILWHEW(IJ)=2
ELSE IF(AL0.LT.364.) THEN
ILWHEW(IJ)=3
ELSE IF(AL0.LT.569.) THEN
ILWHEW(IJ)=4
ELSE IF(AL0.LT.819.) THEN
ILWHEW(IJ)=5
ELSE IF(AL0.LT.1116.) THEN
ILWHEW(IJ)=6
ELSE IF(AL0.LT.1457.) THEN
ILWHEW(IJ)=7
ELSE IF(AL0.LT.1844.) THEN
ILWHEW(IJ)=8
ELSE IF(AL0.LT.2277.) THEN
ILWHEW(IJ)=9
ELSE IF(AL0.LT.2756.) THEN
ILWHEW(IJ)=10
ELSE IF(AL0.LT.3279.) THEN
ILWHEW(IJ)=11
ELSE
ILWHEW(IJ)=12
END IF
FRION=FRHE(ILWHEW(IJ))
FR1=FRION*ILWHEW(IJ)*ILWHEW(IJ)
IF(FRION.GT.FR) MHE10W(IJ)=int(SQRT(FR1/(FRION-FR)))
RETURN
END
synspec/extracted/hephot.f
+164
View File
@@ -0,0 +1,164 @@
FUNCTION HEPHOT(S,L,N,FREQ)
C ===========================
C
C EVALUATES HE I PHOTOIONIZATION CROSS SECTION USING SEATON
C FERNLEY'S CUBIC FITS TO THE OPACITY PROJECT CROSS SECTIONS
C UP TO SOME ENERGY "EFITM" IN THE RESONANCE-FREE ZONE. BEYOND
C THIS ENERGY LINEAR FITS TO LOG SIGMA IN LOG (E/E0) ARE USED.
C THIS EXTRAPOLATION SHOULD BE USED UP TO THE BEGINNING OF THE
C RESONANCE ZONE "XMAX", BUT AT PRESENT IT IS USED THROUGH IT.
C BY CHANGING A FEW LINES THAT ARE PRESENTLY COMMENTED OUT,
C FOR ENERGIES IN THE RESONANCE ZONE A VALUE OF 1/100 OF THE
C THRESHOLD CROSS SECTION IS USED -- THIS IS PURELY AD HOC AND
C ONLY A TEMPORARY MEASURE. OBVIOUSLY ANY OTHER VALUE OR FUNCTIONAL
C FORM CAN BE INSERTED HERE.
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 FREQ = FREQUENCY
C
C DGH JUNE 1988 JILA, slightly modified by I.H.
C
INCLUDE 'PARAMS.FOR'
INTEGER S,L,SS,LL
DIMENSION COEF(4,53),IST(3,2),N0(3,2),
* FL0(53),A(53),B(53),XFITM(53)
c DIMENSION XMAX(53)
C
DATA IST/1,36,20,11,45,28/
DATA N0/1,2,3,2,2,3/
C
DATA FL0/
. 2.521D-01,-5.381D-01,-9.139D-01,-1.175D+00,-1.375D+00,-1.537D+00,
.-1.674D+00,-1.792D+00,-1.896D+00,-1.989D+00,-4.555D-01,-8.622D-01,
.-1.137D+00,-1.345D+00,-1.512D+00,-1.653D+00,-1.774D+00,-1.880D+00,
.-1.974D+00,-9.538D-01,-1.204D+00,-1.398D+00,-1.556D+00,-1.690D+00,
.-1.806D+00,-1.909D+00,-2.000D+00,-9.537D-01,-1.204D+00,-1.398D+00,
.-1.556D+00,-1.690D+00,-1.806D+00,-1.909D+00,-2.000D+00,-6.065D-01,
.-9.578D-01,-1.207D+00,-1.400D+00,-1.558D+00,-1.692D+00,-1.808D+00,
.-1.910D+00,-2.002D+00,-5.749D-01,-9.352D-01,-1.190D+00,-1.386D+00,
.-1.547D+00,-1.682D+00,-1.799D+00,-1.902D+00,-1.995D+00/
C
DATA XFITM/
. 3.262D-01, 6.135D-01, 9.233D-01, 8.438D-01, 1.020D+00, 1.169D+00,
. 1.298D+00, 1.411D+00, 1.512D+00, 1.602D+00, 7.228D-01, 1.076D+00,
. 1.206D+00, 1.404D+00, 1.481D+00, 1.464D+00, 1.581D+00, 1.685D+00,
. 1.777D+00, 9.586D-01, 1.187D+00, 1.371D+00, 1.524D+00, 1.740D+00,
. 1.854D+00, 1.955D+00, 2.046D+00, 9.585D-01, 1.041D+00, 1.371D+00,
. 1.608D+00, 1.739D+00, 1.768D+00, 1.869D+00, 1.803D+00, 7.360D-01,
. 1.041D+00, 1.272D+00, 1.457D+00, 1.611D+00, 1.741D+00, 1.855D+00,
. 1.870D+00, 1.804D+00, 9.302D-01, 1.144D+00, 1.028D+00, 1.210D+00,
. 1.362D+00, 1.646D+00, 1.761D+00, 1.863D+00, 1.954D+00/
C
DATA A/
. 6.95319D-01, 1.13101D+00, 1.36313D+00, 1.51684D+00, 1.64767D+00,
. 1.75643D+00, 1.84458D+00, 1.87243D+00, 1.85628D+00, 1.90889D+00,
. 9.01802D-01, 1.25389D+00, 1.39033D+00, 1.55226D+00, 1.60658D+00,
. 1.65930D+00, 1.68855D+00, 1.62477D+00, 1.66726D+00, 1.83599D+00,
. 2.50403D+00, 3.08564D+00, 3.56545D+00, 4.25922D+00, 4.61346D+00,
. 4.91417D+00, 5.19211D+00, 1.74181D+00, 2.25756D+00, 2.95625D+00,
. 3.65899D+00, 4.04397D+00, 4.13410D+00, 4.43538D+00, 4.19583D+00,
. 1.79027D+00, 2.23543D+00, 2.63942D+00, 3.02461D+00, 3.35018D+00,
. 3.62067D+00, 3.85218D+00, 3.76689D+00, 3.49318D+00, 1.16294D+00,
. 1.86467D+00, 2.02110D+00, 2.24231D+00, 2.44240D+00, 2.76594D+00,
. 2.93230D+00, 3.08109D+00, 3.21069D+00/
C
DATA B/
.-1.29000D+00,-2.15771D+00,-2.13263D+00,-2.10272D+00,-2.10861D+00,
.-2.11507D+00,-2.11710D+00,-2.08531D+00,-2.03296D+00,-2.03441D+00,
.-1.85905D+00,-2.04057D+00,-2.02189D+00,-2.05930D+00,-2.03403D+00,
.-2.02071D+00,-1.99956D+00,-1.92851D+00,-1.92905D+00,-4.58608D+00,
.-4.40022D+00,-4.39154D+00,-4.39676D+00,-4.57631D+00,-4.57120D+00,
.-4.56188D+00,-4.55915D+00,-4.41218D+00,-4.12940D+00,-4.24401D+00,
.-4.40783D+00,-4.39930D+00,-4.25981D+00,-4.26804D+00,-4.00419D+00,
.-4.47251D+00,-3.87960D+00,-3.71668D+00,-3.68461D+00,-3.67173D+00,
.-3.65991D+00,-3.64968D+00,-3.48666D+00,-3.23985D+00,-2.95758D+00,
.-3.07110D+00,-2.87157D+00,-2.83137D+00,-2.82132D+00,-2.91084D+00,
.-2.91159D+00,-2.91336D+00,-2.91296D+00/
C
DATA ((COEF(I,J),I=1,4),J=1,10)/
. 8.734D-01,-1.545D+00,-1.093D+00, 5.918D-01, 9.771D-01,-1.567D+00,
.-4.739D-01,-1.302D-01, 1.174D+00,-1.638D+00,-2.831D-01,-3.281D-02,
. 1.324D+00,-1.692D+00,-2.916D-01, 9.027D-02, 1.445D+00,-1.761D+00,
.-1.902D-01, 4.401D-02, 1.546D+00,-1.817D+00,-1.278D-01, 2.293D-02,
. 1.635D+00,-1.864D+00,-8.252D-02, 9.854D-03, 1.712D+00,-1.903D+00,
.-5.206D-02, 2.892D-03, 1.782D+00,-1.936D+00,-2.952D-02,-1.405D-03,
. 1.845D+00,-1.964D+00,-1.152D-02,-4.487D-03/
DATA ((COEF(I,J),I=1,4),J=11,19)/
. 7.377D-01,-9.327D-01,-1.466D+00, 6.891D-01, 9.031D-01,-1.157D+00,
.-7.151D-01, 1.832D-01, 1.031D+00,-1.313D+00,-4.517D-01, 9.207D-02,
. 1.135D+00,-1.441D+00,-2.724D-01, 3.105D-02, 1.225D+00,-1.536D+00,
.-1.725D-01, 7.191D-03, 1.302D+00,-1.602D+00,-1.300D-01, 7.345D-03,
. 1.372D+00,-1.664D+00,-8.204D-02,-1.643D-03, 1.434D+00,-1.715D+00,
.-4.646D-02,-7.456D-03, 1.491D+00,-1.760D+00,-1.838D-02,-1.152D-02/
DATA ((COEF(I,J),I=1,4),J=20,27)/
. 1.258D+00,-3.442D+00,-4.731D-01,-9.522D-02, 1.553D+00,-2.781D+00,
.-6.841D-01,-4.083D-03, 1.727D+00,-2.494D+00,-5.785D-01,-6.015D-02,
. 1.853D+00,-2.347D+00,-4.611D-01,-9.615D-02, 1.955D+00,-2.273D+00,
.-3.457D-01,-1.245D-01, 2.041D+00,-2.226D+00,-2.669D-01,-1.344D-01,
. 2.115D+00,-2.200D+00,-1.999D-01,-1.410D-01, 2.182D+00,-2.188D+00,
.-1.405D-01,-1.460D-01/
DATA ((COEF(I,J),I=1,4),J=28,35)/
. 1.267D+00,-3.417D+00,-5.038D-01,-1.797D-02, 1.565D+00,-2.781D+00,
.-6.497D-01,-5.979D-03, 1.741D+00,-2.479D+00,-6.099D-01,-2.227D-02,
. 1.870D+00,-2.336D+00,-4.899D-01,-6.616D-02, 1.973D+00,-2.253D+00,
.-3.972D-01,-8.729D-02, 2.061D+00,-2.212D+00,-3.072D-01,-1.060D-01,
. 2.137D+00,-2.189D+00,-2.352D-01,-1.171D-01, 2.205D+00,-2.186D+00,
.-1.621D-01,-1.296D-01/
DATA ((COEF(I,J),I=1,4),J=36,44)/
. 1.129D+00,-3.149D+00,-1.910D-01,-5.244D-01, 1.431D+00,-2.511D+00,
.-3.710D-01,-1.933D-01, 1.620D+00,-2.303D+00,-3.045D-01,-1.391D-01,
. 1.763D+00,-2.235D+00,-1.829D-01,-1.491D-01, 1.879D+00,-2.215D+00,
.-9.003D-02,-1.537D-01, 1.978D+00,-2.213D+00,-2.066D-02,-1.541D-01,
. 2.064D+00,-2.220D+00, 3.258D-02,-1.527D-01, 2.140D+00,-2.225D+00,
. 6.311D-02,-1.455D-01, 2.208D+00,-2.229D+00, 7.977D-02,-1.357D-01/
DATA ((COEF(I,J),I=1,4),J=45,53)/
. 1.204D+00,-2.809D+00,-3.094D-01, 1.100D-01, 1.455D+00,-2.254D+00,
.-4.795D-01, 6.872D-02, 1.619D+00,-2.109D+00,-3.357D-01,-2.532D-02,
. 1.747D+00,-2.065D+00,-2.317D-01,-5.224D-02, 1.853D+00,-2.058D+00,
.-1.517D-01,-6.647D-02, 1.943D+00,-2.055D+00,-1.158D-01,-6.081D-02,
. 2.023D+00,-2.070D+00,-6.470D-02,-6.800D-02, 2.095D+00,-2.088D+00,
.-2.357D-02,-7.250D-02, 2.160D+00,-2.107D+00, 1.065D-02,-7.542D-02/
C
IF(L.GT.2) GO TO 20
C
C SELECT BEGINNING AND END OF COEFFICIENTS
C
SS=(S+1)/2
LL=L+1
NSL0=N0(LL,SS)
I=IST(LL,SS)+N-NSL0
C
C EVALUATE CROSS SECTION
C
FL=LOG10(FREQ/3.28805E15)
X=FL-FL0(I)
IF(X.GE.-0.001D0) THEN
IF(X.LT.XFITM(I)) THEN
P=COEF(4,I)
DO 10 K=1,3
P=X*P+COEF(4-K,I)
10 CONTINUE
HEPHOT=1.D-18*1.D1**P
ELSE
C OTHERWISE REMOVE INSTRUCTION AND 3 FOLLOWING "C"
C ELSE IF(X.LT.XMAX(I)) THEN
HEPHOT=1.D-18*1.D1**(A(I)+B(I)*X)
C ELSE
C HEPHOT=1.D-18*1.D1**(COEF(1,I)-2.0D0)
END IF
ELSE
HEPHOT=0.
END IF
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=2.D0*N*N
HEPHOT=2.815D29/FREQ/FREQ/FREQ/N**5*(2*L+1)*S/GN
RETURN
END
synspec/extracted/heset.f
+150
View File
@@ -0,0 +1,150 @@
SUBROUTINE HESET(IL,ALM,EXCL,EXCU,ION,IPRF0,ILWN,IUPN)
C ======================================================
C
C Auxiliary procedure for INISET - set up quantities:
C IPRF0 - index for the procedure evaluating standard absorption
C profile coefficient for He I lines - see GAMHE
C ILWN,IUPN - only in NLTE option is switched on;
C indices of the lower and upper level associated with
C the given line
C
C Input: IL - line index
C ALM - line wavelength in nm
C EXCL - excitation potential of the lower level (in cm**-1)
C EXCU - excitation potential of the upper level (in cm**-1)
C ION - ionisation degree (1=neutrals, 2=once ionized, etc.)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION JU(24),NU(24),IT(24)
DATA IT/1,1,0,1,0,0,0,1,0,0,0,1,1,0,0,0,1,0,1,0,0,0,0,0/
DATA NU/6,6,9,3,8,4,7,5,6,6,5,4,4,4,3,4,3,3,5,5,7,8,10,2/
DATA JU/15,3,5,9,5,3,5,3,5,1,1,15,3,5,3,1,15,5,15,5,1,1,1,9/
C
C ******* He I ***********
C
IF(ION.NE.1) GO TO 20
C
C switch IPRF0 - see GAMHE
C
IL1=IL
ALAM=ALM*10.
IPRF=0
IF(ABS(ALAM-3819.60).LT.1.) IPRF=1
IF(ABS(ALAM-3867.50).LT.1.) IPRF=2
IF(ABS(ALAM-3871.79).LT.1.) IPRF=3
IF(ABS(ALAM-3888.65).LT.1.) IPRF=4
IF(ABS(ALAM-3926.53).LT.1.) IPRF=5
IF(ABS(ALAM-3964.73).LT.1.) IPRF=6
IF(ABS(ALAM-4009.27).LT.1.) IPRF=7
IF(ABS(ALAM-4120.80).LT.1.) IPRF=8
IF(ABS(ALAM-4143.76).LT.1.) IPRF=9
IF(ABS(ALAM-4168.97).LT.1.) IPRF=10
IF(ABS(ALAM-4437.55).LT.1.) IPRF=11
IF(ABS(ALAM-4471.50).LT.1.) IPRF=12
IF(ABS(ALAM-4713.20).LT.1.) IPRF=13
IF(ABS(ALAM-4921.93).LT.1.) IPRF=14
IF(ABS(ALAM-5015.68).LT.1.) IPRF=15
IF(ABS(ALAM-5047.74).LT.1.) IPRF=16
IF(ABS(ALAM-5875.70).LT.1.) IPRF=17
IF(ABS(ALAM-6678.15).LT.1.) IPRF=18
IF(ABS(ALAM-4026.20).LT.1.) IPRF=19
IF(ABS(ALAM-4387.93).LT.1.) IPRF=20
IF(ABS(ALAM-4023.97).LT.1.) IPRF=21
IF(ABS(ALAM-3935.91).LT.1.) IPRF=22
IF(ABS(ALAM-3833.55).LT.1.) IPRF=23
IF(ABS(ALAM-10830.0).LT.1.) IPRF=24
IF(IPRF.GT.0.AND.IPRF.LE.20) IPRF0=IPRF
C
C Indices of NLTE levels associated with the given line
C
IF(INLTE.gt.5.OR.IELHE1.EQ.0) RETURN
N0I=NFIRST(IELHE1)
N1I=NLAST(IELHE1)
HC=CL*H
EION=ENION(N0I)/HC
ILW=0
IUN=0
NQL=0
IF(IPRF.GT.0) NQL=NU(IPRF)
DO 10 I=N0I,N1I
NQ=NQUANT(I)
EX=EION-ENION(I)/HC
IF(ABS(EXCL-EX).LT.100.) THEN
ILW=I
IGL=INT(G(I)+0.001)
END IF
IF(NQ.EQ.NQL) THEN
IG=INT(G(I)+0.001)
IF(IT(IPRF).EQ.0) THEN
IF(NQ.EQ.2.AND.IG.EQ.JU(IPRF)) IUN=I
IF(NQ.EQ.3) THEN
IF(IG.EQ.JU(IPRF)) THEN
IF(IG.EQ.1.OR.IG.EQ.5) IUN=I
IF(IG.EQ.3.AND.IGL.EQ.1) IUN=I
ELSE
IF(IG.EQ.9) IUN=I
END IF
END IF
IF(NQ.EQ.4) THEN
IF(IG.EQ.JU(IPRF)) THEN
IF(IG.EQ.1.OR.IG.EQ.5.OR.IG.EQ.7) IUN=I
IF(IG.EQ.3.AND.IGL.EQ.1) IUN=I
ELSE
IF(IG.EQ.16) IUN=I
END IF
END IF
IF(IG.EQ.25.OR.IG.EQ.36) IUN=I
IF(IG.EQ.49.OR.IG.EQ.64.OR.IG.EQ.81) IUN=I
IF(IG.EQ.100.OR.IG.EQ.121.OR.IG.EQ.144) IUN=I
ELSE
IF(NQ.EQ.3) THEN
IF(IG.EQ.JU(IPRF)) THEN
IF(IG.EQ.9.OR.IG.EQ.15) IUN=I
IF(IG.EQ.3.AND.IGL.EQ.9) IUN=I
ELSE
IF(IG.EQ.27) IUN=I
END IF
END IF
IF(NQ.EQ.4) THEN
IF(IG.EQ.JU(IPRF)) THEN
IF(IG.EQ.9.OR.IG.EQ.15.OR.IG.EQ.21) IUN=I
IF(IG.EQ.3.AND.IGL.EQ.9) IUN=I
ELSE
IF(IG.EQ.48) IUN=I
END IF
END IF
IF(IG.EQ.75) IUN=I
IF(IG.EQ.108.OR.IG.EQ.147.OR.IG.EQ.192) IUN=I
IF(IG.EQ.243.OR.IG.EQ.300.OR.IG.EQ.363) IUN=I
END IF
IF(NQ.EQ.2.AND.IG.EQ.16) IUN=I
IF(NQ.EQ.3.AND.IG.EQ.36) IUN=I
IF(NQ.EQ.4.AND.IG.EQ.64) IUN=I
IF(NQ.EQ.5.AND.IG.EQ.100) IUN=I
IF(NQ.EQ.6.AND.IG.EQ.144) IUN=I
IF(NQ.EQ.7.AND.IG.EQ.196) IUN=I
IF(NQ.EQ.8.AND.IG.EQ.256) IUN=I
IF(NQ.EQ.9.AND.IG.EQ.324) IUN=I
IF(NQ.EQ.10.AND.IG.EQ.400) IUN=I
END IF
10 CONTINUE
c print *, 'il,iprof,ilw,iupn',il,iprf,ilw,iun
ILWN=ILW
IUPN=IUN
C
C ******* He II ***********
C
20 IF(ION.NE.2.OR.IELHE2.LE.0) RETURN
N0I=NFIRST(IELHE2)
NLHE2=NLAST(IELHE2)-N0I+1
XL=SQRT(1./(1.-EXCL/438916.146))
ILW=INT(XL)
IF((FLOAT(ILW)-XL).LT.0.) ILW=ILW+1
XU=SQRT(1./(1.-EXCU/438916.146))
IUN=INT(XU)
IF((FLOAT(IUN)-XU).LT.0.) IUN=IUN+1
IF(ILW.LE.NLHE2) ILWN=ILW+N0I-1
IF(IUN.LE.NLHE2) IUPN=IUN+N0I-1
RETURN
END
synspec/extracted/hidalg.f
+74
View File
@@ -0,0 +1,74 @@
FUNCTION HIDALG(IB,FR)
C ======================
C
C Read table of wavelengths and photo-ionization cross-sections
C from Hidalgo (1968, Ap. J., 153, 981) for the species indicated by IB
C (Hidalgo's number = INDEX = -IB-100).
C Compute linearly interpolated value of the cross-section
C at the frequency FR.
C
INCLUDE 'PARAMS.FOR'
DIMENSION WL1(20),WL2(20),WLI(20),SIG0(20,24),SIGS(20)
C
DATA WL1 /
* 39.1, 80.9, 97.6,100.1,104.3,107.2,108.7,111.9,113.6,115.4,
* 117.1,119.0,124.8,126.9,129.1,131.3,133.6,136.0,138.5,141.1/
DATA WL2 /
* 68.5, 80.9,100.1,120.9,158.8,165.7,177.3,190.6,200.7,206.2,
* 211.9,218.0,224.5,231.3,246.3,5*0./
DATA SIG0 /
*120*0.,
*.0460,.2400,.3500,.3700,.4000,.4300,.4400,.4600,.4700,.4900,
*.5000,.5200,.5700,.6200, 6*0.,
* 80*0.,
*.0092,.1000,.1900,.2100,.2300,.2500,.2600,.2900,.3000,.3200,
*.3400,.3500,.4100,.4300,.4500,.4800,.5000,.5300,.5600,.5900,
* 20*0.,
*.3400,.4600,.6300,.7700,.9100,1.080, 14*0.,
* 20*0.,
*.0064,.1100,.2200,.4100,.9400,1.000,1.300,1.600, 12*0.,
* 80*0.,
*.0370,.0650,.1300,.2400,.5500,.6300,.7700,.9500,1.100,1.250,
* 10*0.,
* 40*0.,
*.0220,.0390,.0800,.1500,.3500,.4000,.4900,.6200,.7200,.7800,
*.8500,.9300,1.020,
* 7*0./
C
INDEX=-IB-100
NUM=20
IF(INDEX.GE.13.AND.INDEX.LE.27) NUM=15
DO 10 I=1,NUM
IF(INDEX.LT.13) WLI(I)=WL1(I)
IF(INDEX.GE.13) WLI(I)=WL2(I)
SIGS(I)=SIG0(I,INDEX)
10 CONTINUE
C
WLAM=2.997925E18/FR
IL=1
IR=NUM
DO 50 I=1,NUM-1
IF(WLAM.GE.WLI(I).AND.WLAM.LE.WLI(I+1)) THEN
IL=I
IR=I+1
GO TO 60
ENDIF
50 CONTINUE
C
C LINEAR INTERPOLATION:
C
60 SIGM=(SIGS(IR)-SIGS(IL))*(WLAM-WLI(IL))/(WLI(IR)-WLI(IL))
* + SIGS(IL)
C
C IF OUTSIDE WAVELENGTH RANGE SET TO FIRST(LAST) VALUE:
C
IF(WLAM.LE.WLI(1)) SIGM=SIGS(1)
IF(WLAM.GE.WLI(NUM)) SIGM=SIGS(NUM)
C
C IF LAST NON-ZERO SIG VALUES, NO INTERPOLATION:
C
c IF(SIGS(IR).EQ.0.) SIGM=SIGS(IL)
C
HIDALG=SIGM*1.E-18
RETURN
END
synspec/extracted/hydini.f
+191
View File
@@ -0,0 +1,191 @@
SUBROUTINE HYDINI
C
C Initializes necessary arrays for evaluating hydrogen line profiles
C from the Lemke, Tremblay-Bergeron, or Schoening-Butler tables
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
c DIMENSION WLINE(4,22)
DIMENSION IILW(100),IIUP(100)
CHARACTER*1 CHAR
DATA INIT /0/
C
IF(INIT.EQ.0) THEN
DO I=1,4
DO J=I+1,22
CALL STARK0(I,J,IZZ,XK,WL0,FIJ,FIJ0)
WLINE(I,J)=WL0
c OSCH(I,J)=FIJ+FIJ0
END DO
END DO
INIT=1
END IF
DO I=1,4
DO J=1,22
ILIN0(I,J)=0
END DO
END DO
C
C --------------------------------------------
C Schoening-Butler tables - for IHYDPR < 0
C --------------------------------------------
C
IF(IHYDPR.LT.0) THEN
IHYDPR=67
ILEMKE=0
NLINE=12
c
OPEN(UNIT=IHYDPR,FILE='./data/hydprf.dat',STATUS='OLD')
write(6,*) ' reading Schoening-Butler tables'
C
DO I=1,12
READ(IHYDPR,500)
END DO
DO 100 ILINE=1,NLINE
C
C read the tables, which have to be stored in file
C unit IHYDPR (which is the input parameter in the progarm)
C
READ(IHYDPR,501) I,J
IF(ILINE.EQ.12) J=10
WL0=WLINE(I,J)
ILIN0(I,J)=ILINE
READ(IHYDPR,*) CHAR,NWL,(WL(I,ILINE),I=1,NWL)
READ(IHYDPR,*) CHAR,NT,(XT(I,ILINE),I=1,NT)
READ(IHYDPR,*) CHAR,NE,(XNE(I,ILINE),I=1,NE)
READ(IHYDPR,500)
NWLH(ILINE)=NWL
NWLHYD(ILINE)=NWL
NTH(ILINE)=NT
NEH(ILINE)=NE
C
DO I=1,NWL
IF(WL(I,ILINE).LT.1.E-4) WL(I,ILINE)=1.E-4
WLHYD(ILINE,I)=LOG10(WL(I,ILINE))
END DO
C
DO IE=1,NE
DO IT=1,NT
READ(IHYDPR,500)
READ(IHYDPR,*) (PRF(IWL,IT,IE,ILINE),IWL=1,NWL)
END DO
END DO
C
C coefficient for the asymptotic profile is determined from
C the input data
C
XCLOG=PRF(NWL,1,1,ILINE)+2.5*LOG10(WL(NWL,ILINE))+31.5304-
* XNE(1,ILINE)-2.*LOG10(WL0)
XKLOG=0.6666667*(XCLOG-0.176)
XK=EXP(XKLOG*2.3025851)
C
DO ID=1,ND
C
C temperature is modified in order to account for the
C effect of turbulent velocity on the Doppler width
C
T=TEMP(ID)+6.06E-9*VTURB(ID)
ANE=ELEC(ID)
TL=LOG10(T)
ANEL=LOG10(ANE)
F00=1.25E-9*ANE**0.666666667
FXK=F00*XK
DOP=1.E8/WL0*SQRT(1.65E8*T)
DBETA=WL0*WL0/2.997925E18/FXK
BETAD=DBETA*DOP
C
C interpolation to the actual values of temperature and electron
C density. The result is stored at array PRFHYD, having indices
C ILINE (line number: 1 for L-alpha,..., 4 for H-delta, etc.);
C 5 for H-alpha,..., 8 for H-delta, etc.)
C ID - depth index
C IWL - wavelength index
C
DO IWL=1,NWL
CALL INTHYD(PROF,TL,ANEL,IWL,ILINE)
PRFHYD(ILINE,ID,IWL)=PROF
END DO
END DO
100 CONTINUE
CLOSE(IHYDPR)
C
500 FORMAT(1X)
501 FORMAT(12X,I1,9X,I1)
C
IHYDPR=-IHYDPR
RETURN
END IF
C
C ---------------------------------
C read Lemke or Tremblay tables
C ---------------------------------
C
if(ihydpr.lt.20) ihydpr=ihydpr+20
if(ihydpr.eq.21) then
open(unit=ihydpr,file='./data/lemke.dat',status='old')
write(6,641) ihydpr
else if(ihydpr.eq.22) then
open(unit=ihydpr,file='./data/tremblay.dat',status='old')
write(6,642) ihydpr
end if
641 format(' -----------'/
* ' reading Lemke tables; ihydpr =',i3,/
* ' -----------')
642 format(' -----------'/
* ' reading Tremblay tables; ihydpr =',i3,/
* ' -----------')
C
ILEMKE=1
READ(IHYDPR,*) NTAB
write(6,611) ntab
611 format(' ntab',i4)
DO ITAB=1,NTAB
ILINEB=ILINE
READ(IHYDPR,*) NLLY
DO ILI=1,NLLY
ILINE=ILINE+1
READ(IHYDPR,*) I,J,ALMIN,ANEMIN,TMIN,DLA,DLE,DLT,
* NWL,NE,NT
WL0=WLINE(I,J)
ILIN0(I,J)=ILINE
NWLH(ILINE)=NWL
NWLHYD(ILINE)=NWL
NTH(ILINE)=NT
NEH(ILINE)=NE
iilw(iline)=i
iiup(iline)=j
DO IWL=1,NWL
WL(IWL,ILINE)=ALMIN+(IWL-1)*DLA
WLHYD(ILINE,IWL)=WL(IWL,ILINE)
WL(IWL,ILINE)=EXP(2.3025851*WL(IWL,ILINE))
END DO
DO INE=1,NE
XNE(INE,ILINE)=ANEMIN+(INE-1)*DLE
END DO
DO IT=1,NT
XT(IT,ILINE)=TMIN+(IT-1)*DLT
END DO
END DO
c
DO ILI=1,NLLY
ILNE=ILINEB+ILI
NWL=NWLH(ILNE)
READ(IHYDPR,500)
DO INE=1,NEH(ILNE)
DO IT=1,NTH(ILNE)
READ(IHYDPR,*) QLT,(PRF(IWL,IT,INE,ILNE),IWL=1,NWL)
END DO
END DO
C
i=iilw(ilne)
j=iiup(ilne)
DO ID=1,ND
CALL HYDTAB(I,J,ID)
END DO
END DO
END DO
NLIHYD=ILNE
CLOSE(IHYDPR)
C
RETURN
END
synspec/extracted/hydlin.f
+369
View File
@@ -0,0 +1,369 @@
SUBROUTINE HYDLIN(ID,I0,I1,ABSOH,EMISH)
C =======================================
C
C opacity and emissivity of hydrogen lines
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
PARAMETER (FRH1=3.28805E15,FRH2=FRH1/4.,UN=1.,SIXTH=1./6.)
PARAMETER (CPP=4.1412E-16,CPJ=157803.)
PARAMETER (C00=1.25E-9,CDOP=1.284523E12,CID=0.02654,TWO=2.)
PARAMETER (CPJ4=CPJ/4.,AL10=2.3025851,CINV=UN/2.997925E18)
PARAMETER (CID1=0.01497)
common/quasun/nunalp,nunbet,nungam,nunbal
common/hhebrd/sthe,nunhhe
common/gompar/hglim,ihgom
DIMENSION PJ(40),PRF0(54),OSCH(4,22),
* ABSO(MFREQ),EMIS(MFREQ),ABSOH(MFREQ),EMISH(MFREQ)
dimension wlir(15),irlow(15),irupp(15)
DATA FRH /3.289017E15/
data wlir/
* 123680., 75005., 59066., 51273.,190570.,113060.,
* 87577., 75061.,277960.,162050.,123840.,105010.,
* 223340.,168760.,141790./
data irlow/4*6, 4*7, 4*8, 3*9/
data irupp/7,8,9,10,8,9,10,11,9,10,11,12,11,12,13/
data nlinir/15/
c
DATA INIT /0/
C
DO IJ=I0,I1
ABSOH(IJ)=0.
EMISH(IJ)=0.
END DO
c
if(iath.le.0.or.rrr(1,1,1).eq.0.) return
izz=1
C
IF(INIT.EQ.0) THEN
DO I=1,4
DO J=I+1,22
CALL STARK0(I,J,IZZ,XK,WL0,FIJ,FIJ0)
WLINE(I,J)=WL0
OSCH(I,J)=FIJ+FIJ0
END DO
END DO
INIT=1
END IF
DO IJ=I0,I1
ABSO(IJ)=0.
EMIS(IJ)=0.
END DO
c
if(ilowh.le.0) return
c
T=TEMP(ID)
T1=UN/T
SQT=SQRT(T)
ANE=ELEC(ID)
ANES=EXP(SIXTH*LOG(ANE))
TL=LOG10(T)
ANEL=LOG10(ANE)
C
C populations of the first 40 levels of hydrogen
C
ANP=POPUL(NKH,ID)
PP=CPP*ANE*ANP*T1/SQT
NLH=N1H-N0HN+1
c if(ifwop(n1h).lt.0) nlh=nlh-1
nlh=nlh-1
DO IL=1,50
X=IL*IL
IF(IL.LE.NLH) PJ(IL)=POPUL(N0HN+IL-1,ID)
IF(IL.GT.NLH) PJ(IL)=PP*EXP(CPJ/X*T1)*X*wnhint(il,id)
END DO
p2=pp*exp(cpj4*t1)*4.*wnhint(2,id)
c
C Frequency- and line-independent parameters for evaluating the
C asymptotic Stark profile
C
F00=C00*ANES*ANES*ANES*ANES
DOP0=1.E8*SQRT(1.65E8*T+VTURB(ID))
C
C -------------------------------------------------------------------
C overall loop over spectral series (only in the infrared region)
C -------------------------------------------------------------------
C
ISERL=ILOWH
ISERU=ILOWH
c
if(wlam(i0).gt.14000.) iseru=4
if(wlam(i0).gt.22700.) iseru=5
if(wlam(i0).gt.32800.) iseru=6
if(wlam(i0).gt.44660.) iseru=7
if(wlam(i0).gt.60000.) iserl=4
c
if(iserl.eq.3.and.iseru.eq.3.and.nunbal.gt.0) iserl=2
DO IJ=I0,I1
ABSO(IJ)=0.
EMIS(IJ)=0.
END DO
C
c ========================
c loop over spectral series
c ========================
c
DO I=ISERL,ISERU
c
c skip the following calculations if one uses the Gomez tables
c
if(ihgom.gt.0.and.elec(id).gt.hglim) then
if(i.ge.1.and.i.le.ihgom) then
call ghydop(id,i0,i1,pj,absoh,emish)
go to 200
end if
end if
c
II=I*I
XII=UN/II
POPI=PJ(I)
IF(I.EQ.1) FRH=3.28805E15
C
C determination of which hydrogen lines contribute in a current
C frequency region
C
M1=M10
IF(I.LT.ILOWH) M1=ILOWH-1
M2=M1+1
M1=M1-1
M2=M20+3
IF(M1.LT.I+1) M1=I+1
if(grav.gt.3.) then
m2=m2+5
m1=m1-3
if(m1.gt.i+6) m1=m1-3
end if
c new!
if(i.ge.3) then
m1=i+1
m2=i+40
end if
if(i.ge.4) m2=i+20
if(i.ge.6) m2=i+10
C
C loop over lines which contribute at given wavelength region
C
m1=min(m1,40)
m2=min(m2,40)
m1=max(m1,i+1)
m2=max(m2,i+2)
DO J=M1,M2
ILINE=0
JJ=J*J
XJJ=UN/JJ
ABTRA=PJ(I)*WNHINT(J,ID)
EMTRA=PJ(J)*WNHINT(I,ID)*II*XJJ*EXP(CPJ*(XII-XJJ)*T1)
if(i.le.2.and.j.le.i+2) then
abtra=pj(i)
emtra=pj(j)*wnhint(i,id)/wnhint(j,id)*
* ii*xjj*exp(cpj*(xii-xjj)*t1)
end if
IF(I.LE.4.AND.J.LE.22) ILINE=ILIN0(I,J)
c
c quasi-molecular opacity for Lyman-alpha and beta satellites
c
lquasi=i.eq.1.and.j.eq.2.and.nunalp.gt.0
lquasi=lquasi.or.i.eq.1.and.j.eq.3.and.nunbet.gt.0
lquasi=lquasi.or.i.eq.1.and.j.eq.4.and.nungam.gt.0
lquasi=lquasi.or.i.eq.2.and.j.eq.3.and.nunbal.gt.0
lalhhe=i.eq.1.and.j.eq.2.and.nunhhe.gt.0
if(lquasi) then
DO IJ=I0,I1
call allard(wlam(ij),popi,anp,sg,i,j)
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END DO
end if
ahe=0.
if(iathe.gt.0) ahe=popul(n0a(iathe),id)
if(lalhhe.and.ahe.gt.0.) then
rel=1./6.2831855
do ij=i0,i1
call lyahhe(wlam(ij),ahe,sg0)
sg=sg0*rel
abso(ij)=abso(ij)+sg*abtra
emis(ij)=emis(ij)+sg*emtra
end do
end if
c
c lines with special Stark broadening tables
c
IF(ILINE.GT.0) THEN
FID=CID*OSCH(I,J)
c
c switch to either original Lemke/Tremblay of Xenomorph
c
if(ilxen(i,j).eq.0.or.anel.lt.xnemin) then
c
c original Lemke/Tremblay
c
NWL=NWLHYD(ILINE)
DO IWL=1,NWL
PRF0(IWL)=PRFHYD(ILINE,ID,IWL)
END DO
DO IJ=I0,I1
AL=ABS(WLAM(IJ)-WLINE(I,J))
IF(AL.LT.1.E-4) AL=1.E-4
IF(ILEMKE.EQ.1) AL=AL/F00
AL=LOG10(AL)
DO 30 IWL=1,NWL-1
IW0=IWL
IF(AL.LE.WLHYD(ILINE,IWL+1)) GO TO 40
30 CONTINUE
40 IW1=IW0+1
PRFF=(PRF0(IW0)*(WLHYD(ILINE,IW1)-AL)+PRF0(IW1)*
* (AL-WLHYD(ILINE,IW0)))/
* (WLHYD(ILINE,IW1)-WLHYD(ILINE,IW0))
SG=EXP(PRFF*AL10)*FID
sg0=EXP(PRFF*AL10)
IF(ILEMKE.EQ.1) SG=SG*WLINE(I,J)**2*CINV/F00
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END DO
c
c XENOMORPH data for selected lines
c
else
ixn=ilxen(i,j)
nwl=nwlxen(ixn)
fr0l=2.997925e18/wline(i,j)
do ij=i0,i1
al=(freq(ij)-fr0l)/f00
if(abs(al).lt.1.e-4) al=1.e-4
all=log10(abs(al))
do 51 iwl=1,nwl-1
iw0=iwl
if(all.le.alxen(ixn,iwl+1)) go to 52
51 continue
52 iw1=iw0+1
if(al.gt.0.) then
prff=(prfb(ixn,id,iw0)*(alxen(ixn,iw1)-all)+
* prfb(ixn,id,iw1)*(all-alxen(ixn,iw0)))/
* (alxen(ixn,iw1)-alxen(ixn,iw0))
else
prff=(prfr(ixn,id,iw0)*(alxen(ixn,iw1)-all)+
* prfr(ixn,id,iw1)*(all-alxen(ixn,iw0)))/
* (alxen(ixn,iw1)-alxen(ixn,iw0))
end if
sg=exp(prff*al10)*fid/f00
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
end do
END IF
c
c lines without special Stark broadening tables
c
ELSE
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
if((wl0.le.wlam(i1).and.1.25*wl0.gt.wlam(i0)). or.
* (wl0.ge.wlam(i0).and.0.75*wl0.lt.wlam(i1))) then
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
c FID0=CID1*FIJ0/DOP
CALL DIVSTR(AD,DIV)
fac=two
if(lquasi) fac=un
DO IJ=I0,I1
fr=freq(ij)
BETA=ABS(WLAM(IJ)-WL0)*FXK1
IF(I.LT.5) THEN
SG=STARKA(BETA,AD,DIV,fac)*FID
if(iophli.eq.2.and.i.eq.1.and.j.eq.2)
* sg=sg*feautr(fr,id)
ELSE
SG=STARKIR(II,JJ,T,ANE,BETA)*FID
END IF
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END DO
END IF
END IF
END DO
END DO
C
C far infrared hydrogen lines
C
if(wlam(i1).gt.70000.) then
DO I=8,13
II=I*I
XII=UN/II
DO J=I+1,I+4
JJ=J*J
XJJ=UN/JJ
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
if((wl0.le.wlam(i1).and.1.5*wl0.gt.wlam(i0)). or.
* (wl0.ge.wlam(i0).and.0.5*wl0.lt.wlam(i1))) then
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
CALL DIVSTR(AD,DIV)
fac=two
DO IJ=I0,I1
fr=freq(ij)
BETA=ABS(WLAM(IJ)-WL0)*FXK1
SG=STARKIR(II,JJ,T,ANE,BETA)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END DO
END IF
END DO
END DO
END IF
200 continue
c
if(wlam(i1).gt.5.e5) then
do ij=i0,i1
fr=freq(ij)
do ilir=1,nlinir
if(wlam(ij).gt.wlir(ilir)*0.95.and.
* wlam(ij).lt.wlir(ilir)*1.05) then
j=irupp(ilir)
JJ=J*J
i=irlow(ilir)
II=I*I
XII=UN/II
XJJ=UN/JJ
ABTRA=PJ(I)*WNHINT(J,ID)
EMTRA=PJ(J)*WNHINT(I,ID)*II*XJJ*EXP(CPJ*(XII-XJJ)*T1)
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
CALL DIVSTR(AD,DIV)
fac=two
BETA=ABS(WLAM(IJ)-WL0)*FXK1
SG=STARKA(BETA,AD,DIV,fac)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
end if
end do
end do
end if
C
C ----------------------------
C total opacity and emissivity
C ----------------------------
C
DO IJ=I0,I1
F=FREQ(IJ)
F15=F*1.E-15
XKF=EXP(-4.79928e-11*F*T1)
XKFB=XKF*1.4743E-2*F15*F15*F15
ABSOH(IJ)=ABSO(IJ)-XKF*EMIS(IJ)
EMISH(IJ)=XKFB*EMIS(IJ)
END DO
RETURN
END
synspec/extracted/hydliw.f
+258
View File
@@ -0,0 +1,258 @@
SUBROUTINE HYDLIW(ID,ABSOH,EMISH)
C =================================
C
C opacity and emissivity of hydrogen lines
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
PARAMETER (FRH1=3.28805E15,FRH2=FRH1/4.,UN=1.,SIXTH=1./6.)
PARAMETER (CPP=4.1412E-16,CPJ=157803.)
PARAMETER (C00=1.25E-9,CDOP=1.284523E12,CID=0.02654,TWO=2.)
PARAMETER (CPJ4=CPJ/4.,AL10=2.3025851,CINV=UN/2.997925E18)
PARAMETER (CID1=0.01497)
common/lasers/lasdel
common/quasun/nunalp,nunbet,nungam,nunbal
DIMENSION PJ(40),PRF0(54),OSCH(4,22),
* ABSO(MFREQ),EMIS(MFREQ),ABSOH(MFREQ),EMISH(MFREQ)
DATA FRH /3.289017E15/
DATA INIT /0/
C
if(iath.le.0) return
izz=1
C
IF(INIT.EQ.0) THEN
DO I=1,4
DO J=I+1,22
CALL STARK0(I,J,IZZ,XK,WL0,FIJ,FIJ0)
WLINE(I,J)=WL0
OSCH(I,J)=FIJ+FIJ0
END DO
END DO
INIT=1
END IF
DO IJ=1,NFREQ
ABSO(IJ)=0.
EMIS(IJ)=0.
ABSOH(IJ)=0.
EMISH(IJ)=0.
END DO
T=TEMP(ID)
T1=UN/T
SQT=SQRT(T)
ANE=ELEC(ID)
ANES=EXP(SIXTH*LOG(ANE))
C
C populations of the first 40 levels of hydrogen
C
ANP=POPUL(NKH,ID)
PP=CPP*ANE*ANP*T1/SQT
NLH=N1H-N0HN+1
if(ifwop(n1h).lt.0) nlh=nlh-1
DO 5 IL=1,40
X=IL*IL
IF(IL.LE.NLH) PJ(IL)=POPUL(N0HN+IL-1,ID)
IF(IL.GT.NLH) PJ(IL)=PP*EXP(CPJ/X*T1)*X*wnhint(il,id)
5 CONTINUE
p2=pp*exp(cpj4*t1)*4.*wnhint(2,id)
C
C Frequency- and line-independent parameters for evaluating the
C asymptotic Stark profile
C
F00=C00*ANES*ANES*ANES*ANES
DOP0=1.E8*SQRT(1.65E8*T+VTURB(ID))
C
C -------------------------------------------------------------------
C overall loop over spectral series (only in the infrared region)
C -------------------------------------------------------------------
C
DO 300 IJ=1,NFREQ
IF(IHYLW(IJ).LE.0) GO TO 300
ISERL=ILOWHW(IJ)
ISERU=ILOWHW(IJ)
IF(WLAM(IJ).GT.17000..AND.WLAM(IJ).LE.21000.) THEN
ISERL=3
ISERU=4
ELSE IF(WLAM(IJ).GT.22700..AND.WLAM(IJ).LE.29000.) THEN
ISERL=4
ISERU=5
ELSE IF(WLAM(IJ).GT.32800..AND.WLAM(IJ).LE.37000.) THEN
ISERL=5
ISERU=6
ELSE IF(WLAM(IJ).GT.37000..AND.WLAM(IJ).LE.44600.) THEN
ISERL=4
ISERU=6
ELSE IF(WLAM(IJ).GT.44660..AND.WLAM(IJ).LE.58300.) THEN
ISERL=5
ISERU=7
ELSE IF(WLAM(IJ).GT.58300..AND.WLAM(IJ).LE.72000.) THEN
ISERL=6
ISERU=8
ELSE IF(WLAM(IJ).GT.72000..AND.WLAM(IJ).LE.73800.) THEN
ISERL=5
ISERU=8
ELSE IF(WLAM(IJ).GT.73800..AND.WLAM(IJ).LE.77000.) THEN
ISERL=5
ISERU=9
ELSE IF(WLAM(IJ).GT.77000.) THEN
ISERL=6
ISERU=9
END IF
C
if(iserl.eq.3.and.iseru.eq.3.and.nunbal.gt.0) iserl=2
C
ABSO(IJ)=0.
EMIS(IJ)=0.
DO 200 I=ISERL,ISERU
II=I*I
XII=UN/II
PLTEI=PP*EXP(CPJ*T1*XII)*II
POPI=PJ(I)
IF(I.EQ.1) FRH=3.28805E15
C
C determination of which hydrogen lines contribute in a current
C frequency region
C
M1=M10W(IJ)
IF(I.LT.ILOWHW(IJ)) M1=ILOWHW(IJ)-1
M2=M1+1
IF(M1.LT.I+1) M1=I+1
IF(grav.lt.3..and.M1.LE.16.AND.I.EQ.7) GO TO 10
IF(grav.lt.3..and.M1.LE.14.AND.I.EQ.6) GO TO 10
IF(grav.lt.3..and.M1.LE.12.AND.I.EQ.5) GO TO 10
IF(grav.lt.3..and.M1.LE.10.AND.I.EQ.4) GO TO 10
IF(grav.lt.3..and.M1.LE.8.AND.I.EQ.3) GO TO 10
IF(grav.lt.3..and.M1.LE.6.AND.I.EQ.2) GO TO 10
IF(grav.lt.3..and.M1.LE.4.AND.I.EQ.1) GO TO 10
M1=M1-1
M2=M20W(IJ)+3
IF(M1.LT.I+1) M1=I+1
10 CONTINUE
if(grav.gt.3.) then
m2=m2+5
m1=m1-3
if(m1.gt.i+6) m1=m1-3
end if
if(grav.gt.6.) then
m2=m2+2
m1=m1-1
if(m1.gt.i+6) m1=m1-1
end if
IF(M1.LT.I+1) M1=I+1
c if(m2.gt.30) then
c m2=m20W(IJ)+8
c m1=m1-4
c end if
IF(M2.GT.40) M2=40
c if(id.eq.1) write(6,666) i,m1,m2
c 666 format(/' hydrogen lines contribute - ilow=',i2,', iup from ',i3,
c * ' to',i3/)
C
A=0.
E=0.
C
C loop over lines which contribute at given wavelength region
C
DO 100 J=M1,M2
IF(I.EQ.1.AND.J.LE.5.AND.IOPHLI.LT.0) GO TO 100
ILINE=0
JJ=J*J
XJJ=UN/JJ
ABTRA=PJ(I)*WNHINT(J,ID)
EMTRA=PJ(J)*WNHINT(I,ID)*II*XJJ*EXP(CPJ*(XII-XJJ)*T1)
if(i.le.2.and.j.le.i+2) then
abtra=pj(i)
emtra=pj(j)*wnhint(i,id)/wnhint(j,id)*
* ii*xjj*exp(cpj*(xii-xjj)*t1)
end if
IF(I.LE.4.AND.J.LE.22) ILINE=ILIN0(I,J)
c
c quasi-molecular opacity for Lyman-alpha and beta satellites
c
lquasi=i.eq.1.and.j.eq.2.and.nunalp.gt.0
lquasi=lquasi.or.i.eq.1.and.j.eq.3.and.nunbet.gt.0
lquasi=lquasi.or.i.eq.1.and.j.eq.4.and.nungam.gt.0
lquasi=lquasi.or.i.eq.2.and.j.eq.3.and.nunbal.gt.0
if(lquasi) then
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
CALL DIVSTR(AD,DIV)
fr=freq(ij)
BETA=ABS(WLAM(IJ)-WL0)*FXK1
call allard(wlam(ij),popi,anp,sg,i,j)
sg=sg+STARKA(BETA,AD,DIV,UN)*FID
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
go to 100
end if
c
c lines with special Stark broadening tables
c
IF(ILINE.GT.0) THEN
NWL=NWLHYD(ILINE)
DO IWL=1,NWL
PRF0(IWL)=PRFHYD(ILINE,ID,IWL)
END DO
FID=CID*OSCH(I,J)
AL=ABS(WLAM(IJ)-WLINE(I,J))
IF(AL.LT.1.E-4) AL=1.E-4
IF(ILEMKE.EQ.1) AL=AL/F00
AL=LOG10(AL)
DO 30 IWL=1,NWL-1
IW0=IWL
IF(AL.LE.WLHYD(ILINE,IWL+1)) GO TO 40
30 CONTINUE
40 IW1=IW0+1
PRFF=(PRF0(IW0)*(WLHYD(ILINE,IW1)-AL)+PRF0(IW1)*
* (AL-WLHYD(ILINE,IW0)))/
* (WLHYD(ILINE,IW1)-WLHYD(ILINE,IW0))
SG=EXP(PRFF*AL10)*FID
IF(ILEMKE.EQ.1) SG=SG*WLINE(I,J)**2*CINV/F00
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
c
c lines without special Stark broadening tables
c
ELSE
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
FXK=F00*XKIJ
FXK1=UN/FXK
DOP=DOP0/WL0
DBETA=WL0*WL0*CINV*FXK1
BETAD=DOP*DBETA
FID=CID*FIJ*DBETA
CALL DIVSTR(AD,DIV)
fr=freq(ij)
BETA=ABS(WLAM(IJ)-WL0)*FXK1
SG=STARKA(BETA,AD,DIV,TWO)*FID
if(iophli.eq.2.and.i.eq.1.and.j.eq.2)
* sg=sg*feautr(fr,id)
ABSO(IJ)=ABSO(IJ)+SG*ABTRA
EMIS(IJ)=EMIS(IJ)+SG*EMTRA
END IF
100 CONTINUE
200 CONTINUE
C
C ----------------------------
C total opacity and emissivity
C ----------------------------
C
F=FREQ(IJ)
F15=F*1.E-15
XKF=EXP(-4.79928e-11*F*T1)
XKFB=XKF*1.4743E-2*F15*F15*F15
if(abso(ij).le.0. .and. lasdel) then
abso(ij)=0.
emis(ij)=0.
endif
ABSOH(IJ)=ABSO(IJ)-XKF*EMIS(IJ)
EMISH(IJ)=XKFB*EMIS(IJ)
300 CONTINUE
RETURN
END
synspec/extracted/hydtab.f
+48
View File
@@ -0,0 +1,48 @@
SUBROUTINE HYDTAB(I,J,ID)
C
C interpolated hydrogen line broadening table for line I->J and
C for parameters (TEMP, ELEC) at depth ID
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
C
ILINE=ILIN0(I,J)
IF(ILINE.EQ.0) RETURN
WL0=WLINE(I,J)
NWL=NWLH(ILINE)
C
C coefficient for the asymptotic profile is determined from
C the input data
C
if(id.eq.1) then
XCLOG=PRF(NWL,1,1,ILINE)+2.5*WLHYD(ILINE,NWL)-0.477121
XKLOG=0.6666667*XCLOG
XK=EXP(XKLOG*2.3025851)
end if
C
C temperature is modified in order to account for the
C effect of turbulent velocity on the Doppler width
C
T=TEMP(ID)+6.06E-9*VTURB(ID)
ANE=ELEC(ID)
TL=LOG10(T)
ANEL=LOG10(ANE)
F00=1.25E-9*ANE**0.666666667
FXK=F00*XK
DOP=1.E8/WL0*SQRT(1.65E8*T)
DBETA=WL0*WL0/2.997925E18/FXK
BETAD=DBETA*DOP
C
C interpolation to the actual values of temperature and electron
C density. The result is stored at array PRFHYD, having indices
C ILINE - line number
C ID - depth index
C IWL - wavelength index
C
DO IWL=1,NWL
CALL INTHYD(PROF,TL,ANEL,IWL,ILINE)
PRFHYD(ILINE,ID,IWL)=PROF
END DO
C
RETURN
END
synspec/extracted/hylset.f
+64
View File
@@ -0,0 +1,64 @@
SUBROUTINE HYLSET
C =================
C
C Initialization procedure for treating the hydrogen line opacity
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
DIMENSION ALB(15)
DATA ALB /656.28,486.13,434.05,410.17,397.01,
* 388.91,383.54,379.79,377.06,375.02,
* 373.44,372.19,371.20,370.39,369.72/
C
C IHYL=-1 - hydrogen lines are excluded a priori
C
IHYL=-1
if(iath.le.0) return
IF(FREQ(2).GE.3.28805E15) RETURN
AL0=2.997925E17/FREQ(1)
AL1=2.997925E17/FREQ(2)
IF(AL0.GT.200..AND.AL1.LT.364.6) RETURN
IF(AL0.GT.560..AND.AL1.LT.580.) RETURN
IF(AL0.GT.720..AND.AL1.LT.820.3) RETURN
C
C otherwise, hydrogen lines are included
C
IHYL=0
M20=40
IF(AL1.LT.364.6) THEN
ILOWH=1
FRION=3.28805E15
M10=int(SQRT(3.28805E15/ABS(FRION-FREQ(2))))
IF(FRION.GT.FREQ(1)) M20=int(SQRT(3.28805E15/(FRION-FREQ(1))))
IHYL=1
IF(AL0.GT.123.) IHYL=0
IF(AL0.GT.104..AND.AL1.LT.120.) IHYL=0
IF(AL0.GT.98.5.AND.AL1.LT.102.) IHYL=0
IF(IMODE.EQ.2.OR.IHYDPR.NE.0.OR.GRAV.GE.6.) IHYL=1
ELSE IF(AL1.LT.820.) THEN
ILOWH=2
if(vaclim.lt.3600.) then
FRION=8.2225E14
M10=int(SQRT(3.289017E15/ABS(FRION-FREQ(2))))
else
FRION=8.22013E14
M10=int(SQRT(3.28805E15/ABS(FRION-FREQ(2))))
end if
IF(FRION.GT.FREQ(1)) M20=int(SQRT(3.289017E15/(FRION-FREQ(1))))
DO 10 I=1,15
AL=ALB(I)
IF(AL.LT.AL0-1..OR.AL.GT.AL1+1.) GO TO 10
IHYL=1
GO TO 20
10 CONTINUE
20 CONTINUE
IF(IMODE.EQ.2.OR.IHYDPR.NE.0.OR.GRAV.GE.6.) IHYL=1
ELSE
ILOWH=3
IHYL=1
END IF
c
ihyl=1
c
RETURN
END
synspec/extracted/hylsew.f
+58
View File
@@ -0,0 +1,58 @@
SUBROUTINE HYLSEW(IJ)
C =====================
C
C Initialization procedure for treating the hydrogen line opacity
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'SYNTHP.FOR'
C
C IHYL=-1 - hydrogen lines are excluded a priori
C
IHYLW(IJ)=0
if(iath.le.0) return
FR=FREQ(IJ)
IF(FR.GE.3.28805E15) RETURN
AL0=2.997925E17/FR
AL1=AL0
IF(grav.lt.6.) then
IF(AL0.GT.160..AND.AL1.LT.364.6) RETURN
IF(AL0.GT.506..AND.AL1.LT.630.) RETURN
IF(AL0.GT.680..AND.AL1.LT.820.3) RETURN
else
IF(AL0.GT.540..AND.AL1.LT.600.) RETURN
IF(AL0.GT.720..AND.AL1.LT.820.3) RETURN
end if
C
C otherwise, hydrogen lines are included
C
IHYLW(IJ)=1
M20W(IJ)=40
IF(AL1.LT.364.6) THEN
ILOWHW(IJ)=1
FRION=3.28805E15
ELSE IF(AL1.LT.820.) THEN
ILOWHW(IJ)=2
FRION=8.2225E14
ELSE IF(AL1.LT.1458.) THEN
ILOWHW(IJ)=3
FRION=3.6544142E14
ELSE IF(AL1.LT.2278.) THEN
ILOWHW(IJ)=4
FRION=2.0555837E14
ELSE IF(AL1.LT.3281.) THEN
ILOWHW(IJ)=5
FRION=1.315589E14
ELSE IF(AL1.LT.4466.) THEN
ILOWHW(IJ)=6
FRION=9.136394E13
ELSE
ILOWHW(IJ)=7
FRION=6.7120228E13
END IF
IF(FRION.GT.FR) M10W(IJ)=int(SQRT(3.289017E15/ABS(FRION-FR)))
c WRITE(6,601) ILOWH,M20+1
c 601 FORMAT(1H0/ ' *** HYDROGEN LINES CONTRIBUTE'/
c * ' THE NEAREST LINE ON THE SHORT-WAVELENGTH SIDE IS',
c * I3,' TO ',I3/)
RETURN
END
synspec/extracted/idmtab.f
+86
View File
@@ -0,0 +1,86 @@
SUBROUTINE IDMTAB
C =================
C
C output of selected molecular line parameters (identification table)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/REFDEP/IREFD(MFREQ)
COMMON/RTEOPA/CH(MFREQ,MDEPTH),ET(MFREQ,MDEPTH),
* SC(MFREQ,MDEPTH)
CHARACTER*4 APB,AP0,AP1,AP2,AP3,AP4,APR
C
PARAMETER (C1=2.3025851, C2=4.2014672, C3=1.4387886)
DATA APB,AP0,AP1,AP2,AP3,AP4 /' ',' .',' *',' **',' ***',
* '****'/
C
ALM0=2.997925D18/FREQ(1)
ALM1=2.997925D18/FREQ(2)
if(ifwin.gt.0) ALM1=2.997925D18/FREQ(NFREQ)
IF(IPRIN.LE.-2) RETURN
if(iprin.ge.3) then
IF(IMODE.GE.0) WRITE(6,601) IBLANK,ALM0,ALM1
IF(IMODE.GE.0.OR.(IMODE.EQ.-1.AND.IBLANK.EQ.1)) WRITE(6,602)
end if
C
ID=IDSTD
DO 100 ILIST=1,NMLIST
IF(NLINML(ILIST).EQ.0) GO TO 100
DO IL0=1,NLINML(ILIST)
IL=INMLIN(IL0,ILIST)
ALAM=2.997925D18/FREQM(IL,ILIST)
c ID=IDSTD
IJCN=IJCMTR(IL0,ILIST)
c IF(IJCN.GE.1.AND.IJCN.LE.NFREQS) ID=IREFD(IJCN)
IMOL=INDATM(IL,ILIST)
DOP1=DOPMOL(IMOL,ID)
ANE=ELEC(ID)
AGAM=(GRM(IL,ILIST)+GSM(IL,ILIST)*ANE+
* GVDW(IL,ILIST,ID))*DOP1
ABCNT=EXP(GFM(IL,ILIST)-EXCLM(IL,ILIST)/TEMP(ID))*
* RRMOL(IMOL,ID)*DOP1*STIM(ID)
absta=min(ch(1,id),ch(2,id))
str0=abcnt/absta
if(ifwin.gt.0) STR0=ABCNT/ABSTDW(IJCONT(IL),ID)
GF=(GFM(IL,ILIST)+C2)/C1
EXCL=EXCLM(IL,ILIST)/C3
IF(STR0.LE.1.2) THEN
WW1=0.886*STR0*(1.-STR0*(0.707-STR0*0.577))
ELSE
WW1=SQRT(LOG(STR0))
END IF
IF(STR0.GT.55.) THEN
WW2=0.5*SQRT(3.14*AGAM*STR0)
IF(WW2.GT.WW1) WW1=WW2
END IF
EQW=ALAM/FREQM(IL,ILIST)*1.E3/DOP1*WW1
STR=EQW*10.
APR=APB
IF(STR.GE.1.E0.AND.STR.LT.1.E1) APR=AP0
IF(STR.GE.1.E1.AND.STR.LT.1.E2) APR=AP1
IF(STR.GE.1.E2.AND.STR.LT.1.E3) APR=AP2
IF(STR.GE.1.E3.AND.STR.LT.1.E4) APR=AP3
IF(STR.GE.1.E4) APR=AP4
if(alam.ge.alm0.and.alam.lt.alm1) then
WRITE(15,603) ALAM,CMOL(IMOL),GF,EXCL,
* STR0,EQW,APR,id,AGAM
end if
END DO
C
601 FORMAT(/' ',I4,'. SET (MOLECULAR LINES):',
* ' INTERVAL ',F9.3,' -',F9.3,' ANGSTROMS'/
* ' ------------')
602 FORMAT(/1H ,13X,
* 'LAMBDA MOLECULE LOG GF ELO LINE/CONT',2X,
* 'EQ.WIDTH',8x,'AGAM'/)
603 FORMAT(F11.3,2X,A4,4X,F7.2,F12.3,1PE11.2,0PF8.1,1X,A4,
* i4,1PE10.2)
C
100 CONTINUE
RETURN
END
synspec/extracted/idtab.f
+97
View File
@@ -0,0 +1,97 @@
SUBROUTINE IDTAB
C ================
C
C output of selected line parameters (identification table)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
CHARACTER*4 TYPION(30)
CHARACTER*4 APB,AP0,AP1,AP2,AP3,AP4,APR
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
COMMON/REFDEP/IREFD(MFRQ)
COMMON/RTEOPA/CH(MFREQ,MDEPTH),ET(MFREQ,MDEPTH),
* SC(MFREQ,MDEPTH)
C
PARAMETER (C1=2.3025851, C2=4.2014672, C3=1.4387886)
DATA TYPION /' I ',' II ',' III',' IV ',' V ',
* ' VI ',' VII','VIII',' IX ',' X ',
* ' XI ',' XII','XIII',' XIV',' XV ',
* ' XVI','XVII',' 18 ',' XIX',' XX ',
* ' XXI','XXII',' 23 ','XXIV','XXV ',
* 'XXVI',' 27 ',' 28 ','XXIX',' XXX'/
DATA APB,AP0,AP1,AP2,AP3,AP4 /' ',' .',' *',' **',' ***',
* '****'/
C
IF(NLIN.EQ.0) GO TO 100
C
ALM0=2.997925D18/FREQ(1)
ALM1=2.997925D18/FREQ(2)
if(ifwin.gt.0) ALM0=2.997925D18/FRQOBS(1)
if(ifwin.gt.0) ALM1=2.997925D18/FRQOBS(NFREQ)
IF(IPRIN.LE.-2) RETURN
if(iprin.ge.2) then
c IF(IMODE.GE.0.OR.(IMODE.EQ.-1.AND.IBLANK.EQ.1)) WRITE(6,602)
end if
C
DO IL0=1,NLIN
IL=INDLIN(IL0)
ALAM=2.997925D18/FREQ0(IL)
ID=IDSTD
IJCN=IJCNTR(IL0)
ID0=0
IF(IJCN.GE.1.AND.IJCN.LE.NFREQS) ID0=IREFD(IJCN)
IF(ID0.GT.0.and.id0.lt.nd) ID=ID0
IAT=INDAT(IL)/100
ION=MOD(INDAT(IL),100)
CALL PROFIL(IL,IAT,ID,AGAM)
ABCNT=EXP(GF0(IL)-EXCL0(IL)/TEMP(ID))*RRR(ID,ION,IAT)*
* STIM(ID)
absta=min(ch(1,idstd),ch(2,idstd))
if(ifwin.le.0) then
DOP1=DOPA1(IAT,ID)
str0=abcnt*dop1/absta
else
DOP1=DOPA1(IAT,ID)/FREQ0(IL)
STR0=ABCNT*DOP1/ABSTDW(IJCONT(IL),ID)
end if
GF=(GF0(IL)+C2)/C1
EXCL=EXCL0(IL)/C3
IF(STR0.LE.1.2) THEN
WW1=0.886*STR0*(1.-STR0*(0.707-STR0*0.577))
ELSE
WW1=SQRT(LOG(STR0))
END IF
IF(STR0.GT.55.) THEN
WW2=0.5*SQRT(3.14*AGAM*STR0)
IF(WW2.GT.WW1) WW1=WW2
END IF
EQW=ALAM/FREQ0(IL)*1.E3/DOP1*WW1
STR=EQW*10.
APR=APB
IF(STR.GE.1.E0.AND.STR.LT.1.E1) APR=AP0
IF(STR.GE.1.E1.AND.STR.LT.1.E2) APR=AP1
IF(STR.GE.1.E2.AND.STR.LT.1.E3) APR=AP2
IF(STR.GE.1.E3.AND.STR.LT.1.E4) APR=AP3
IF(STR.GE.1.E4) APR=AP4
if(alam.ge.alm0.and.alam.lt.alm1) then
ill=ilown(il)
ilu=iupn(il)
if(ill.gt.0) ill=ill-nfirst(iel(ill))+1
if(ilu.gt.0) ilu=ilu-nfirst(iel(ilu))+1
WRITE(12,603) ALAM,TYPAT(IAT),TYPION(ION),GF,EXCL,
* STR0,EQW,APR,ill,ilu,id
end if
END DO
C
c 602 FORMAT(/1H ,13X,
c * 'LAMBDA ATOM LOG GF ELO LINE/CONT',2X,
c * 'EQ.WIDTH'/)
603 FORMAT(F11.3,2X,A4,A3,F7.2,F12.3,1PE11.2,0PF8.1,1X,A4,
* 3i4)
C
100 CONTINUE
RETURN
END
synspec/extracted/ingrid.f
+334
View File
@@ -0,0 +1,334 @@
subroutine ingrid(mode,inext,igrd)
C ==================================
C
c setting state parameters for the opacity grid calculations
c
c input:
c temp1 - lowest value of T
c temp2 - largest value of T
c ntemp - number of temperature values
c dens1 - lowest value of the density parameter
c dens2 - largest value of the density parameter
c ndens - number of the density parameter values
c
c isdens = 0 - density parameter is electron density
c > 0 - density parameter is mass density
c < 0 - density parameter is gas pressure
c
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'LINDAT.FOR'
parameter (un=1.,ten15=1.e-15,c18=2.997925e18)
real*4 absgrd(mttab,mrtab,mfgrid),dtim
common/alsave/ALAM0s,ALASTs,CUTOF0s,CUTOFSs,RELOPs,SPACEs
common/gridp0/tempg(mttab),densg(mttab,mrtab),elecgr(mttab,mrtab),
* densg0(mttab),temp1,ntemp,ndens,nden(mttab)
common/gridf0/wlgrid(mfgrid),nfgrid
common/fintab/absgrd
common/prfrgr/ipfreq,indext,indexn
common/igrddd/igrdd,irelin
common/initab/absop(msftab),wltab(msftab),
* nfrtab(mttab,mrtab),inttab
common/elecm0/elecm(mdepth)
common/timeta/dtim
common/relabu/relabn(matom),popul0(mlevel,1)
dimension abgrd(mfgrid),xli(3)
character*(80) tabname
common/tabout/tabname,ibingr,idens
dimension templ(mttab)
c
c --------------
c initialization
c --------------
c
igrdd=igrd
if(mode.eq.0) then
c
read(2,*) ntemp,temp1,temp2
read(2,*) idens
if(idens.lt.10) then
read(2,*) ndens,dens1,dens2
else if(idens.lt.20) then
read(2,*) ndens,densl1,densl2,densu1,densu2
else
do it=1,ntemp
read(2,*) ndens,densl,densu
densg(it,1)=densl
densg(it,ndens)=densu
nden(it)=ndens
end do
end if
if(idens.lt.20) then
do it=1,ntemp
nden(it)=ndens
end do
end if
if(ifeos.le.0) then
read(2,*) nfgrid,inttab,wlam1,wlam2
read(2,*) tabname,ibingr
end if
c
irsct=0
irsche=0
irsch2=0
c
wl1=log(wlam1)
wl2=log(wlam2)
dwl=(wl2-wl1)/(nfgrid-1)
do i=1,nfgrid
wlgrid(i)=exp(wl1+(i-1)*dwl)
end do
c
if(temp1.gt.0.) then
at1=log(temp1)
at2=log(temp2)
dt=0.
if(ntemp.gt.1) dt=(at2-at1)/(ntemp-1)
do i=1,ntemp
templ(i)=at1+(i-1)*dt
tempg(i)=exp(templ(i))
end do
if(idens.lt.10) then
at1=log(dens1)
at2=log(dens2)
dr=0.
ndens=nden(1)
if(ndens.gt.0) dr=(at2-at1)/(ndens-1)
do i=1,ntemp
do j=1,ndens
densg(i,j)=exp(at1+(j-1)*dr)
end do
end do
else if(idens.lt.20) then
rhol1=log(densl1)
rhol2=log(densl2)
rhou1=log(densu1)
rhou2=log(densu2)
do i=1,ntemp
ndens=nden(i)
dens1=rhol1+(rhou1-rhol1)/(at2-at1)*(templ(i)-at1)
dens2=rhol2+(rhou2-rhol2)/(at2-at1)*(templ(i)-at1)
dr=0.
if(ndens.gt.1) dr=(dens2-dens1)/(ndens-1)
do j=1,ndens
densg(i,j)=exp(dens1+(j-1)*dr)
end do
end do
else
do i=1,ntemp
ndens=nden(i)
at1=log(densg(i,1))
at2=log(densg(i,ndens))
dr=0.
if(ndens.gt.0) dr=(at2-at1)/(ndens-1)
do j=2,ndens-1
densg(i,j)=exp(at1+(j-1)*dr)
end do
end do
end if
c
write(6,621) ntemp,nden(1)
do i=1,ntemp
ndens=nden(i)
write(6,622) tempg(i),(log10(densg(i,j)),j=1,ndens)
end do
621 format(/' COMPUTING AN OPACITY TABLE WITH GRID PARAMETERS:'/
* ' ===== ntemp, ndens ',2i4)
622 format(f10.1,20f8.2)
else
call inpmod
ntemp=nd
ndens=1
do it=1,ntemp
tempg(it)=temp(it)
densg0(it)=dens(it)
densg(it,1)=dens(it)
elecm(it)=elec(it)
end do
if(ifeos.le.0) then
write(6,621) ntemp,ndens
do i=1,ntemp
write(6,622) tempg(i),densg0(i)
end do
end if
ndens=1
idens=2
end if
c
nd=1
idstd=1
inext=1
frmx=0.
frmn=1.e20
idens0=mod(idens,10)
c
indext=1
indexn=1
ipfreq=0
irelin=1
temp(1)=tempg(indext)
c
write(6,646) indext,temp(1),
* indexn,densg(indext,indexn)
646 format(/' ************************************',
* /' GRID POINT OF THE OPACITY TABLE WITH:'/
* ' INDEX TEMP, T ',i4,f10.1/
* ' INDEX DENS, DENS',I4,1PE10.1,
* /' ************************************'/)
c
if(temp1.le.0.) elec(1)=elecm(indext)
call densit(densg(indext,indexn),idens0)
if(ntemp.eq.1.and.ndens.eq.1) inext=0
elecgr(indext,indexn)=elec(1)
call abnchn(0)
return
c
c ---------------------------------------------
c after computing the table for one T-rho pair:
c ---------------------------------------------
c
else if(mode.eq.1) then
if(ifeos.le.0) then
c
call timing(1,igrd+1)
c
do i=1,3
xli(i)=0.
end do
do i=1,nmlist
xli(i)=float(nlinmt(i))*1.e-3
end do
c
if(imode.ge.-5) then
if(indext.eq.1.and.indexn.eq.1)
* write(29,625)
write(29,626) indext,indexn,temp(1),dens(1),elec(1),
* float(nlin0)*1.e-3,
* (xli(i),i=1,3),dtim
625 format(' it ir t rho elec',6x,
* ' atomic molec1 molec2 molec3 time'/)
626 format(2i4,f9.2,1p2e10.2,2x,0pf8.1,2x,3f8.1,2x,f8.2)
else
alam0=alam0s
if(alam0s.eq.0.) alam0=5.e7/temp(1)/10.
if(alam0s.lt.0.) alam0=-5.e7/temp(1)/alam0s
alast=alasts
if(alasts.eq.0.) alast=5.e7/temp(1)*20.
if(alasts.lt.0.) alast=-5.e7/temp(1)*alasts
if(alast.gt.1.e5) alast=1.e5
write(29,629) temp(1),elec(1),dens(1),
* alam0,alast
end if
629 format(1p3e11.3,0pf9.3,0pf12.3)
c
c ------------------------------------------------
c interpolate and store previously computed table
c ------------------------------------------------
c
nfr=ipfreq
nfrtab(indext,indexn)=ipfreq
write(*,*) 'indext,indexn,nfreq',indext,indexn,ipfreq
write(*,*) 'nfr,nfgrid',nfr,nfgrid
c
if(inttab.eq.1) then
c call interp(wltab,absop,wlgrid,abgrd,nfr,nfgrid,2,0,0)
call intrp(wltab,absop,wlgrid,abgrd,nfr,nfgrid)
else
ij=0
ijgrd=0
30 continue
ijgrd=ijgrd+1
wlgr=0.5*(wlgrid(ijgrd)+wlgrid(ijgrd+1))
isum=0
sum=0.
40 continue
ij=ij+1
if(ij.gt.nfr) go to 50
wlt=wltab(ij)
abl=absop(ij)
if(wlt.le.wlgr) then
sum=sum+exp(abl)
isum=isum+1
go to 40
end if
if(isum.gt.0) then
abgrd(ijgrd)=log(sum/float(isum))
else
abg=abl+(absop(ij+1)-abl)/(wltab(ij+1)-wlt)*(wlgr-wlt)
abgrd(ijgrd)=abg
c write(*,*) 'grd',ij,absop(ij+1),abl,wltab(ij+1),
c * wlt,wlgr,abg,abgrd(ijgrd),ijgrd
end if
if(ijgrd.lt.nfgrid) then
ij=ij-1
go to 30
else if(ijgrd.eq.nfgrid) then
wlgr=wlgrid(nfgrid)
sum=0.
isum=0
if(ij.lt.nfr) ij=ij-1
go to 40
end if
end if
50 continue
c
do ij=1,nfgrid
absgrd(indext,indexn,ij)=real(abgrd(ij))
end do
absgrd(indext,indexn,nfgrid)=absgrd(indext,indexn,nfgrid-1)
end if
c
c ------------------------------
c prepare values for a new table
c ------------------------------
c
ipfreq=0
ndens=nden(indext)
if(indexn.lt.ndens) then
indexn=indexn+1
rho=densg(indext,indexn)
write(6,646) indext,tempg(indext),
* indexn,densg(indext,indexn)
call densit(rho,idens0)
inext=1
else
indexn=1
irelin=1
if(indext.lt.ntemp) then
indext=indext+1
temp(1)=tempg(indext)
if(temp1.le.0.) then
densg(indext,indexn)=densg0(indext)
elec(1)=elecm(indext)
end if
rho=densg(indext,indexn)
write(6,646) indext,tempg(indext),
* indexn,densg(indext,indexn)
call densit(rho,idens0)
inext=1
else
inext=0
end if
end if
if(inext.eq.1) then
rewind(19)
if(inlist.lt.0) rewind(19)
end if
c
elecgr(indext,indexn)=elec(1)
c
call abnchn(0)
id=1
do i=1,4
do j=i+1,22
call hydtab(i,j,id)
end do
end do
end if
c
return
end
synspec/extracted/inibl0.f
+456
View File
@@ -0,0 +1,456 @@
SUBROUTINE INIBL0
C
C AUXILIARY INITIALIZATION PROCEDURE
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'LINDAT.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
parameter (un=1.)
character*2 iu
character*6 ilab
DIMENSION CROSS(MCROSS,MFRQ),
* ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ),
* ABSOC(MFREQC),EMISC(MFREQC),SCATC(MFREQC)
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
common/lasers/lasdel
common/linrej/ilne(mdepth),ilvi(mdepth)
common/velaux/velmax,iemoff,nltoff,itrad
common/alsave/ALAM0s,ALASTs,CUTOF0s,CUTOFSs,RELOPs,SPACEs
C
C --------------------------------------------------------------
C Parameters controlling an evaluation of the synthetic spectrum
C
C --------------------------------------------------------------
C
C ALAM0, ALAM1 - synthetic spectrum is evaluated between wavelengths
C ALAM0 (initial) and ALAM1 (final), given in Anstroms
C CUTOF0 - cutoff parameter for normal lines (given in Angstroms)
C ie the maximum distance from the line center, in
C which the opacity in the line is allowd to contribute
C to the total opacity (recommended 5 - 10)
C CUTOFS = SPACON
C SPACON - spacing of the continuum wavelength points
C (at the midpoint of teh total interval; actual spacing
C is equidistant in log(lambda)
C RELOP - the minimum value of the ratio (opacity in the line
C center)/(opacity in continuum), for which is the line
C taken into account (usually 1d-4 to 1d-3)
C SPACE - the maximum distance of two neighbouring frequency
C points for evaluating the spectrum; in Angstroms
C
C INLTE = 0 - pure LTE (no line in NLTE)
C ne.0 - NLTE option, ie one or more lines treated
C in the exact or approximate NLTE approach
C IFHE2 gt.0 - He II line opacity in the first four series
C (Lyman, Balmer, Paschen, Brackett)
C for lines with lambda < 3900 A
C is taken into account even if line list
C does not contain any He II lines (i.e.
C He II lines are treated as the hydrogen lines)
C
C IHYDPR = 0 - means that hydrogen lines Stark profiles
C are calculated by approximate formulae
C > 0 - hydrogen lines Stark profiles are calculated
C in detail, using the Schoening & Butler tables;
C (for 1-2 to 1-5; 2-3 to 2-10).
C the tables are stored in file FOR0xx.dat,
C where xx=IHYDPR;
C higher Balmer lines are calculated as before
C
C the meaning of other parameters is quite analogous, for the
C following lines
C
C IHE1PR - He I lines at 4471, 4026, 4387, and 4922 Angstroms
C (tables calculated by Barnard, Cooper, and Shamey)
C IHE2PR - for the He II lines calculated by Schoening and Butler,
C
if(ifeos.le.0) then
READ(55,*) IFREQ,INLTE,ICONTL,INLIST,IFHE2
IF(LTE) INLTE=0
READ(55,*) IHYDPR,IHE1PR,IHE2PR
READ(55,*) ALAM0,ALAST,CUTOF0,CUTOFS,RELOP,SPACE
end if
C
IF(IDSTD.EQ.0) THEN
ID1=5
NDSTEP=(ND-2*ID1)/2
IDSTD=2*ND/3
ELSE IF(IDSTD.LT.0) THEN
ID1=1
NDSTEP=-IDSTD
IDSTD=2*ND/3
END IF
if(imode.le.-3) ndstep=1
c
alam0s=alam0
alasts=alast
cutof0s=cutof0
cutofss=cutofs
relops=relop
spaces=space
C
C if ALAST.lt.0 - set up vacuum wavelengths everywhere
C
vaclim=2000.
if(alast.lt.0.) then
alast=abs(alast)
alasts=alast
vaclim=1.e18
end if
c
if(inlte.lt.10) then
lasdel=.true.
else if(inlte.le.20) then
inlte=inlte-10
lasdel=.false.
else if(inlte.le.30) then
inlte=inlte-20
ifreq=11
lasdel=.true.
else if(inlte.le.40) then
inlte=inlte-30
ifreq=11
lasdel=.false.
end if
C
ibin(0)=mod(inlist,10)
do ilist=1,mmlist
tmlim(ilist)=tmolim
ibin(ilist)=mod(inlist,10)
ivdwli(ilist)=0
iun=19+ilist
write(iu,622) iun
622 format(i2)
amlist(ilist)='fort.' // iu
end do
c
if(imode.ge.-3.and.imode.le.1) then
nmlist=0
numlis=0
read(55,*,err=5,end=5) nmlist,(iunitm(ilist),ilist=1,nmlist)
do ilist=1,nmlist
write(iu,622) iunitm(ilist)
amlist(ilist) ='fort.' // iu
end do
5 continue
c
ilist=0
amlist(0)='fort.19'
read(3,*,err=20,end=20) amlist(0),ibin(0)
c
ilist=0
10 continue
ilist=ilist+1
read(3,*,end=20) amlist(ilist),ibin(ilist),tmlim(ilist)
numlis=numlis+1
go to 10
20 continue
if(numlis.gt.0) nmlist=numlis
if(nmlist.gt.0.and.ifmol.eq.0) then
write(*,*) 'NEEDS TO SET IFMOL > 0 with NMLIST>0'
stop
end if
c
ilist=0
ilab='ATOMIC'
write(6,623) ilist,ilab,trim(amlist(ilist)),ibin(ilist)
ilab='MOLEC '
do ilist=1,nmlist
write(6,624) ilist,ilab,trim(amlist(ilist)),ibin(ilist),
* tmlim(ilist)
end do
623 format(/'************************'/
* ' LINE LISTS:'/
* /' ILIST',8x,'FILENAME IBIN TMLIM'/
* i4,2x,a6,2x,a,2x,i4,f11.1)
624 format( i4,2x,a6,2x,a,2x,i4,f11.1)
end if
c
C
c VTB - turbulent velocity (in km/s). In non-negative, this
C value overwrites the value given by the standard input
C
read(55,*,err=30,end=30) VTB
if(ifwin.le.0) then
if(vtb.ge.0.) then
WRITE(6,608) VTB
608 FORMAT(//' TURBULENT VELOCITY - CHANGED TO VTURB =',
* 1PE10.3,' KM/S'/' ------------------'/)
do id=1,nd
vturb(id)=vtb*vtb*1.e10
end do
end if
end if
C
TSTD=TEMP(IDSTD)
VTS=VTURB(IDSTD)
DSTD=SQRT(1.4E7*TSTD+VTS)
30 continue
C
C angle points (in case the specific intensities are evaluated
C
C NMU0 - number of angles:
C >0 - and if also ANG0>0, angles (mu's) equidistant
C between 1 and ANG0
C >0 - and if also ANG0<0, angles (mu's) equidistant
C between 0.7 and ANG0, and sinuses equidistatnt for
C others
C <0 - angles read in the next record
C ANG0 - minimum mu (see above)
C IFLUX - mode for evaluating angle-dependent intensities and
C the corresponding flux:
C =0 - no specifiec intensities are evaluated; only usual
C flux is stored (unit 7 and 17)
C =1 - specific intensities are evaluated;
C and stored on unit 18
C =2 - (interesting only for the case of macroscopic
C velocity field); specific intensities evaluated by
C a simple formal solution (RESOLV)
C
NMU0=1
ANG0=1.
ANGL(1)=1.
WANGL(1)=0.
IFLUX=0
velmax=3.e5
nltoff=0
iemoff=0
itrad=0
do id=1,nd
wdil(id)=un
end do
if(ifwin.le.0) then
READ(55,*,end=100,err=100) NMU0,ANG0,IFLUX
C
C determinantion of the angle points and weights
C
IF(NMU0.LT.0) THEN
NMU0=IABS(NMU0)
READ(55,*) (ANGL(IMU),IMU=1,NMU0)
DO IMU=2,NMU0-1
WANGL(IMU)=0.5*(ANGL(IMU-1)+ANGL(IMU+1))
END DO
WANGL(1)=0.5*(ANGL(1)-ANGL(2))
WANGL(NMU0)=0.5*(ANGL(NMU0-1)-ANGL(NMU0))
ELSE
IF(ANG0.GT.0.) THEN
IF(NMU0.GT.1) THEN
DMU=(1.-ANG0)/(NMU0-1)
DO IMU=1,NMU0
ANGL(IMU)=1.-(IMU-1)*DMU
WANGL(IMU)=DMU
END DO
WANGL(1)=0.5*DMU
WANGL(NMU0-1)=0.5*DMU
WANGL(NMU0)=2.*DMU
END IF
ELSE
ANGH=0.70710678
DMU=ANGH/(NMU0-1)
DO IMU=1,NMU0
ANGL(IMU)=(IMU-1)*DMU
ANGL(IMU)=SQRT(1.-ANGL(IMU)**2)
IF(IMU.GT.1.AND.IMU.LT.NMU0)
* WANGL(IMU)=0.5*(ANGL(IMU-1)+ANGL(IMU+1))
END DO
WANGL(1)=0.5*(ANGL(1)-ANGL(2))
WANGL(NMU0)=0.5*(ANGL(NMU0-1)-ANGL(NMU0))
IF(ANG0.LT.0.) DMU=(ANGH+ANG0)/(NMU0-1)
DO IMU=1,NMU0-2
ANGL(IMU+NMU0)=ANGH-IMU*DMU
WANGL(IMU+NMU0)=DMU
END DO
WANGL(NMU0)=WANGL(NMU0)+0.5*DMU
WANGL(2*NMU0-3)=0.5*DMU
WANGL(2*NMU0-2)=2.*DMU
NMU0=2*NMU0-2
END IF
END IF
IF(NMU0.LE.0) GO TO 100
WRITE(6,609) NMU0,(ANGL(I),I=1,NMU0)
609 FORMAT(//' SPECIFIC INTENSITIES COMPUTED FOR',I3,
* ' ANGLES mu=cos(theta) ='/
* ' ---------------------------------',
* '------------------------'//
* (10F7.2))
100 CONTINUE
else
itrad=1
read(55,*,end=110,err=110) velmax,ITRAD,nltoff,iemoff
110 write(6,602) velmax,itrad,nltoff,iemoff
if(velmax.lt.0.) then
velmax=3.e5
go to 120
end if
602 format(//' velmax (velocity for line rejection)',
* ' itrad,nltoff,iemoff',f10.1,2i3)
C
C Set up rays and weights
C
call velset
call radtem
CALL SETRAY
CALL WGTJH1
C
end if
C
120 CONTINUE
velmax=velmax*1.e5
do id=1,nd
ilvi(id)=0
ilne(id)=0
if(vel(id).gt.velmax.and.iemoff.eq.0) ilvi(id)=1
if(vel(id).gt.velmax.and.nltoff.gt.0.and.iemoff.gt.0)
* ilne(id)=1
end do
C
IF(IMODE.EQ.-1) THEN
INLTE=0
CUTOF0=0.
END IF
C
C continuum frequencies
C
if(ifwin.le.0) then
alam0=alam0s
if(alam0s.eq.0.) alam0=5.e7/temp(1)/10.
if(alam0s.lt.0.) alam0=-5.e7/temp(1)/alam0s
alast=alasts
if(alasts.eq.0.) alast=5.e7/temp(1)*20.
if(alasts.lt.0.) alast=-5.e7/temp(1)*alasts
c if(alast.gt.1.e5) alast=1.e5
ALAMC=(ALAM0+ALAST)*0.5
if(space.eq.0.) space=4.3e-8*sqrt(temp(idstd))*alamc
if(space.lt.0.) space=-5.72e-8*sqrt(temp(idstd))*alamc*space
SPACF=2.997925E18/ALAMC/ALAMC*SPACE
WRITE(6,601) ALAM0,ALAST,CUTOF0,RELOP,SPACF,SPACE
CUTOF0=0.1*CUTOF0
SPACE0=SPACE*0.1
ALAM0=1.D-1*ALAM0
ALAST=1.D-1*ALAST
ALAMC=ALAMC*0.1
ALST00=ALAST
FRLAST=2.997925D17/ALAST
NFREQ=2
FREQ(1)=2.997925D17/ALAM0
FREQ(2)=FRLAST
C
else
C
spacon=cutofs
IF(SPACON.EQ.0) SPACON=3.
XFR=(ALAST-ALAM0)/SPACON
NFREQC=int(XFR)+1
NFREQC=MIN(NFREQC,MFREQC)
NFREQC=MAX(NFREQC,2)
DLAMLO=LOG10(ALAST/ALAM0)/(NFREQC-1)
AL0L=LOG10(ALAM0)
alambe=alam0
DO IJ=1,NFREQC
AL=AL0L+(IJ-1)*DLAMLO
ALAM=EXP(2.3025851*AL)
WLAMC(IJ)=ALAM
FREQC(IJ)=2.997925E18/ALAM
END DO
ALAMC=(ALAM0+ALAST)*0.5
SPACF=2.997925E18/ALAMC/ALAMC*SPACE
WRITE(6,601) ALAM0,ALAST,CUTOF0,RELOP,SPACF,SPACE
CUTOF0=0.1*CUTOF0
SPACE0=SPACE*0.1
ALAM0=1.D-1*ALAM0
ALAST=1.D-1*ALAST
ALAMC=ALAMC*0.1
ALST00=ALAST
FRLAST=2.997925D17/ALAST
NFREQ=2
FREQ(1)=2.997925D17/ALAM0
FREQ(2)=FRLAST
c
end if
c
CALL SIGAVS
IF(IHYDPR.NE.0) THEN
CALL HYDINI
CALL XENINI
END IF
IF(IHE1PR.GT.0) CALL HE1INI
IF(IHE2PR.GT.0) CALL HE2INI
C
C auxiliary quantities for dissolved fractions
C
DO ID=1,ND
CALL DWNFR0(ID)
CALL WNSTOR(ID)
END DO
C
c pretabulate expansion coefficients for the Voigt function
c
CALL PRETAB
c
c calculate the characteristic standard opacity
c
IF(IMODE.LE.2) THEN
if(ifwin.le.0.and.ndstep.eq.0) then
c
c old procedure
c
CALL CROSET(CROSS)
DO ID=1,ND
CALL OPAC(ID,CROSS,ABSO,EMIS,SCAT)
ABSTD(ID)=MIN(ABSO(1),ABSO(2))
END DO
else
c
c new procedure
c
if(ifwin.le.0) then
nfreqc=ifix(real(cutofs,4))
if(nfreqc.eq.0) nfreqc=mfreq
all0=log(alam0)
all1=log(alast)
dlc=(all1-all0)/(nfreqc-1)
do ijc=1,nfreqc
wlamc(ijc)=exp(all0+(ijc-1)*dlc)
freqc(ijc)=2.997925e17/wlamc(ijc)
end do
CALL CROSEW(CROSS)
do id=1,nd
CALL OPACON(ID,CROSS,ABSOC,EMISC,SCATC)
do ijc=1,nfreqc
abstdw(ijc,id)=absoc(ijc)
end do
end do
c write(*,*) 'abstdw(1,ij)',(abstdw(ij,1),ij=1,nfreqc)
c write(*,*) 'abstdw(50,ij)',(abstdw(ij,50),ij=1,nfreqc)
c
else
CALL CROSEW(CROSS)
DO ID=1,ND
CALL OPACW(ID,CROSS,ABSO,EMIS,ABSOC,EMISC,SCATC,0)
DO IJ=1,NFREQC
ABSTDW(IJ,ID)=ABSOC(IJ)/DENSCON(ID)
END DO
END DO
end if
end if
END IF
C
601 FORMAT(//'----------------------------------------------'/
* ' BASIC INPUT PARAMETERS FOR SYNTHETIC SPECTRA'/
* ' ---------------------------------------------'/
* ' INITIAL LAMBDA',28X,1H=,F10.3,' ANGSTROMS'/
* ' FINAL LAMBDA',28X,1H=,F10.3,' ANGSTROMS'/
* ' CUTOFF PARAMETER',26X,1H=,F10.3,' ANGSTROMS'/
* ' MINIMUM VALUE OF (LINE OPAC.)/(CONT.OPAC) =',1PE10.1/
* ' MAXIMUM FREQUENCY SPACING',17X,1H=,1PE10.3,' I.E.',
* 0PF6.3,' ANGSTROMS'/
* ' ---------------------------------------------'/)
c
write(6,612) idstd,ndstep
612 format(/'IDSTD, NDSTEP = ',2i5/)
RETURN
END
synspec/extracted/inibl1.f
+117
View File
@@ -0,0 +1,117 @@
SUBROUTINE INIBL1(IGRD)
C =======================
C
C AUXILIARY INITIALIZATION PROCEDURE
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'LINDAT.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'WINCOM.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
common/alsave/ALAM0s,ALASTs,CUTOF0s,CUTOFSs,RELOPs,SPACEs
common/plaopa/plalin,plcint,chcint
common/conabs/absoc(mfreqc),emisc(mfreqc),scatc(mfreqc),
* plac(mfreqc)
parameter (un=1.,bnc=1.4743e-2,hkc=4.79928e4,
* clc=2.997925e17)
DIMENSION CROSS(MCROSS,MFRQ),
* ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ)
C
C auxiliary quantities for dissolved fractions
C
DO ID=1,ND
CALL DWNFR0(ID)
CALL WNSTOR(ID)
anh2(id)=0.
anhm(id)=0.
anch(id)=0.
anoh(id)=0.
END DO
CALL TINT
c
c reset wavelengths in case of opacity grid calculations
c
if(igrd.ge.0) then
alam0=alam0s
if(alam0s.eq.0.) alam0=5.e7/temp(1)/10.
if(alam0s.lt.0.) alam0=-5.e7/temp(1)/alam0s
alast=alasts
if(alasts.eq.0.) alast=5.e7/temp(1)*20.
if(alasts.lt.0.) alast=-5.e7/temp(1)*alasts
c if(alast.gt.1.e5) alast=1.e5
cutof0=cutof0s
cutofs=cutofss
relop=relops
if(relops.eq.0) then
relop=1.e-15
if(temp(1).lt.2.e6) relop=1.e-6
if(temp(1).lt.1.e6) relop=1.e-5
if(temp(1).lt.1.e5) relop=1.e-4
end if
space=spaces
ALAMC=(ALAM0+ALAST)*0.5
if(space.eq.0.) space=4.3e-8*sqrt(temp(idstd))*alamc
if(space.lt.0.) space=-5.72e-8*sqrt(temp(idstd))*alamc*space
SPACF=2.997925E18/ALAMC/ALAMC*SPACE
CUTOF0=0.1*CUTOF0
SPACE0=SPACE*0.1
ALAM0=1.D-1*ALAM0
ALAST=1.D-1*ALAST
ALAMC=ALAMC*0.1
ALST00=ALAST
FRLAST=CLC/ALAST
c
nfreqc=ifix(real(cutofs,4))
if(nfreqc.eq.0) nfreqc=mfreq
all0=log(alam0)
all1=log(alast)
dlc=(all1-all0)/(nfreqc-1)
xcc0=hkc/temp(1)
do ijc=1,nfreqc
wlamc(ijc)=exp(all0+(ijc-1)*dlc)
freqc(ijc)=clc/wlamc(ijc)
c frc=freqc(ijc)*1.e-15
c plac(ijc)=bnc*frc**3/(exp(xcc0*frc)-un)
end do
id=1
CALL CROSEW(CROSS)
CALL OPACON(ID,CROSS,ABSOC,EMISC,SCATC)
wc0=(freqc(1)-freqc(2))*0.5
wc1=(freqc(nfreqc-1)-freqc(nfreqc))*0.5
do ijc=2,nfreqc-1
absoc(ijc)=min(absoc(ijc),1.e30)
write(26,642) wlamc(ijc)*10.,log(absoc(ijc)/dens(1))
end do
642 format(f11.3,1p5e13.5)
c
do ijc=1,nfreqc
abstdw(ijc,id)=absoc(ijc)
end do
c
end if
c
c calculate the characteristic standard opacity
c
IF(IMODE.LE.2.and.imode.ge.-2) THEN
if(ifwin.le.0) then
CALL CROSET(CROSS)
DO ID=1,ND
CALL OPAC(ID,CROSS,ABSO,EMIS,SCAT)
ABSTD(ID)=MIN(ABSO(1)+SCAT(1),ABSO(2)+SCAT(2))
END DO
else
CALL CROSEW(CROSS)
DO ID=1,ND
CALL OPACW(ID,CROSS,ABSO,EMIS,ABSOC,EMISC,SCATC,0)
DO IJ=1,NFREQC
denscon(id)=1.
ABSTDW(IJ,ID)=ABSOC(IJ)/DENSCON(ID)
END DO
END DO
end if
END IF
C
RETURN
END
synspec/extracted/inibla.f
+46
View File
@@ -0,0 +1,46 @@
SUBROUTINE INIBLA
C =================
C
C driving procedure for treating a partial line list for the
C current wavelength region
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
C
PARAMETER (DP0=3.33564E-11, DP1=1.651E8,
c * VW1=0.42, VW2=0.3, TENM4=1.E-4)
* VW1=0.42, VW2=0.45,TENM4=1.E-4)
PARAMETER (UN=1.)
C
IF(NLIN.EQ.0) RETURN
XX=FREQ(1)
IF(NFREQ.GE.2) XX=0.5*(FREQ(1)+FREQ(2))
if(ifwin.gt.0) XX=0.5*(FREQC(1)+FREQC(NFREQC))
BNU=BN*(XX*1.E-15)**3
HKF=HK*XX
if(ifwin.gt.0) XX=un
DO 20 ID=1,ND
T=TEMP(ID)
ANE=ELEC(ID)
EXH=EXP(HKF/T)
EXHK(ID)=UN/EXH
PLAN(ID)=BNU/(EXH-UN)
STIM(ID)=UN-EXHK(ID)
if(iath.gt.0) then
ANP=POPUL(NKH,ID)
AH=DENS(ID)/WMM(ID)/YTOT(ID)-ANP
else
ah=rrr(id,1,1)
end if
AHE=RRR(ID,1,2)
VDWC(ID)=(AH+VW1*AHE+0.85*ANH2(ID))*(T*TENM4)**VW2
DO 10 IAT=1,MATOM
IF(AMAS(IAT).GT.0.)
* DOPA1(IAT,ID)=UN/(XX*DP0*SQRT(DP1*T/AMAS(IAT)+VTURB(ID)))
10 CONTINUE
20 CONTINUE
RETURN
END
synspec/extracted/iniblh.f
+125
View File
@@ -0,0 +1,125 @@
SUBROUTINE INIBLH
C =================
C
C output information about hydrogen lines
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
CHARACTER*4 TYPION(30)
CHARACTER*4 APB,AP0,AP1,AP2,AP3,AP4,APR
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
C
PARAMETER (C1=2.3025851, C2=4.2014672, C3=1.4387886)
PARAMETER (DP0=3.33564E-11, DP1=1.651E8,
* VW1=0.42, VW2=0.45,TENM4=1.E-4)
PARAMETER (UN=1.)
DATA TYPION /' I ',' II ',' III',' IV ',' V ',
* ' VI ',' VII','VIII',' IX ',' X ',
* ' XI ',' XII','XIII',' XIV',' XV ',
* ' XVI','XVII',' 18 ',' XIX',' XX ',
* ' XXI','XXII',' 23 ','XXIV','XXV ',
* 'XXVI',' 27 ',' 28 ','XXIX',' XXX'/
DATA APB,AP0,AP1,AP2,AP3,AP4 /' ',' .',' *',' **',' ***',
* '****'/
C
IF(IPRIN.LE.-2.OR.IHYL.LT.0) RETURN
ALM0=2.997925D18/FREQ(1)
ALM1=2.997925D18/FREQ(2)
XX=FREQ(1)
IF(NFREQ.GE.2) XX=0.5*(FREQ(1)+FREQ(2))
BNU=BN*(XX*1.E-15)**3
HKF=HK*XX
C
IAT=1
ION=1
IZZ=1
ID=IDSTD
T=TEMP(ID)
ANE=ELEC(ID)
EXH=EXP(HKF/T)
EXHK(ID)=UN/EXH
PLAN(ID)=BNU/(EXH-UN)
STIM(ID)=UN-EXHK(ID)
DOPA1(IAT,ID)=UN/(XX*DP0*SQRT(DP1*T/AMAS(IAT)+VTURB(ID)))
ISERL=ILOWH
ISERU=ILOWH
IF(alm0.GT.17000..AND.alm1.LT.21000.) THEN
ISERL=3
ISERU=4
ELSE IF(alm0.GT.22700.) THEN
ISERL=4
ISERU=5
IF(alm0.GT.32800.) ISERU=6
IF(alm0.GT.44660.) ISERU=7
END IF
C
DO I=ISERL,ISERU
II=I*I
XII=UN/II
M1=M10
IF(I.LT.ILOWH) M1=ILOWH-1
M2=M1+1
IF(M1.LT.I+1) M1=I+1
M1=M1-1
M2=M20+3
IF(M1.LT.I+1) M1=I+1
if(grav.gt.3.) then
m2=m2+5
m1=m1-3
if(m1.gt.i+6) m1=m1-3
end if
if(grav.gt.6.) then
m2=m2+2
m1=m1-1
if(m1.gt.i+6) m1=m1-1
end if
IF(M1.LT.I+1) M1=I+1
IF(M2.GT.20) M2=20
ILINH=0
DO J=M2,M1,-1
CALL STARK0(I,J,izz,XKIJ,WL0,FIJ,FIJ0)
ALAM=WL0
if(alam.ge.alm0.and.alam.lt.alm1) then
ILINH=ILINH+1
GH=2.*II
GF=LOG10(FIJ*GH)
EXCL=109679.*(1.-XII)
EXCL0H=EXCL*C3
GF0H=GF*C1-C2
ABCNT=EXP(GF0H-EXCL0H/TEMP(ID))*RRR(ID,ION,IAT)*
* DOPA1(IAT,ID)*STIM(ID)
STR0=ABCNT/ABSTD(ID)
IF(STR0.LE.1.2) THEN
WW1=0.886*STR0*(1.-STR0*(0.707-STR0*0.577))
ELSE
WW1=SQRT(LOG(STR0))
END IF
IF(STR0.GT.55.) THEN
agam=0.01
WW2=0.5*SQRT(3.14*AGAM*STR0)
IF(WW2.GT.WW1) WW1=WW2
END IF
EQW=ALAM*ALAM/3.E18*1.E3/DOPA1(IAT,ID)*WW1
STR=EQW*10.
APR=APB
IF(STR.GE.1.E0.AND.STR.LT.1.E1) APR=AP0
IF(STR.GE.1.E1.AND.STR.LT.1.E2) APR=AP1
IF(STR.GE.1.E2.AND.STR.LT.1.E3) APR=AP2
IF(STR.GE.1.E3.AND.STR.LT.1.E4) APR=AP3
IF(STR.GE.1.E4) APR=AP4
c if(iprin.ge.2)
c * WRITE(6,601) ALAM,TYPAT(IAT),TYPION(ION),GF,EXCL,
c * STR0,EQW,APR,i,j
WRITE(14,601) ALAM,TYPAT(IAT),TYPION(ION),GF,EXCL,
* STR0,EQW,APR,i,j
end if
END DO
END DO
C
601 FORMAT(F10.3,2X,2A4,F7.2,F12.3,1PE11.2,0PF8.1,1X,A4,2i3)
C
RETURN
END
synspec/extracted/iniblm.f
+31
View File
@@ -0,0 +1,31 @@
SUBROUTINE INIBLM
C =================
C
C driving procedure for treating a partial molecular line list for the
C current wavelength region
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
C
PARAMETER (DP0=3.33564E-11, DP1=1.651E8, UN=1.)
C
XX=FREQ(1)
IF(NFREQ.GE.2) XX=0.5*(FREQ(1)+FREQ(2))
BNU=BN*(XX*1.E-15)**3
HKF=HK*XX
DO ID=1,ND
T=TEMP(ID)
EXH=EXP(HKF/T)
EXHK(ID)=UN/EXH
PLAN(ID)=BNU/(EXH-UN)
STIM(ID)=UN-EXHK(ID)
DO IMOL=1,NMOLEC
IF(AMMOL(IMOL).GT.0.)
* DOPMOL(IMOL,ID)=UN/(XX*DP0*SQRT(DP1*T/AMMOL(IMOL)+
* VTURB(ID)))
END DO
END DO
RETURN
END
synspec/extracted/inilin.f
+607
View File
@@ -0,0 +1,607 @@
SUBROUTINE INILIN
C =================
C
C read in the input line list,
C selection of lines that may contribute,
C set up auxiliary fields containing line parameters,
C
C Input of line data - unit 19:
C
C For each line, one (or two) records, containing:
C
C ALAM - wavelength (in nm)
C ANUM - code of the element and ion (as in Kurucz-Peytremann)
C (eg. 2.00 = HeI; 26.00 = FeI; 26.01 = FeII; 6.03 = C IV)
C GF - log gf
C EXCL - excitation potential of the lower level (in cm*-1)
C QL - the J quantum number of the lower level
C EXCU - excitation potential of the upper level (in cm*-1)
C QU - the J quantum number of the upper level
C AGAM = 0. - radiation damping taken classical
C > 0. - the value of Gamma(rad)
C
C There are now two possibilities, called NEW and OLD, of the next
C parameters:
C a) NEW, next parameters are:
C GS = 0. - Stark broadening taken classical
C > 0. - value of log gamma(Stark)
C GW = 0. - Van der Waals broadening taken classical
C > 0. - value of log gamma(VdW)
C INEXT = 0 - no other record necessary for a given line
C > 0 - a second record is present, see below
C
C The following parameters may or may not be present,
C in the same line, next to INEXT:
C ISQL >= 0 - value for the spin quantum number (2S+1) of lower level
C < 0 - value for the spin number of the lower level unknown
C ILQL >= 0 - value for the L quantum number of lower level
C < 0 - value for L of the lower level unknown
C IPQL >= 0 - value for the parity of lower level
C < 0 - value for the parity of the lower level unknown
C ISQU >= 0 - value for the spin quantum number (2S+1) of upper level
C < 0 - value for the spin number of the upper level unknown
C ILQU >= 0 - value for the L quantum number of upper level
C < 0 - value for L of the upper level unknown
C IPQU >= 0 - value for the parity of upper level
C < 0 - value for the parity of the upper level unknown
C (by default, the program finds out whether these quantum numbers
C are included, but the user can force the program to ignore them
C if present by setting INLIST=10 or larger
C
C If INEXT was set to >0 then the following record includes:
C WGR1,WGR2,WGR3,WGR4 - Stark broadening values from Griem (in Angst)
C for T=5000,10000,20000,40000 K, respectively;
C and n(el)=1e16 for neutrals, =1e17 for ions.
C ILWN = 0 - line taken in LTE (default)
C > 0 - line taken in NLTE, ILWN is then index of the
C lower level
C =-1 - line taken in approx. NLTE, with Doppler K2 function
C =-2 - line taken in approx. NLTE, with Lorentz K2 function
C IUN = 0 - population of the upper level in LTE (default)
C > 0 - index of the lower level
C IPRF = 0 - Stark broadening determined by GS
C < 0 - Stark broadening determined by WGR1 - WGR4
C > 0 - index for a special evaluation of the Stark
C broadening (in the present version inly for He I -
C see procedure GAMHE)
C b) OLD, next parameters are
C IPRF,ILWN,IUN - the same meaning as above
C next record with WGR1-WGR4 - again the same meaning as above
C (this record is automatically read if IPRF<0
C
C The only differences between NEW and OLD is the occurence of
C GS and GW in NEW, and slightly different format of reading.
C
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
COMMON/IPOTLS/IPOTL(mlin0)
C
PARAMETER (C1 = 2.3025851,
* C2 = 4.2014672,
* C3 = 1.4387886,
* CNM = 2.997925D17,
* ANUMIN = 1.9,
* ANUMAX = 99.31,
* AHE2 = 2.01,
* EXT0 = 3.17,
* UN = 1.0,
* TEN = 10.,
* HUND = 1.D2,
* TENM4 = 1.D-4,
* TENM8 = 1.D-8,
* OP4 = 0.4,
* AGR0=2.4734E-22,
* XEH=13.595, XET=8067.6, XNF=25.,
* R02=2.5, R12=45., VW0=4.5E-9)
PARAMETER (ENHE1=198310.76, ENHE2=438908.85)
CHARACTER*1000 CADENA
DATA INLSET /0/
C
if(ibin(0).eq.0) then
open(unit=19,file=amlist(0),status='old')
else
open(unit=19,file=amlist(0),form='unformatted',status='old')
end if
if(imode.lt.-2) then
call inilin_grid
return
end if
c
if(ndstep.eq.0) then
write(6,621) idstd,temp(idstd),dens(idstd)
else
write(6,622)
do id=1,nd,ndstep
write(6,623) id,temp(id),dens(id)
end do
end if
621 format(/' lines are rejected based on opacities at the',
* ' standard depth:'/
* ' ID =',i4,' T = ',f10.1,', DENS = ',1pe10.3/)
622 format(/' lines are rejected based on opacities at depths:'/)
623 format(' ID =',i4,' T = ',f10.1,', DENS = ',1pe10.3/)
c
IL=0
INNLT0=0
IGRIE0=0
IF(NXTSET.EQ.1) THEN
ALAM0=ALM00
ALAST=ALST00
FRLAST=CNM/ALAST
NXTSET=0
REWIND 19
END IF
ALAM00=ALAM0
ALAST=CNM/FRLAST
ALAST0=ALAST
DOPSTD=1.E7/ALAM0*DSTD
DOPLAM=ALAM0*ALAM0/CNM*DOPSTD
AVAB=ABSTD(IDSTD)*RELOP
ASTD=1.0
c IF(GRAV.GT.6.) ASTD=0.1
CUTOFF=CUTOF0
ALAST=CNM/FRLAST
IF(INLTE.GE.1.AND.INLSET.EQ.0) THEN
CALL NLTSET(0,IL,IAT,ION,ALAM0,EXCL,EXCU,QL,QU,
* ISQL,ILQL,IPQL,ISQU,ILQU,IPQU,IEVEN,INNLT0,ILMATCH)
INLSET=1
ILMATCH=0
ILSEARCH=0
ILFOUND=0
ILFAIL=0
ILMULT=0
END IF
c
C
C Check whether any ion needs to compare quantum number limits
C
MAXILIMITS=0
DO I=1,NION
IF (ILIMITS(I).EQ.1) MAXILIMITS=1
END DO
IF (MAXILIMITS.EQ.0.and.inlist.gt.0) INLIST=20
C
C If INLIST=0 or 10, the program checks for the number of words
C present in the first line of the file to determine if quantum
C numbers are included. If INLINST=11, they will be ignored anyway
IADQN=0
IF(ibin(0).eq.0) then
CADENA=' '
READ(19,'(1000a)')CADENA
BACKSPACE(19)
CALL COUNT_WORDS(CADENA,NOW)
IF(NOW.LT.12) THEN
WRITE(11,*) 'INILIN: NO quantum numbers given in linelist'
ELSE
IADQN=1
END IF
if(inlist.ge.10)
* write(11,*) 'INILIN: if present, quant. num. limits are ignored'
ELSE
read(19,err=4) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW,INEXT,ISQL,ILQL,IPQL,ISQU,ILQU,IPQU
c BACKSPACE(19)
IADQN=1
go to 5
4 continue
backspace(19)
read(19) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW,INEXT
backspace(19)
5 continue
if(iadqn.eq.0)
* write(11,*) 'INILIN: no quantum numbers in binary linelist'
IF(INLIST.GE.10) THEN
write(11,*)
* 'INILIN: if present, quant. num. limits are ignored'
END IF
END IF
rstd=1.e4
if(relop.gt.0.) rstd=1./relop
afac=10.
if(iat.gt.15.and.iat.ne.26) afac=1.
afac=afac*rstd*astd
C
C first part of reading line list - read only lambda, and
C skip all lines with wavelength below ALAM0-CUTOFF
C
ALAM=0.
IJC=2
7 if(ibin(0).eq.0) then
READ(19,510) ALAM
else
read(19) alam
end if
510 FORMAT(F10.4)
IF(ALAM.LT.ALAM0-CUTOFF) GO TO 7
BACKSPACE(19)
GO TO 10
c
c read the line list
c
8 continue
10 ILWN=0
IUN=0
IPRF=0
GS=0.
GW=0.
IF(IBIN(0).EQ.0) THEN
IF(IADQN.EQ.0) THEN
READ(19,*,END=100,err=8) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW,INEXT
IF(INEXT.NE.0) READ(19,*) WGR1,WGR2,WGR3,WGR4,ILWN,IUN,IPRF
ELSE
READ(19,*,END=100,err=8) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW,INEXT,ISQL,ILQL,IPQL,ISQU,ILQU,IPQU
END IF
ELSE
IF(IADQN.EQ.0) THEN
READ(19,END=100) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,GS,GW
ELSE
READ(19,END=100) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,GS,GW,
* INEXT,ISQL,ILQL,IPQL,ISQU,ILQU,IPQU
END IF
END IF
IF(INLIST.GE.10) THEN
IF(ISPICK.EQ.0) THEN
ISQL=-1
ISQU=-1
END IF
IF(ILPICK.EQ.0) THEN
ILQL=-1
ILQU=-1
END IF
IF(IPPICK.EQ.0) THEN
IPQL=-1
IPQU=-1
END IF
IF(INEXT.NE.0) READ(19,*) WGR1,WGR2,WGR3,WGR4,ILWN,IUN,IPRF
END IF
C
c change wavelength to vacuum for lambda > 2000
c
if(alam.gt.200..and.vaclim.gt.2000.) then
wl0=alam*10.
ALM=1.E8/(WL0*WL0)
XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM)
WL0=WL0*(XN1*1.D-6+UN)
alam=wl0*0.1
END IF
C
C first selection : for a given interval a atomic number
C
IF(ALAM.GT.ALAST+CUTOFF) GO TO 100
IF(ANUM.LT.ANUMIN.OR.ANUM.GT.ANUMAX) GO TO 10
IF(ABS(ANUM-AHE2).LT.TENM4.AND.IFHE2.GT.0) GO TO 10
C
C second selection : for line strenghts
C
FR0=CNM/ALAM
IAT=INT(ANUM)
FRA=(ANUM-FLOAT(IAT)+TENM4)*HUND
ION=INT(FRA)+1
IF(ION.GT.IONIZ(IAT)) GO TO 10
IEVEN=1
EXCL=ABS(EXCL)
EXCU=ABS(EXCU)
IF(EXCL.GT.EXCU) THEN
FRA=EXCL
EXCL=EXCU
EXCU=FRA
FRA=QL
QL=QU
QU=FRA
IEVEN=0
IF(INLIST.GE.10) THEN
IFRA=ISQL
ISQL=ISQU
ISQU=IFRA
IFRA=ILQL
ILQL=ILQU
ILQU=IFRA
IFRA=IPQL
IPQL=IPQU
IPQU=IFRA
END IF
END IF
GFP=C1*GF-C2
EPP=C3*EXCL
c
if(ndstep.eq.0.and.ifwin.eq.0) then
c
c old procedure for rejecting lines
c
GX=GFP-EPP/TSTD
AB0=0.
if(gx.gt.-30)
* AB0=EXP(GFP-EPP/TSTD)*RRR(IDSTD,ION,IAT)/DOPSTD/AVAB
IF(AB0.LT.UN) GO TO 10
C
else
c
c new procedure for rejecting lines
c
DOPSTD=1.E7/ALAM*DSTD
DOPLAM=ALAM*ALAM/CNM*DOPSTD
do ijcn=ijc,nfreqc
if(fr0.ge.freqc(ijcn)) go to 12
end do
12 continue
ijc=ijcn
if(ijc.gt.nfreqc) ijc=nfreqc
tkm=1.65e8/amas(iat)
DP0=3.33564E-11*FR0
do id=1,nd,ndstep
td=temp(id)
gx=gfp-epp/td
ab0=0.
if(gx.gt.-30) then
dops=dp0*sqrt(tkm/td+vturb(id))
AB0=EXP(gx)*RRR(ID,ION,IAT)/(DOPS*abstdw(ijc,id)*relop)
end if
if(ab0.ge.un) go to 15
end do
GO TO 10
end if
C
C truncate line list if there are more lines than maximum allowable
C (given by MLIN0 - see include file LINDAT.FOR)
C
15 continue
IL=IL+1
IF(IL.GT.MLIN0) THEN
WRITE(6,601) ALAM
IL=MLIN0
ALAST=CNM/FREQ0(IL)-CUTOFF
FRLAST=CNM/ALAST
NXTSET=1
GO TO 100
END IF
C
C =============================================
C line is selected, set up necessary parameters
C =============================================
C
C store parameters for selected lines
C
FREQ0(IL)=FR0
EXCL0(IL)=real(EPP)
EXCU0(IL)=real(EXCU*C3)
GF0(IL)=real(GFP)
INDAT(IL)=100*IAT+ION
C
C indices for corresponding excitation temperatures of the lower
C and upper levels
C (for winds)
C
if(ifwin.gt.0) then
IJCONT(IL)=IJC
if(excl.ge.enhe2) then
ipotl(il)=3
else if(excl.ge.enhe1) then
ipotl(il)=2
else
ipotl(il)=1
end if
end if
C
C ****** line broadening parameters *****
C
C 1) natural broadening
C
IF(AGAM.GT.0.) THEN
GAMR0(IL)=real(EXP(C1*AGAM))
ELSE
GAMR0(IL)=real(AGR0*FR0*FR0)
END IF
C
C if Stark or Van der Waals broadenig assumed classical,
C evaluate the effective quantum number
C
IF(GS.EQ.0..OR.GW.EQ.0) THEN
Z=FLOAT(ION)
XNEFF2=Z**2*(XEH/(ENEV(IAT,ION)-EXCU/XET))
IF(XNEFF2.LE.0..OR.XNEFF2.GT.XNF) XNEFF2=XNF
END IF
C
C 2) Stark broadening
C
IF(GS.NE.0.) THEN
GS0(IL)=real(EXP(C1*GS))
ELSE
GS0(IL)=real(TENM8*XNEFF2*XNEFF2*SQRT(XNEFF2))
END IF
C
C 3) Van der Waals broadening
C
IF(GW.NE.0.) THEN
GW0(IL)=real(EXP(C1*GW))
ELSE
IF(IAT.LT.21) THEN
R2=R02*(XNEFF2/Z)**2
ELSE IF(IAT.LT.45) then
R2=(R12-FLOAT(IAT))/Z
ELSE
R2=0.5
END IF
GW0(IL)=real(VW0*R2**OP4)
END IF
c
C evaluation of EXTIN0 - the distance (in delta frequency) where
C the line is supposed to contribute to the total opacity
C
call profil(il,iat,idstd,agam)
IF(IAT.LE.2) THEN
EXT=SQRT(10.*AB0)
ELSE IF(IAT.LE.14) THEN
EX0=AB0*ASTD*10.
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
ELSE
EX0=AB0*ASTD
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
END IF
EXTIN0=EXT*DOPSTD
EXTIN(IL)=real(EXTIN0)
C
C 4) parameters for a special profile evaluation:
C
C a) special He I and He II line broadening parameters
C
ISPRFF=0
IF(IAT.LE.2) ISPRFF=ISPEC(IAT,ION,ALAM)
IF(IAT.EQ.2) CALL HESET(IL,ALAM,EXCL,EXCU,ION,IPRF,ILWN,IUN)
ISPRF(IL)=ISPRFF
IPRF0(IL)=IPRF
C
C b) parameters for Griem values of Stark broadening
C
IF(IPRF.LT.0) THEN
IGRIE0=IGRIE0+1
IGRIEM(IL)=IGRIE0
IF(IGRIE0.GT.MGRIEM) THEN
WRITE(6,603) ALAM
GO TO 20
END IF
WGR0(1,IGRIE0)=real(WGR1)
WGR0(2,IGRIE0)=real(WGR2)
WGR0(3,IGRIE0)=real(WGR3)
WGR0(4,IGRIE0)=real(WGR4)
END IF
20 CONTINUE
C
C implied NLTE option
C
if(inlte.eq.-2.or.inlte.eq.12) then
if(iat.le.20.and.excl.le.1000.) qu=-abs(qu)
else if(inlte.eq.-3) then
if(excl.le.1000.) qu=-abs(qu)
else if(inlte.eq.-4) then
qu=-abs(qu)
end if
C
C NLTE lines initialization
C
INDNLT(IL)=0
IF(QU.LT.0..OR.QL.LT.0.) THEN
ILWN=-1
QU=ABS(QU)
QL=ABS(QL)
END IF
IF(ILWN.LT.0.AND.INLTE.NE.0) THEN
INNLT0=INNLT0+1
INDNLT(IL)=INNLT0
IF(INNLT0.GT.MNLT) THEN
WRITE(6,604) ALAM
GO TO 100
END IF
GI=2.*QL+UN
GJ=2.*QU+UN
CALL NLTE(IL,ILWN,IUN,GI,GJ)
ILOWN(IL)=ILWN
IUPN(IL)=IUN
END IF
IF(ILWN.GT.0.AND.INLTE.NE.0) THEN
INNLT0=INNLT0+1
INDNLT(IL)=INNLT0
IF(INNLT0.GT.MNLT) THEN
WRITE(6,604) ALAM
GO TO 100
END IF
GI=2.*QL+UN
GJ=2.*QU+UN
CALL NLTE(IL,ILWN,IUN,GI,GJ)
ILOWN(IL)=ILWN
IUPN(IL)=IUN
END IF
IF(ILWN.EQ.0.AND.INLTE.GE.1) THEN
ILMATCH=-1
CALL NLTSET(1,IL,IAT,ION,ALAM,EXCL,EXCU,QL,QU,
* ISQL,ILQL,IPQL,ISQU,ILQU,IPQU,IEVEN,INNLT0,ILMATCH)
C
C Success accounting for nlte lines matched with quantum numbers and
C energy limits
C
C nlte lines searched matching energies and quantum numbers
IF(ILMATCH.GE.0) THEN
ILSEARCH=ILSEARCH+1
C nlte lines not found matching
IF (ILMATCH.EQ.0) THEN
ILFAIL=ILFAIL+1
C nlte lines with multiple matches
ELSE IF (ILMATCH.EQ.2) THEN
ILMULT=ILMULT+1
C nlte lines uniquely matched
ELSE IF (ILMATCH.EQ.1) THEN
ILFOUND=ILFOUND+1
ENDIF
ENDIF
IF(INDNLT(IL).GT.0) THEN
IF(INDNLT(IL).GT.MNLT) THEN
WRITE(6,604) ALAM
GO TO 100
END IF
GI=2.*QL+UN
GJ=2.*QU+UN
ILWN=ILOWN(IL)
IUN=IUPN(IL)
IF(ILWN.EQ.IUN.AND.GI.EQ.GJ) THEN
INDNLT(IL)=0
ILOWN(IL)=0
IUPN(IL)=0
ELSE
CALL NLTE(IL,ILWN,IUN,GI,GJ)
END IF
END IF
END IF
GO TO 10
C
100 NLIN0=IL
NNLT=INNLT0
NGRIEM=IGRIE0
ALM1=CNM/FREQ0(1)
IF(ALAM0.LT.ALM1.AND.IMODE.NE.1) THEN
ALAM0=ALM1-4.*DOPLAM
IF(ALAM0.LT.ALAM00) ALAM0=ALAM00
END IF
ALM2=CNM/FREQ0(NLIN0)
IF(NLIN0.GT.1) ALM2=CNM/FREQ0(NLIN0-1)
IF(ALAST.GT.ALM2.AND.IMODE.NE.1) THEN
ALAST=ALM2-4.*DOPLAM
IF(ALAST.GT.ALAST0) ALAST=ALAST0
FRLAST=CNM/ALAST
END IF
IBLANK=0
C
WRITE(11,*)'INILIN: NLTE matches using Energies and SLP limits --'
WRITE(11,*)ILSEARCH,' lines searched'
WRITE(11,*)ILFAIL,' lines unmatched -- set to LTE'
WRITE(11,*)ILMULT,' lines with multiple matches'
WRITE(11,*)ILFOUND,' lines uniquely matched'
WRITE(11,*)'----------------------------------------------------'
C
WRITE(*,*)'----------------------------------------------------'
WRITE(6,611) NLIN0,NNLT
611 FORMAT(/' LINES - TOTAL :',I10
* /' LINES - NLTE :',I10/)
601 FORMAT(' **** MORE LINES THAN MLIN0, LINE LIST TRUNCATED '/
*' AT LAMBDA',F15.4,' NM'/)
603 FORMAT(' **** MORE LINES WITH GRIEM PROFILES THAN MGRIEM'/
*' FOR LINES WITH LAMBDA GREATER THAN',F15.4,' NM'/)
604 FORMAT(' **** MORE LINES IN NLTE OPTION THAN MNLT'/
*' FOR LINES WITH LAMBDA GREATER THAN',F15.4,' NM'/)
RETURN
END
synspec/extracted/inilin_grid.f
+383
View File
@@ -0,0 +1,383 @@
SUBROUTINE INILIN_grid
C ======================
C
C read in the input line list,
C selection of lines that may contribute,
C set up auxiliary fields containing line parameters,
C
C Input of line data - unit 19:
C
C For each line, one (or two) records, containing:
C
C ALAM - wavelength (in nm)
C ANUM - code of the element and ion (as in Kurucz-Peytremann)
C (eg. 2.00 = HeI; 26.00 = FeI; 26.01 = FeII; 6.03 = C IV)
C GF - log gf
C EXCL - excitation potential of the lower level (in cm*-1)
C QL - the J quantum number of the lower level
C EXCU - excitation potential of the upper level (in cm*-1)
C QU - the J quantum number of the upper level
C AGAM = 0. - radiation damping taken classical
C > 0. - the value of Gamma(rad)
C
C There are now two possibilities, called NEW and OLD, of the next
C parameters:
C a) NEW, next parameters are:
C GS = 0. - Stark broadening taken classical
C > 0. - value of log gamma(Stark)
C GW = 0. - Van der Waals broadening taken classical
C > 0. - value of log gamma(VdW)
C INEXT = 0 - no other record necessary for a given line
C > 0 - next record is read, which contains:
C WGR1,WGR2,WGR3,WGR4 - Stark broadening values from Griem (in Angst)
C for T=5000,10000,20000,40000 K, respectively;
C and n(el)=1e16 for neutrals, =1e17 for ions.
C ILWN = 0 - line taken in LTE (default)
C > 0 - line taken in NLTE, ILWN is then index of the
C lower level
C =-1 - line taken in approx. NLTE, with Doppler K2 function
C =-2 - line taken in approx. NLTE, with Lorentz K2 function
C IUN = 0 - population of the upper level in LTE (default)
C > 0 - index of the lower level
C IPRF = 0 - Stark broadening determined by GS
C < 0 - Stark broadening determined by WGR1 - WGR4
C > 0 - index for a special evaluation of the Stark
C broadening (in the present version inly for He I -
C see procedure GAMHE)
C b) OLD, next parameters are
C IPRF,ILWN,IUN - the same meaning as above
C next record with WGR1-WGR4 - again the same meaning as above
C (this record is automatically read if IPRF<0
C
C The only differences between NEW and OLD is the occurence of
C GS and GW in NEW, and slightly different format of reading.
C
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
common/igrddd/igrdd,irelin
common/plaopa/plalin,plcint,chcint
common/conabs/absoc(mfreqc),emisc(mfreqc),scatc(mfreqc),
* plac(mfreqc)
C
PARAMETER (C1 = 2.3025851,
* C2 = 4.2014672,
* C3 = 1.4387886,
* CNM = 2.997925D17,
* ANUMIN = 1.9,
* ANUMAX = 99.31,
* AHE2 = 2.01,
* EXT0 = 3.17,
* UN = 1.0,
* TEN = 10.,
* HUND = 1.D2,
* TENM4 = 1.D-4,
* TENM8 = 1.D-8,
* OP4 = 0.4,
* AGR0=2.4734E-22,
* XEH=13.595, XET=8067.6, XNF=25.,
* R02=2.5, R12=45., VW0=4.5E-9,
* bnc=1.4743e-2,hkc=4.79928e-11)
PARAMETER (ENHE1=198310.76, ENHE2=438908.85)
DATA INLSET /0/
C
if(irelin.eq.0) return
c
relop0=relop
relop=1.e-3*relop
if(relop.gt.1.e-4) relop=1.e-4
if(relop.lt.1.e-5) relop=1.e-5
plalin=0.
ijcon=2
IL=0
INNLT0=0
IGRIE0=0
IF(NXTSET.EQ.1) THEN
ALAM0=ALM00
ALAST=ALST00
FRLAST=CNM/ALAST
NXTSET=0
REWIND 19
END IF
ALAM00=ALAM0
ALAST=CNM/FRLAST
ALAST0=ALAST
DOPSTD=1.E7/ALAM0*DSTD
DOPLAM=ALAM0*ALAM0/CNM*DOPSTD
AVAB=ABSTD(IDSTD)*RELOP
id=idstd
dstdid=sqrt(1.4e7*temp(idstd))
ASTD=1.0
c IF(GRAV.GT.6.) ASTD=0.1
CUTOFF=CUTOF0
ALAST=CNM/FRLAST
absta=absoc(1)
write(6,630) alam0,alast,abstd(idstd),absta
630 format(/' read line list with alam0, alast',2f10.3,1p3e11.3/)
c
rstd=1.e4
if(relop.gt.0.) rstd=1./relop
afac=10.
if(iat.gt.15.and.iat.ne.26) afac=1.
afac=afac*rstd*astd
C
afac=afac*rstd*astd
afilin=alast
C
C first part of reading line list - read only lambda, and
C skip all lines with wavelength below ALAM0-CUTOFF
C
ALAM=0.
7 continue
if(ibin(0).eq.0) then
read(19,510) alam
else
read(19) alam
end if
510 FORMAT(F10.4)
IF(ALAM.LT.ALAM0-CUTOFF) GO TO 7
BACKSPACE(19)
GO TO 10
c
8 continue
10 ILWN=0
IUN=0
IPRF=0
GS=0.
GW=0.
IF(IBIN(0).EQ.0) THEN
READ(19,*,END=100,err=8) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW
else
read(19,end=100) ALAM,ANUM,GF,EXCL,QL,EXCU,QU,AGAM,
* GS,GW
end if
c
c change wavelength to vacuum for lambda > 2000
c
if(alam.gt.200..and.vaclim.gt.2000.) then
wl0=alam*10.
ALM=1.E8/(WL0*WL0)
XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM)
WL0=WL0*(XN1*1.D-6+UN)
alam=wl0*0.1
END IF
C
C first selection : for a given interval a atomic number
C
IF(ALAM.GT.ALAST+CUTOFF) GO TO 100
C
C second selection : for line strengths
C
FR0=CNM/ALAM
if(inlist.ge.0) then
IAT=ifix(real(ANUM,4))
FRA=(ANUM-FLOAT(IAT)+TENM4)*HUND
ION=INT(FRA)+1
IF(ION.GT.IONIZ(IAT)) GO TO 10
IEVEN=1
EXCL=ABS(EXCL)
EXCU=ABS(EXCU)
IF(EXCL.GT.EXCU) THEN
FRA=EXCL
EXCL=EXCU
EXCU=FRA
FRA=QL
QL=QU
QU=FRA
IEVEN=0
END IF
GFP=C1*GF-C2
EPP=C3*EXCL
else
IF(ION.GT.IONIZ(IAT)) GO TO 10
end if
C
if(fr0.lt.freqc(ijcon)) then
ijcon=ijcon+1
absta=0.5*(absoc(ijcon)+scatc(ijcon)+
* absoc(ijcon-1)+scatc(ijcon-1))
end if
abstd(id)=absta
c
dop=1.e7/alam*dstdid
abct=exp(gfp-epp/temp(id))*rrr(id,ion,iat)
abid=abct/dop/absta
ext=sqrt(abid*afac)*dop
c
c line part of the Planck mean opacity
c
c if(alam.ge.alam0.and.alam.le.alast) then
c if(abid.ge.relop) then
c xx=exp(-hkc*fr0/temp(id))
c pln=bnc*(fr0*1.e-15)**3*xx/(un-xx)
c abct=abct*(un-xx)
c plalin=plalin+pln*abct
c write(16,643) iat,ion,alam*10.,abct,dop,absta,abid
c 643 format(2i4,0pf12.3,1p6e12.4)
c end if
c
ALAX0=12.
c
c alax0=0
c
if(imode.eq.-6) go to 10
if(alam.lt.afilin) then
if(abid.ge.relop) then
afilin=alam
else
if(abid.lt.relop*1.e-6) go to 10
end if
else if(alam.lt.9500.) then
if(abid.lt.relop) go to 10
else if(alam.lt.9950.) then
if(abid.lt.relop*1.e-9) go to 10
else
if(abid.lt.relop*1.e-19) go to 10
end if
c
c if(abid.lt.relop.and.alam.gt.alax0) go to 10
c if(abid.lt.1.e-10*relop.and.alam.lt.alax0) go to 10
IF(ANUM.LT.ANUMIN.OR.ANUM.GT.ANUMAX) GO TO 10
IF(ANUM.GT.ANUMAX) GO TO 10
IF(ABS(ANUM-AHE2).LT.TENM4.AND.IFHE2.GT.0) GO TO 10
c
extin0=ext
C
C truncate line list if there are more lines than maximum allowable
C (given by MLIN0 - see include file LINDAT.FOR)
C
IL=IL+1
IF(IL.GT.MLIN0) THEN
WRITE(6,601) ALAM
IL=MLIN0
ALAST=CNM/FREQ0(IL)-CUTOFF
FRLAST=CNM/ALAST
NXTSET=1
GO TO 100
END IF
C
C =============================================
C line is selected, set up necessary parameters
C =============================================
C
C evaluation of EXTIN0 - the distance (in delta frequency) where
C the line is supposed to contribute to the total opacity
C
C store parameters for selected lines
C
FREQ0(IL)=FR0
EXCL0(IL)=real(EPP,4)
EXCU0(IL)=real(EXCU*C3,4)
GF0(IL)=real(GFP,4)
EXTIN(IL)=real(EXTIN0,4)
INDAT(IL)=100*IAT+ION
C
C ****** line broadening parameters *****
C
C 1) natural broadening
C
IF(AGAM.GT.0.) THEN
GAMR0(IL)=real(EXP(C1*AGAM),4)
ELSE
GAMR0(IL)=real(AGR0*FR0*FR0,4)
END IF
C
C if Stark or Van der Waals broadening assumed classical,
C evaluate the effective quantum number
C
IF(GS.EQ.0..OR.GW.EQ.0) THEN
Z=FLOAT(ION)
XNEFF2=Z**2*(XEH/(ENEV(IAT,ION)-EXCU/XET))
IF(XNEFF2.LE.0..OR.XNEFF2.GT.XNF) XNEFF2=XNF
END IF
C
C 2) Stark broadening
C
IF(GS.NE.0.) THEN
GS0(IL)=real(EXP(C1*GS),4)
ELSE
GS0(IL)=real(TENM8*XNEFF2*XNEFF2*SQRT(XNEFF2),4)
END IF
C
C 3) Van der Waals broadening
C
IF(GW.NE.0.) THEN
GW0(IL)=real(EXP(C1*GW),4)
ELSE
IF(IAT.LT.21) THEN
R2=R02*(XNEFF2/Z)**2
ELSE IF(IAT.LT.45) then
R2=(R12-FLOAT(IAT))/Z
ELSE
R2=0.5
END IF
GW0(IL)=real(VW0*R2**OP4,4)
END IF
C
C 4) parameters for a special profile evaluation:
C
C a) special He I and He II line broadening parameters
C
ISPRFF=0
IF(IAT.LE.2) ISPRFF=ISPEC(IAT,ION,ALAM)
IF(IAT.EQ.2) CALL HESET(IL,ALAM,EXCL,EXCU,ION,IPRF,ILWN,IUN)
ISPRF(IL)=ISPRFF
IPRF0(IL)=IPRF
C
C b) parameters for Griem values of Stark broadening
C
IF(IPRF.LT.0) THEN
IGRIE0=IGRIE0+1
IGRIEM(IL)=IGRIE0
IF(IGRIE0.GT.MGRIEM) THEN
WRITE(6,603) ALAM
GO TO 20
END IF
WGR0(1,IGRIE0)=real(WGR1,4)
WGR0(2,IGRIE0)=real(WGR2,4)
WGR0(3,IGRIE0)=real(WGR3,4)
WGR0(4,IGRIE0)=real(WGR4,4)
END IF
20 CONTINUE
GO TO 10
C
100 NLIN0=IL
NNLT=INNLT0
NGRIEM=IGRIE0
ALM1=CNM/FREQ0(1)
IF(ALAM0.LT.ALM1.AND.IMODE.NE.1) THEN
ALAM0=ALM1-4.*DOPLAM
IF(ALAM0.LT.ALAM00) ALAM0=ALAM00
END IF
ALM2=CNM/FREQ0(NLIN0)
IF(NLIN0.GT.1) ALM2=CNM/FREQ0(NLIN0-1)
IF(ALAST.GT.ALM2.AND.IMODE.NE.1) THEN
ALAST=ALM2-4.*DOPLAM
IF(ALAST.GT.ALAST0) ALAST=ALAST0
FRLAST=CNM/ALAST
END IF
IBLANK=0
relop=relop0
C
WRITE(6,611) NLIN0
611 FORMAT(/' ATOMIC LINES :',I10/)
c WRITE(6,611) NLIN0,NNLT,NGRIEM
c 611 FORMAT(/' LINES - TOTAL :',I10
c * /' LINES - NLTE :',I10
c * /' LINES - GRIEM :',I10/)
601 FORMAT('0 **** MORE LINES THAN MLIN0, LINE LIST TRUNCATED '/
*' AT LAMBDA',F15.4,' NM'/)
c 602 FORMAT('0 **** MORE LINES WITH SPECIAL PROFILES THAN MPRF'/
c *' FOR LINES WITH LAMBDA GREATER THAN',F15.4,' NM'/)
603 FORMAT('0 **** MORE LINES WITH GRIEM PROFILES THAN MGRIEM'/
*' FOR LINES WITH LAMBDA GREATER THAN',F15.4,' NM'/)
c 604 FORMAT('0 **** MORE LINES IN NLTE OPTION THAN MNLT'/
c *' FOR LINES WITH LAMBDA GREATER THAN',F15.4,' NM'/)
RETURN
END
synspec/extracted/inimod.f
+68
View File
@@ -0,0 +1,68 @@
SUBROUTINE INIMOD
C
C SET UP COMMON/RRRVAL/ - VALUES OF N(ION)/U(ION) FOR ALL THE ATOMS
C AND IONS CONSIDERED
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
COMMON/HPOPST/HPOP
C
c 1. "low-temperature" ionization fractions
c (using Hamburg partition functions)
c
DO 50 ID=1,ND
IF(IFMOL.EQ.0.OR.TEMP(ID).GE.TMOLIM) THEN
CALL STATE(ID,TEMP(ID),ELEC(ID),S1)
HPOP=DENS(ID)/WMM(ID)/YTOT(ID)
DO J=1,MION0
DO I=1,MATOM
RRR(ID,J,I)=RR(I,J)*HPOP
END DO
END DO
DO IAT=1,NATOM
ATTOT(IAT,ID)=HPOP*ABUND(IAT,ID)
END DO
ELSE
HPOP=ATTOT(1,ID)
END IF
IF(ID.NE.IDSTD) GO TO 50
TSTD=TEMP(ID)
VTS=VTURB(ID)
DSTD=SQRT(1.4E7*TSTD+VTS)
WRITE(6,601) ID,TEMP(ID),ELEC(ID),hpop
c DO I=1,MATOM
DO I=1,30
WRITE(6,602) TYPAT(I),(RRR(ID,J,I),J=1,MION0-1)
END DO
c WRITE(6,603)
c DO I=1,MATOM
c WRITE(6,602) TYPAT(I),(PFSTD(J,I),J=1,MION0-1)
c END DO
50 CONTINUE
c
c 2. "high-temperature" ionization fractions
c (using the Opacity Project ionization fractions)
c
if(teff.lt.0.) then
CALL FRAC1
ID=IDSTD
HPOP=DENS(ID)/WMM(ID)/YTOT(ID)
WRITE(6,604) ID,TEMP(ID),ELEC(ID)
DO 60 I=1,MATOM
WRITE(6,605) TYPAT(I),(RRR(ID,J,I)/hpop,J=1,MION)
ioniz(i)=i+1
60 continue
end if
C
601 FORMAT(/' N/U AT THE STANDARD DEPTH (ID =',I3,
* ' ; T,Ne = ',F8.1,1P2E12.3,' )'/
* ' --------------------------'//)
602 FORMAT(1H ,A4,1P8E9.2)
c 603 FORMAT(//' PARTITION FUNCTIONS AT THE STANDARD DEPTH'/
c * ' ------------------------------------------'//)
604 FORMAT(/' N/U AT THE STANDARD DEPTH - OP DATA',
* ' (ID =',I3,' ; T,Ne = ',F8.1,1PE12.3,' )'//)
605 FORMAT(1H ,A4,(1P8E9.2))
RETURN
END
synspec/extracted/iniset.f
+354
View File
@@ -0,0 +1,354 @@
SUBROUTINE INISET
C =================
C
C SELECTION OF LINES THAT MAY CONTRIBUTE,
C SET UP AUXILIARY FIELDS CONTAINING LINE PARAMETERS,
C SET UP THE SET OF FREQUENCY POINTS
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
INCLUDE 'WINCOM.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
COMMON/CTRFUN/CINT1(MDEPTH),CINT2(MDEPTH),
* CTRI(MDEPTH),CTRR(MDEPTH),XKAR(MDEPTH),
* ABXLI(MFREQ),EMXLI(MFREQ),IJCTR(MFREQ)
SAVE ILLAST
C
DATA CNM,CAS /2.997925D17,2.997925D18/
c DATA C1,C2,C3 /2.3025851, 4.2014672, 1.4387886/
C
DO 10 I=1,MFRQ
W(I)=0.
IJCTR(I)=0
10 CONTINUE
C
IL0=0
IPRSET=0
NLIN=0
IREADP=1
IRLIST=0
IF(IBLANK.LE.1.OR.IMODE.EQ.1.OR.IMODE.EQ.-1) IREADP=0
IF(IBLANK.LE.1) APREV=0.
FRMIN=CNM/ALAM0
FRM=FRMIN
if(ifwin.le.0) then
ij0=3
else
ij0=1
end if
IJ=IJ0
FREQ(IJ0)=FRM
SPACE=SPACE0
IF(ALAMC.GT.0.) SPACE=SPACE0*ALAM0/ALAMC
IF(SPACE0.LT.0.) SPACE=-SPACE0
IF(IMODE.EQ.2) THEN
NFRP=NFREQS+1
W0=SPACE
GO TO 105
END IF
C
ISTR=0
IJMAX=0
IMOD1L=0
if(ifwin.le.0) then
CUTOFF=CUTOF0
DOPSTD=1.E7/ALAM0*DSTD
DISTAN=0.15*DOPSTD
SPAC=3.E16/ALAM0/ALAM0*SPACE
DISTA0=0.14*SPAC
ASTD=1.0
AVAB=ABSTD(IDSTD)*RELOP
end if
FRLI0=FRMIN
IF(IBLANK.GE.2.AND.IMODE.EQ.-1) IL0=ILLAST
C
20 CONTINUE
C
C set up indices of lines
C IL0 - is the current index of line in the numbering of all lines
C
IF(IREADP.EQ.1) THEN
IPRSET=IPRSET+1
IL0=INDLIP(IPRSET)
IF(FREQ0(IL0).LT.FRMIN) THEN
IREADP=0
IL0=INDLIP(IPRSET-1)+1
END IF
ELSE
IL0=IL0+1
END IF
IF(IL0.GT.NLIN0) GO TO 210
FRLIM=FRLI0
FR0=FREQ0(IL0)
ALAM=CNM/FR0
C
if(ifwin.gt.0) then
IF(ALAMC.GT.0.) SPACE=SPACE0*ALAM/ALAMC
IF(SPACE0.LT.0.) SPACE=-SPACE0
CUTOFF=CUTOF0*ALAM/ALAMC
DOPSTD=1.E7/ALAM*DSTD
DISTAN=0.15*DOPSTD
SPAC=SPACE
IF(MOD(IFREQ,10).GT.0) SPAC=3.E16/ALAM/ALAM*SPACE
DISTA0=0.14*SPAC
end if
C
C set up a different starting wavelength for IMODE=1
C
IF(IMODE.NE.1) GO TO 45
IF(ISTR.EQ.1.OR.IJ.NE.3) GO TO 45
IF(ALAM.LT.ALAM0+2.*CUTOFF) GO TO 45
ALAM0=ALAM-CUTOFF+0.0001
FRMIN=CNM/ALAM0
FRM=FRMIN
IJ=IJ0
FREQ(IJ0)=FRM
45 CONTINUE
IF(ALAM.LT.ALAM0-CUTOFF) GO TO 20
IF(IJ.LT.NFREQS+1) GO TO 50
IF(ALAM.GT.ALAM1+CUTOFF) GO TO 210
C
C SECOND SELECTION : FOR LINE STRENGHTS
C
50 CONTINUE
ISTR=0
IF(IMODE.GE.1) THEN
ISTR=1
ELSE
EXT=EXTIN(IL0)
FRLI0=FR0-EXT-SPAC
IF(FRLI0.GT.FRLIM) FRLI0=FRLIM
frmiv=frmin
if(ifwin.gt.0) frmiv=frmiv*(1.+vinf/2.997925e10)
IF(ALAM.LT.ALAM0.AND.FR0-FRMIv.GT.EXT+SPAC) GO TO 20
ISTR=1
frmav=frmax
if(ifwin.gt.0) frmav=frmav*(1.-vinf/2.997925e10)
IF(IJ.GE.NFREQS+1.AND.FRMAv-FR0.GT.EXT+SPAC) GO TO 20
END IF
C
NLIN=NLIN+1
if(nlin.gt.mlin) call quit(' too many lines in a set')
INDLIN(NLIN)=IL0
ALAMCU=ALAM+CUTOFF
C
C FREQUENCY POINTS AND WEIGHTS
C
IF(IJ.GE.NFREQS+1) GO TO 20
IF(FR0.GT.FRMIN) GO TO 20
100 DELT=ABS(FRM-FR0)
IF(DELT.LT.DISTA0.AND.IMODE.NE.1) GO TO 20
DFREL=CNM*(1.D0/FR0-1.D0/FRM)/SPACE
NFRP=int(DFREL)+1
IF(NFRP.LE.2) NFRP=2
W0=CNM*(1.D0/FR0-1.D0/FRM)/NFRP
FRM=FR0
105 FRACT=FREQ(IJ)
ALACT=CNM/FRACT
C
DO 110 K=1,NFRP
FRACT=FRACT-W0
ALACT=ALACT+W0
IF(IMODE.GE.1.OR.NFRP.EQ.2) GO TO 107
IF(FRACT.LT.FRLIM.AND.FRACT.GT.FR0+EXT+SPAC) GO TO 110
107 IJ=IJ+1
IF(IJ.GT.NFREQS) GO TO 130
FREQ(IJ)=CNM/ALACT
W(IJ)=W(IJ)+(FREQ(IJ-1)-FREQ(IJ))*0.5
W(IJ-1)=W(IJ-1)+(FREQ(IJ-1)-FREQ(IJ))*0.5
C IF(FREQ(IJ).LT.FRLAST) GO TO 220
IF(IMODE.EQ.1.AND.ALACT.GT.ALAMCU) GO TO 140
110 CONTINUE
IJCTR(IJ)=IL0
IF(IMOD1L.EQ.1) GO TO 210
DISTA0=DISTAN
GO TO 20
C
130 FRMAX=FREQ(NFREQS)
ALAM1=CNM/FRMAX
NFREQ=NFREQS
IF(IMODE.EQ.2) GO TO 210
IF(IMOD1L.EQ.1) GO TO 210
GO TO 20
C
140 IJMAX=IJ
IJMAX=MIN(IJMAX,NFREQS)
NFREQ=IJMAX
IF(IL0.LT.NLIN0) THEN
NBLANK=IBLANK+1
ELSE
NBLANK=IBLANK
END IF
GO TO 240
C
210 NBLANK=IBLANK+1
IF(IJ.GE.NFREQS+1) GO TO 230
IJMAX=IJ
IJMAX=MIN(IJMAX,NFREQS)
NFREQ=IJMAX
IF(IMODE.NE.1) GO TO 240
IF(IMOD1L.EQ.1) GO TO 240
C FR0=MAX(CNM/(ALAM+CUTOFF),FRLAST*0.99999999D0)
FR0=FRLAST*0.99999999D0
ALAM=CNM/FR0
IMOD1L=1
GO TO 100
C
230 IJMAX=NFREQS
NFREQ=NFREQS
240 IF(FREQ(IJMAX).LE.FRLAST) NBLANK=IBLANK
if(alm00.gt.0.) then
if(freq(ijmax).ge.0.999999*cnm/alm00.and.iblank.gt.1)
* nblank=iblank
end if
c
c correction for molecular lines
c
if(nmlist.gt.0.and.ifmol.gt.0) then
do ilist=1,nmlist
if(alastm(ilist).gt.0..and.alastm(ilist).le.alact) then
nblank=iblank
irlist=1
c write(*,*) 'iniset mol',ilist,alastm(ilist),alam
end if
end do
end if
c
if(ifwin.le.0) then
FREQ(1)=FREQ(3)
FREQ(2)=FREQ(IJMAX)
W(1)=0.5*(FREQ(1)-FREQ(2))
W(2)=W(1)
end if
C
C truncate the interval if the required end is reached
C
ijmx=2
if(ifwin.gt.0) ijmx=ijmax
IF(FREQ(ijmx).LT.FRLAST) THEN
FREQ(ijmx)=FRLAST
if(ifwin.le.0) then
W(1)=0.5*(FREQ(1)-FREQ(2))
W(2)=W(1)
end if
DO 245 IJ=IJ0,NFREQ
IF(FREQ(IJ).LT.FRLAST) GO TO 247
IJMAX=IJ
245 CONTINUE
247 NFREQ=IJMAX+1
FREQ(NFREQ)=FRLAST
W(NFREQ)=0.5*(FREQ(NFREQ-1)-FREQ(NFREQ))
W(NFREQ-1)=W(NFREQ)+0.5*(FREQ(NFREQ-2)-FREQ(NFREQ-1))
END IF
C
C frequency interpolation coefficients
C
IF(IMODE.NE.-1) THEN
if(ifwin.le.0) then
XX=FREQ(2)-FREQ(1)
DO IJ=1,NFREQ
WLAM(IJ)=2.997925E18/FREQ(IJ)
FRX1(IJ)=(FREQ(IJ)-FREQ(1))/XX
FRX2(IJ)=(FREQ(2)-FREQ(IJ))/XX
END DO
else
DO IJ=1,NFREQ
WLAM(IJ)=CAS/FREQ(IJ)
frqobs(ij)=freq(ij)
wlobs(ij)=wlam(ij)
fr=freq(ij)
BNUE(IJ)=BN*fr*fr*fr
DO IJCI=1,NFREQC-1
IF(WLAM(IJ).LE.WLAMC(IJCI)) GO TO 248
END DO
248 CONTINUE
IJC=IJCI
IJCINT(IJ)=MAX(IJC-1,1)
IJCI=IJCINT(IJ)
FRX1(IJ)=(FREQ(IJ)-FREQC(IJCI+1))/
* (FREQC(IJCI)-FREQC(IJCI+1))
END DO
nfrobs=nfreq
xx=freq(nfreq)-freq(1)
end if
c
c frequency indices of the line centers
c
DFRCON=NFREQ-ij0
DFRCON=-DFRCON/XX
IFRCON=INT(DFRCON)
DO 255 IL=1,NLIN
fr0=freq0(indlin(il))
XJC=3.+DFRCON*(FREQ(1)-FR0)
IJC=INT(XJC)
IJCNTR(IL)=IJC
if(ijc.le.ij0.or.ijc.ge.nfreq) go to 255
if(fr0.lt.freq(ijc)) then
ijc0=ijc
dfr0=freq(ijc0)-fr0
252 ijc0=ijc0+1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0+1
dfr0=dfr
go to 252
end if
else if(fr0.gt.freq(ijc)) then
ijc0=ijc
dfr0=fr0-freq(ijc0)
254 ijc0=ijc0-1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0-1
dfr0=dfr
go to 254
end if
end if
IJCNTR(IL)=IJC
255 continue
END IF
C
if(ifwin.gt.0) then
C
c set up switches for hydrogen and He II line opacity
c
DO IJ=1,NFREQ
call hylsew(ij)
call he2sew(ij)
end do
end if
C
NSP=0
DO 260 IL=1,NLIN
IL0=INDLIN(IL)
ISP=ISPRF(IL0)
IF(ISP.GT.5) THEN
NSP=NSP+1
ISP0(NSP)=ISP
END IF
INDLIP(IL)=INDLIN(IL)
260 CONTINUE
if(ifwin.le.0) then
ILLAST=INDLIN(NLIN)
else
ILLAST=0
IF(NLIN.GT.0) ILLAST=INDLIN(NLIN)
end if
C
CALL READPH
C
IF(ALAM0.LE.APREV+0.001) NBLANK=IBLANK
APREV=ALAM0
ALAM0=ALAM1
ALM00=CNM/FREQ(NFREQ)
c
c write(6,611) iblank,nblank,irlist,aprev*10.,alam0*10.
c 611 format('inis ',2i6,i3,3f10.3)
RETURN
END
synspec/extracted/initia.f
+339
View File
@@ -0,0 +1,339 @@
SUBROUTINE INITIA
C =================
C
C driver for input and initializations
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
PARAMETER (WI1=911.753578, WI2=227.837832)
common/dissol/fropc(mlevel),indexp(mlevel)
CHARACTER*10 TYPLEV(MLEVEL)
CHARACTER*4 TYPION(MIOEX),TYPIOI
CHARACTER*40 FIDATA(MION),FIODF1(MION),FIODF2(MION),FIBFCS(MION),
* FILEI
CHARACTER*20 FINSTD
CHARACTER*1 BLNK
COMMON/PRINTP/TYPLEV
COMMON/IONDAT/IATI(MION),IZI(MION),NLEVS(MION),NLLIM(MION)
COMMON/IONFIL/FIDATA,FIODF1,FIODF2,FIBFCS
COMMON/INUNIT/IUNIT
COMMON/STRPAR/IMER,ITR,IC,IL,IP,NLASTE,NHOD
common/quasex/iexpl(mlevel),iltot(mlevel)
DIMENSION IGLE(18),IGMN(25),IGFE(26),IGNI(28)
DATA IGLE/2,1,2,1,6,9,4,9,6,1,2,1,6,9,4,9,6,1/
DATA IGMN/2,1,2,1,6,9,4,9,6,1,2,1,6,9,4,9,6,1,
* 10,21,28,25,6,7,6/
DATA IGFE/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 IGNI/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/
DATA BLNK /' '/
C
CALL READBF
C
C ------------------------------------
C Basic input parameters - atmospheres
C ------------------------------------
C
IF(INMOD.LE.1) THEN
READ(IBUFF,*) TEFF,GRAV
ELSE IF(INMOD.EQ.2) THEN
C
C ------------------------------
C Basic input parameters - disks
C ------------------------------
C
READ(IBUFF,*) DISPAR
END IF
C
C ----------------------------
C other basic input parameters
C ----------------------------
C
READ(IBUFF,*) LTE,LTGREY
READ(IBUFF,*) FINSTD
CALL NSTPAR(FINSTD)
C
C
C ----------------------------
C Frequency points and weights
C ----------------------------
C
READ(IBUFF,*) NFREAD
NJREAD=NFREAD
C
IF(NJREAD.LT.0) THEN
NJREAD=-NJREAD
NFREQC=NJREAD
DO IJ=1,NJREAD
READ(IBUFF,*) FREQEXP
END DO
ELSE
NFREQC=NJREAD
END IF
C
WRITE(6,601) TEFF,GRAV
C
C ----------------------------------------------------
C turbulent velocities
C ----------------------------------------------------
C
IF(VTB.LT.1.E3) VTB=VTB*1.E5
DO ID=1,ND
VTURB(ID)=VTB
END DO
C
C ----------------------------------------------------
C Input parameters for explicit and non-explicit atoms
C ----------------------------------------------------
C
C Input parameters are read by procedure STATE
C (see description there)
C
CALL STATE0(1)
ID=1
IF(IPRIN.GE.1) WRITE(6,607) YTOT(ID),WMY(ID),WMM(ID)
DO I=1,MLEVEL
ILK(I)=0
iexpl(i)=0
iltot(i)=0
END DO
C
C --------------------------------------------------------------
C Input of parameters for explicit ions, levels, and transitions
C --------------------------------------------------------------
C
ILEV=0
IATLST=0
ION=0
IA=0
IUNIT=34
NATOM=0
WRITE(6,613)
10 CONTINUE
READ(IBUFF,*,END=20,ERR=20) IATII,IZII,NLEVSI,ILASTI,ILVLIN,
* NONSTD,TYPIOI,FILEI
IF(ILASTI.EQ.0) THEN
ION=ION+1
IATI(ION)=IATII
IZI(ION)=IZII
NLEVS(ION)=NLEVSI
TYPION(ION)=TYPIOI
FIDATA(ION)=FILEI
NLLIM(ION)=ILVLIN
ILIMITS(ION)=-1
IUPSUM(ION)=0
FIBFCS(ION)=BLNK
MODEFF=1
NFF=0
IF(IATI(ION).EQ.1.AND.IZI(ION).EQ.0) THEN
IUPSUM(ION)=-100
MODEFF=2
END IF
IF(IATI(ION).EQ.2.AND.IZI(ION).EQ.1) THEN
MODEFF=2
END IF
IF(NONSTD.GE.10) THEN
WRITE(*,*)'INITIA: QUANTUM NUMBERS AND ENERGY LIMITS WILL'
WRITE(*,*)' BE IGNORED FOR ION ',IATII,' ',IZII
ILIMITS(ION)=0
NONSTD=NONSTD-10
END IF
IF(NONSTD.GT.0) THEN
READ(IBUFF,*) IUPSUM(ION),ICUP,MODEFF,NFF
ELSE IF(NONSTD.LT.0) THEN
READ(IBUFF,*) ifil1,ifil2,FIODF1(ION),
* FIODF2(ION),FIBFCS(ION)
IF(FIBFCS(ION).NE.' ') THEN
IUNIT=IUNIT+1
INBFCS(ION)=IUNIT
END IF
IUPSUM(ION)=1
END IF
C
IF(IATI(ION).EQ.IATLST) THEN
NFIRST(ION)=ILEV
ELSE
NFIRST(ION)=ILEV+1
IATLST=IATI(ION)
IA=IATEX(IATLST)
N0A(IA)=NFIRST(ION)
NATOM=MAX(NATOM,IA)
END IF
NLAST(ION)=NFIRST(ION)+NLEVS(ION)-1
NNEXT(ION)=NLAST(ION)+1
ILEV=NNEXT(ION)
IZ(ION)=IZI(ION)+1
IF(NFF.GT.0) FF(ION)=EH/H*IZ(ION)*IZ(ION)/NFF/NFF
C
N0I=NFIRST(ION)
N1I=NLAST(ION)
NKI=NNEXT(ION)
IFREE(ION)=MODEFF
DO II=N0I,N1I
IEL(II)=ION
IATM(II)=IA
END DO
ILK(NKI)=ION
IATM(NKI)=IA
C
IF(NUMAT(IA).EQ.1) THEN
IATH=IA
IF(IZ(ION).EQ.1) IELH=ION
IF(IZ(ION).EQ.0) IELHM=ION
END IF
IF(NUMAT(IA).EQ.2) THEN
IATHE=IA
IF(IZ(ION).EQ.1) IELHE1=ION
IF(IZ(ION).EQ.2) IELHE2=ION
END IF
C
IF(IPRIN.GE.0)
* WRITE(6,614) TYPION(ION),N0I,N1I,NKI,IZ(ION)
C
ELSE IF(ILASTI.GT.0) THEN
ENION(ILEV)=0.
G(ILEV)=ILASTI
NQUANT(ILEV)=1
TYPLEV(ILEV)=TYPIOI
IFWOP(ILEV)=0
IEL(ILEV)=ION
NKA(IA)=NNEXT(ION)
IF(ILASTI.EQ.1.AND.IATII.GT.IZII) THEN
IF(IATII.LT.25) THEN
G(ILEV)=IGLE(IATII-IZII)
ELSE IF(IATII.EQ.25) THEN
G(ILEV)=IGMN(IATII-IZII)
ELSE IF(IATII.EQ.26) THEN
G(ILEV)=IGFE(IATII-IZII)
ELSE IF(IATII.EQ.28) THEN
G(ILEV)=IGNI(IATII-IZII)
ENDIF
ENDIF
ELSE
GO TO 20
END IF
GO TO 10
20 CONTINUE
NION=ION
NLEVEL=NKI
C
if(iath.gt.0) then
N0H=N0A(IATH)
N1H=NLAST(IELH)
NKH=NNEXT(IELH)
N0HN=NFIRST(IELH)
N0M=0
IF(IELHM.GT.0) THEN
N0M=NFIRST(IELHM)
IOPHMI=0
end if
else
n0h=0
n1h=0
nkh=0
n0hn=0
end if
C
IF(IPRIN.GE.1) WRITE(6,603) INMOD,ND,IDSTD,INTRPL,ICHANG,
* NATOM,NION,NLEVEL,
* IELH,IELHM,IATH
C
C -----------------------------------------
C Parameters for individual explicit levels
C -----------------------------------------
C
IMER=0
ITR=0
IC=0
IL=0
IP=0
C
DO ION=1,NION
CALL RDATA(ION)
NFF=NQUANT(NLAST(ION))+1
IF(NFF.GT.0) FF(ION)=EH/H*IZ(ION)*IZ(ION)/NFF/NFF
END DO
C
IF(IPRIN.GE.1) WRITE(6,615)
DO I=1,NLEVEL
IF(IPRIN.GE.1)
* WRITE(6,616) I,TYPLEV(I),TYPION(IEL(I)),ENION(I),G(I),
* NQUANT(I),IEL(I),ILK(I),IATM(I)
END DO
C
C -----------------------------------------
C Input parameters for additional opacities
C -----------------------------------------
C
IF(IPRIN.GE.0) WRITE(6,605) IOPHMI,IOPH2P,IOPHEM,IOPCH,IOPOH,
* IOPH2M,IOH2H2,IOH2HE,IOH2H1,IOHHE,
* IRSCT,IRSCH2,IRSCHE,IOPHLI
C
C
IF(VTB.LT.1.E3) VTB=VTB*1.E5
DO ID=1,ND
VTURB(ID)=VTB
END DO
WRITE(6,608) VTB*1.E-5
DO I=1,ND
VTURB(I)=VTURB(I)*VTURB(I)
END DO
C
601 FORMAT(31X,'*******************************************'/
* 31X,'I',41X,'I'/
* 31X,'I S Y N T H E T I C S P E C T R U M I'/
* 31X,'I',41X,'I'/
* 31X,'I',8X,'FOR MODEL ATMOSPHERE WITH',8X,'I'/
* 31X,'I',41X,'I'/
* 31X,'I',14X,'TEFF =',F7.0,13X,'I'/
* 31X,'I',14X,'LOG G =',F7.2,13X,'I'/
* 31X,'I',41X,'I'/
* 31X,'*******************************************')
603 FORMAT(//' BASIC INPUT PARAMETERS'/
* ' ----------------------'/
* ' INMOD =',I5/
* ' ND =',I5/
* ' IDSTD =',I5/
* ' INTRPL =',I5/
* ' ICHANG =',I5/
* ' NATOM =',I5/
* ' NION =',I5/
* ' NLEVEL =',I5/
* ' IELH =',I5/
* ' IELHM =',I5/
* ' IATH =',I5)
605 FORMAT(//' ADDITIONAL OPACITY SOURCES'/
* ' --------------------------'/
* ' IOPHMI (H- OPACITY IN LTE) =',I3/
* ' IOPH2P (H2+ OPACITY) =',I3/
* ' IOPHEM (HE- B-F AND F-F) =',I3/
* ' IOPCH (CH OPACITY) =',I3/
* ' IOPOH (OH OPACITY) =',I3/
* ' IOPH2M (H2- OPACITY) =',I3/
* ' IOH2H2 (CIA H2-H2 OPACITY =',I3/
* ' IOH2HE (CIA H2-He OPACITY =',I3/
* ' IOH2H1 (CIA H2-H OPACITY =',I3/
* ' IOHHE (CIA H-He OPACITY =',I3/
* ' IRSCT (RAYLEIGH SCAT. ON H I) =',I3/
* ' IRSCH2 (RAYLEIGH SCAT. ON H2 =',I3/
* ' IRSCHE (RAYLEIGH SCAT. ON HE I) =',I3/
* ' IOPHLI (LYMAN LINES WINGS) =',I3)
607 FORMAT(///' YTOT =',F11.5/' WMY =',1PE15.5/
* ' WMM =',E15.5)
608 FORMAT(//' TURBULENT VELOCITY - DEPTH-INDEPENDENT VTURB =',
* 1PE10.3,' KM/S'/
* ' ------------------'/)
613 FORMAT(//' EXPLICIT IONS INCLUDED'/
* ' ----------------------'//
* ' ION N0 N1 NK IZ'/)
614 FORMAT(A4,4I6)
615 FORMAT(//' EXPLICIT ENERGY LEVELS INCLUDED'/
* ' -------------------------------'//
* ' NO. LEVEL ION ION.EN.(ERG) G NQUANT',
* ' IEL ILK IAT'/)
616 FORMAT(I4,2X,A10,A4,1PE15.7,0PF10.2,4I5)
C
RETURN
END
synspec/extracted/inkur.f
+65
View File
@@ -0,0 +1,65 @@
SUBROUTINE INKUR
C ================
C
C Input of a Kurucz model atmosphere
C
C Input values (extracted from the Kurucz files):
C TEF, G - effective temperature, log g (appears only in output)
C ND - number of depth points
C and for each depth:
C DM - m, m is the mass depth coordinate
C T - temperature
C P - gass pressure
C ANE - electron density
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION POP(MLEVEL),ES(MLEVEL,MLEVEL),BS(MLEVEL),POPLTE(MLEVEL)
COMMON POP,ES,BS
C
READ(8,501) TEF,GRAV
READ(8,502) ND
ND=ND-1
501 FORMAT(4X,F8.0,9X,F8.5)
c 502 FORMAT(/////////////////////10X,I3)
502 FORMAT(/////////////////////10X,I3/)
WRITE(6,600) TEF,GRAV
DO 10 ID=1,ND
READ(8,*) DM(ID),TEMP(ID),P,ELEC(ID)
AN=P/TEMP(ID)/BOLK
DENS(ID)=WMM(ID)*(AN-ELEC(ID))
WRITE(6,601) ID,DM(ID),TEMP(ID),ELEC(ID),DENS(ID)
T=TEMP(ID)
IF(IFMOL.GT.0.AND.T.LT.TMOLIM) THEN
c AN=TOTN(ID)
AEIN=ELEC(ID)
CALL MOLEQ(ID,T,AN,AEIN,ANE,1)
ELSE
DO IAT=1,NATOM
ATTOT(IAT,ID)=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID)
END DO
END IF
c WRITE(6,601) ID,DM(ID),TEMP(ID),ELEC(ID),DENS(ID)
CALL WNSTOR(ID)
CALL SABOLF(ID)
CALL RATMAT(ID,ES,BS)
CALL LEVSOL(ES,BS,POPLTE,NLEVEL)
DO J=1,NLEVEL
POPUL(J,ID)=POPLTE(J)
END DO
10 CONTINUE
c WRITE(77,503) ND, 3
c WRITE(77,504) (DM(ID),ID=1,ND)
DO ID=1,ND
WRITE(77,504) TEMP(ID),ELEC(ID),DENS(ID)
END DO
c
CLOSE(8)
c
504 FORMAT(1P6E13.6)
600 FORMAT(' INPUT KURUCZ MODEL FOR TEFF=',F7.0,' LOG G =',
* F7.2//1H ,7X,'MASS',9X,'T',9X,'NE',9X,'DENS'/
* '-----------------------------------------------'/)
601 FORMAT(1H ,I5,1PE10.3,0PF10.1,1P2E12.3)
RETURN
END
synspec/extracted/inmoli.f
+346
View File
@@ -0,0 +1,346 @@
SUBROUTINE INMOLI(ILIST)
C ========================
C
C read in the input molecular line list,
C selection of lines that may contribute,
C set up auxiliary fields containing line parameters,
C
C Input of line data - unit 20:
C
C For each line, one (or two) records, containing:
C
C ALAM - wavelength (in nm)
C ANUM - code of the modelcule (as in Kurucz)
C (eg. 101.00 = H2; 607.00 = CN)
C GF - log gf
C EXCL - excitation potential of the lower level (in cm*-1)
C GR - gamma(rad)
C GS - gamma(Stark)
C GW - gamma(VdW)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
COMMON/NXTINM/ALMM00,ALSM00
common/alendm/alend(mmlist)
common/brdstd/gsstd,gwstd
character*80 dum
dimension x(9)
PARAMETER (PI4=7.95774715E-2)
PARAMETER (C1 = 2.3025851,
* C2 = 4.2014672,
* C3 = 1.4387886,
* CNM = 2.997925D17,
* EXT0 = 3.17,
* UN = 1.0,
* TEN = 10.,
* HUND = 1.D2,
* TENM4 = 1.D-4,
* TENM8 = 1.D-8,
* OP4 = 0.4,
* AGR0=2.4734E-22,
* XEH=13.595, XET=8067.6, XNF=25.,
* R02=2.5, R12=45., VW0=4.5E-9)
C
c DATA INLSET /0/
C
if(imode.ne.-3.and.temp(idstd).gt.tmolim) return
IUNIT=IUNITM(ILIST)
if(ibin(ilist).eq.0) then
open(unit=iunit,file=amlist(ilist),status='old')
else
open(unit=iunit,file=amlist(ilist),form='unformatted',
* status='old')
end if
C
c define a conversion table between Kurucz notation and Tsuji table
c through array MOLIND
C
do i=1,11000
molind(i)=0
end do
molind(101)=2
molind(106)=5
molind(107)=12
molind(108)=4
molind(111)=122
molind(112)=32
molind(114)=17
molind(116)=16
molind(120)=34
molind(124)=198
molind(126)=214
molind(606)=8
molind(607)=7
molind(608)=6
molind(614)=21
molind(616)=20
molind(707)=9
molind(708)=11
molind(714)=24
molind(716)=23
molind(808)=10
molind(812)=126
molind(813)=134
molind(814)=25
molind(816)=26
molind(820)=179
molind(822)=29
molind(823)=30
molind(10108)=3
c
c iunit=19+ilist
C
c ================================
c detect the type of the line list
c
ivdwli(ilist)=0
ibroad=1
c
c text list
c
if(ibin(ilist).eq.0) then
read(iunit,'(a80)') dum
read(dum,*,iostat=kst1) (x(i),i=1,9)
np=9
if(kst1.ne.0) then
read(dum,*,iostat=kst2) (x(i),i=1,7)
np=7
if(kst2.ne.0) then
read(dum,*,iostat=kst3) (x(i),i=1,4)
ibroad=0
np=4
if(kst3.ne.0) then
write(*,*) 'no applicable format of line list',ilist
end if
end if
end if
if(np.eq.9) ivdwli(ilist)=1
else
c
c binary list
c
read(iunit,err=110) (x(i),i=1,9)
np=9
go to 150
110 continue
read(iunit,err=120) (x(i),i=1,7)
np=7
go to 150
120 continue
read(iunit,err=130) (x(i),i=1,4)
ibroad=0
np=4
go to 150
130 continue
150 continue
if(np.eq.9) ivdwli(ilist)=1
if(np.eq.9) ivdwli(ilist)=1
end if
c =========================
c
ALAST=CNM/FRLAST
ALASTM(ILIST)=ALAST
IL=0
IF(NXTSEM(ILIST).EQ.1) THEN
ALAM0=ALM00
ALASTM(ILIST)=ALST00
FRLASM(ILIST)=CNM/ALASTM(ILIST)
NXTSEM(ILIST)=0
REWIND IUNIT
END IF
ALMM00=ALAM0
c ALASTM(ILIST)=CNM/FRLAST
c FRLASM(ILIST)=CNM/ALASTM(ILIST)
DOPSTD=1.E7/ALAM0*DSTD
DOPLAM=ALAM0*ALAM0/CNM*DOPSTD
AVAB=ABSTD(IDSTD)*RELOP
ASTD=1.0
c IF(GRAV.GT.6.) ASTD=0.1
CUTOFF=CUTOF0
ALAST=CNM/FRLAST
C
C first part of reading line list - read only lambda, and
C skip all lines with wavelength below ALAM0-CUTOFF
C
REWIND IUNIT
ALAM=0.
IJC=2
c
7 if(ibin(ilist).eq.0) then
READ(IUNIT,510) ALAM
else
read(iunit) alam
end if
510 FORMAT(F10.4)
IF(ALAM.LT.ALAM0-CUTOFF) GO TO 7
BACKSPACE(IUNIT)
GO TO 10
c
c read the line list
c
ill=0
8 continue
10 continue
ill=ill+1
c ivdwli(ilist)=1
if(ibin(ilist).eq.0) then
c if(ivdwli(ilist).ne.0) then
if(np.eq.9) then
read(iunit,*,end=100) alam,anum,gf,excl,gr,gh2,xnh2,ghe,xnhe
else if(np.eq.7) then
READ(IUNIT,*,END=100,err=8) ALAM,ANUM,GF,EXCL,GR,GS,GW
else
read(iunit,*,end=100,err=8) alam,anum,gf,excl
gr=2.4e13/alam**2
gs=gsstd
gw=gwstd
end if
else
c if(ivdwli(ilist).ne.0) then
if(np.eq.9) then
read(iunit,end=100) alam,anum,gf,excl,gr,gh2,xnh2,ghe,xnhe
else if(np.eq.7) then
READ(IUNIT,END=100) ALAM,ANUM,GF,EXCL,GR,GS,GW
else
read(iunit,end=100) alam,anum,gf,excl
gr=2.4e13/alam**2
gs=gsstd
gw=gwstd
end if
end if
C
c change wavelength to vacuum for lambda > 2000
c
if(alam.gt.200..and.vaclim.gt.2000.) then
wl0=alam*10.
ALM=1.E8/(WL0*WL0)
XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM)
WL0=WL0*(XN1*1.D-6+UN)
alam=wl0*0.1
END IF
C
C first selection : for a given interval
C
IF(ALAM.GT.ALASTM(ILIST)+CUTOFF) GO TO 100
C
C second selection : for line strengths
C
FR0=CNM/ALAM
icod=int(anum+tenm4)
c IF(ICOD.EQ.823) go to 10
imol=molind(icod)
if(imol.le.0.or.imol.gt.nmolec) go to 10
EXCL=ABS(EXCL)
GFP=C1*GF-C2
EPP=C3*EXCL
gx=gfp-epp/tstd
ab0=0.
c
if(ndstep.eq.0.and.ifwin.eq.0) then
c
c old procedure for line rejection
c
if(gx.gt.-30)
* AB0=EXP(GFP-EPP/TSTD)*RRMOL(IMOL,IDSTD)/DOPSTD/AVAB
IF(AB0.LT.UN) GO TO 10
else
c
c new procedure for line rejection
c
do ijcn=ijc,nfreqc
if(fr0.ge.freqc(ijcn)) go to 12
end do
12 continue
ijc=ijcn
if(ijc.gt.nfreqc) ijc=nfreqc
c
tkm=1.65e8/ammol(imol)
DP0=3.33564E-11*FR0
do id=1,nd,ndstep
td=temp(id)
gx=gfp-epp/td
ab0=0.
if(gx.gt.-30) then
dops=dp0*sqrt(tkm*td+vturb(id))
AB0=EXP(gx)*RRMOL(IMOL,ID)/(DOPS*abstdw(ijc,id)*relop)
end if
if(ab0.ge.un) go to 15
end do
GO TO 10
end if
c
C truncate line list if there are more lines than maximum allowable
C (given by MLIN0 - see include file LINDAT.FOR)
C
15 CONTINUE
IL=IL+1
IF(IL.GT.MLINM0) THEN
WRITE(6,601) ALAM
IL=MLINM0
ALASTM(ILIST)=CNM/FREQM(IL,ILIST)-CUTOFF
FRLASM(ILIST)=CNM/ALASTM(ILIST)
NXTSEM(ILIST)=1
GO TO 100
END IF
C
C =============================================
C line is selected, set up necessary parameters
C =============================================
C
C evaluation of EXTIN0 - the distance (in delta frequency) where
C the line is supposed to contribute to the total opacity
C
EX0=AB0*ASTD*10.
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
EXTIN0=EXT*DOPSTD
C
C store parameters for selected lines
C
FREQM(IL,ILIST)=FR0
EXCLM(IL,ILIST)=real(EPP)
GFM(IL,ILIST)=real(GFP)
EXTINM(IL,ILIST)=real(EXTIN0)
INDATM(IL,ILIST)=imol
C
C ****** line broadening parameters *****
C assuming for Stark 1.e-8*effnsq**5/2, with effnsq=25
C
GRM(IL,ILIST)=real(GR*PI4)
GSM(IL,ILIST)=real(GS*PI4*3.125e-5)
GWM(IL,ILIST)=real(GW*PI4)
c IF(imol.eq.30) gwm(il,ilist)=0.
if(ivdwli(ilist).ne.0) then
gvdwh2(il,ilist)=real(gh2)
gexph2(il,ilist)=real(xnh2)
gvdwhe(il,ilist)=real(ghe)
gexphe(il,ilist)=real(xnhe)
gsm(il,ilist)=0.
gwm(il,ilist)=0.
end if
C
GO TO 10
100 NLINM0(ILIST)=IL
nlinmt(ilist)=nlinmt(ilist)+nlinm0(ilist)
alend(ilist)=cnm/fr0
C
xln=float(il)*1.e-6
WRITE(6,611) IUNIT,trim(amlist(ilist)),XLN
611 FORMAT(/' --------------------------------------------'/
*' MOLECULAR LINES - FROM UNIT ',i3,
*', FILE ',a,':',f8.3,' M'/
*' --------------------------------------------'/)
601 FORMAT('0 **** MORE LINES THAN MLINM0, LINE LIST TRUNCATED '/
*' AT LAMBDA',F15.4,' NM'/)
RETURN
END
synspec/extracted/inpbf.f
+35
View File
@@ -0,0 +1,35 @@
SUBROUTINE INPBF
C ================
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
PARAMETER (MINPUT=MLEVEL+4)
DIMENSION DEPTH(MDEPTH),X(MINPUT,MDEPTH),XX(MDEPTH),BF(MDEPTH)
C
OPEN(8,FILE='bfactors',STATUS='OLD')
NUMLT=3
IF(INMOD.EQ.2) NUMLT=4
READ(8,*) NDPTH,NUMPAR
READ(8,*) (DEPTH(I),I=1,NDPTH)
IF(NUMPAR.LT.0) NUMLT=NUMLT+1
NUMP=ABS(NUMPAR)
DO ID=1,NDPTH
READ(8,*) (X(I,ID),I=1,NUMP)
END DO
CLOSE(8)
c
c interpolate the input b-factors to the original DM-scale;
c compute new NLTE populations
c
DO I=NUMLT+1,NUMP
DO ID=1,NDPTH
XX(ID)=X(I,ID)
END DO
CALL INTERP(DEPTH,XX,DM,BF,NDPTH,ND,2,1,1)
DO ID=1,ND
POPUL(I-NUMLT,ID)=POPUL(I-NUMLT,ID)*BF(ID)
END DO
END DO
C
RETURN
END
synspec/extracted/inpmod.f
+160
View File
@@ -0,0 +1,160 @@
SUBROUTINE INPMOD
C =================
C
C Read an initial model atmosphere from unit 8
C File 8 contains:
C 1. NDPTH - number of depth points in which the initial model is
C given (if not equal to ND, routine interpolates
C automatically to the set DM by linear interpolation
C in log(DM)
C NUMPAR - number of input model parameters in each depth
C = 3 for LTE model - ie. N, T, N(electron);
C > 3 for NLTE model)
C 2. DEPTH(ID),ID=1,NDPTH - mass-depth points for the input model
C 3. for each depth:
C T - temperature
C ANE - electron density
C RHO - mass density
C level populations - only for NLTE input model
C Number of input level populations need not be
C equal to NLEVEL; in that case the procedure
C CHANGE is called from START to calculate the
C remaining level populations
C
C Note: The output file 7, which is created by this program
C (procedure OUTPUT) has the same structure as file 8
C and may thus be used as input to another run of the
C program
C INTRPL - switch indicating whether (and, if so, how) interpolate
C the initial model if the depth scales for the input model
C and the present depth scale are different
C = 0 - no interpolation, i.e. scale DEPTH coincides with DM
C > 0 - polynomial interpolation of the (INTRPL-1)th order
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
PARAMETER (MINPUT=MLEVEL+4)
DIMENSION ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),POPLTE(MLEVEL),
* TOTN(MDEPTH),PLTE(MLEVEL,MDEPTH)
COMMON ESEMAT,BESE,POPLTE,POPUL0(MLEVEL,MDEPTH),X(MINPUT),
* TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),PPL0(MDEPTH),
* PPL(MDEPTH),DEPTH(MDEPTH),DM0(MDEPTH),DP(MDEPTH)
COMMON/NLTPOP/PNLT(MATOM,MION,MDEPTH)
common/quasex/iexpl(mlevel),iltot(mlevel)
C
NUMLT=3
IF(INMOD.EQ.2) NUMLT=4
READ(8,*) NDPTH,NUMPAR
READ(8,*) (DEPTH(I),I=1,NDPTH)
ND=NDPTH
NUMP=ABS(NUMPAR)
DO 30 ID=1,NDPTH
READ(8,*) (X(I),I=1,NUMP)
TEMP(ID)=X(1)
ELEC(ID)=X(2)
DENS(ID)=X(3)
TOTN(ID)=DENS(ID)/WMM(ID)+ELEC(ID)
CALL WNSTOR(ID)
CALL SABOLF(ID)
IP=NUMLT
IF(NUMPAR.LT.0) THEN
IP=IP+1
TOTN(ID)=X(IP)
END IF
IF(INMOD.EQ.2) IP=IP+1
c
c first compute LTE level populations for all levels,
c i.e. explicit, semi-explisit, and quasi-explicit
c
NLEV0=NLEVEL
TEMP(ID)=X(1)
ELEC(ID)=X(2)
DENS(ID)=X(3)
t=temp(id)
if(ifmol.gt.0.and.t.lt.tmolim) then
ipri=1
aein=elec(id)
an=totn(id)
call moleq(id,t,an,aein,ane,ipri)
else
if(imode.gt.-2) then
DO IAT=1,NATOM
ATTOT(IAT,ID)=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID)
END DO
else
DO IAT=1,NATOM
ATTOT(IAT,ID)=DENS(ID)/WMM(1)/YTOT(1)*ABUND(IAT,1)
END DO
end if
end if
CALL WNSTOR(ID)
CALL SABOLF(ID)
CALL RATMAT(ID,ESEMAT,BESE)
CALL LEVSOL(ESEMAT,BESE,POPLTE,NLEV0)
DO I=1,NLEV0
POPUL(I,ID)=POPLTE(I)
PLTE(I,ID)=POPLTE(I)
c if(id.eq.1) write(6,651) i,ip,popul(i,id),plte(i,id)
END DO
c
c if the input file fort.8 contains also NLTE level populations
c of b-factors, replace the LTE populations by those
c
IF(NUMP.GT.IP) THEN
NLEV0=NUMP-IP
DO I=1,NLEV0
j=iltot(i)
POPUL(J,ID)=X(IP+I)*RELAB(IATM(I),ID)
c if(id.eq.1) write(6,651) i,j,x(ip+i),popul(i,id)
c 651 format('in',2i4,1p2e12.4)
END DO
c DO I=1,NLEV0
c j=iltot(i)
c if(popul(j,id).le.0.) then
c IE=IEL(I)
c N0I=NFIRST(IE)
c NKI=NNEXT(IE)
c POPUL(J,ID)=ELEC(ID)*POPUL(iltot(NKI),ID)*SBF(I)
c end if
c END DO
c
c in the case the input "NLTE populations are in fact b-factors,
c compute the real populations
c
if(ibfac.eq.1) then
do i=1,nlev0
j=iltot(i)
popul(j,id)=popul(j,id)*plte(j,id)
end do
end if
END IF
30 CONTINUE
C
close(8)
c
write(6,600)
600 format(/' INPUT TLUSTY MODEL'/
* ' ------------------'/
* 1H ,8X,'MASS',9X,'T',9X,'NE',9X,'DENS'//)
nd=ndpth
DO 40 ID=1,ND
DM(ID)=DEPTH(ID)
write(6,601) id,dm(id),temp(id),elec(id),dens(id),
* popul(1,id)
601 format(i6,1pe10.3,0pf10.1,1p4e12.3)
40 CONTINUE
C
DO 100 ID=1,ND
BCON=ELEC(ID)/TEMP(ID)/SQRT(TEMP(ID))*2.0706E-16
DO 100 IONE=1,NION
ION=IZ(IONE)
IAT=NUMAT(IATM(NFIRST(IONE)))
NKI=NNEXT(IONE)
IF(ION.GT.0) PNLT(IAT,ION,ID)=POPUL(NKI,ID)/G(NKI)*BCON
100 CONTINUE
c
c check abundances
c
c CALL CHCKAB
RETURN
END
synspec/extracted/interp.f
+82
View File
@@ -0,0 +1,82 @@
SUBROUTINE INTERP(X,Y,XX,YY,NX,NXX,NPOL,ILOGX,ILOGY)
C ====================================================
C
C General interpolation procedure of the (NPOL-1)-th order
C
C for ILOGX = 1 logarithmic interpolation in X
C for ILOGY = 1 logarithmic interpolation in Y
C
C Input:
C X - array of original x-coordinates
C Y - array of corresponding functional values Y=y(X)
C NX - number of elements in arrays X or Y
C XX - array of new x-coordinates (to which is to be
C interpolated
C NXX - number of elements in array XX
C Output:
C YY - interpolated functional values YY=y(XX)
C
INCLUDE 'PARAMS.FOR'
DIMENSION X(1),Y(1),XX(1),YY(1)
EXP10(X0)=EXP(X0*2.30258509299405D0)
IF(NPOL.LE.0.OR.NX.LE.0) GO TO 200
IF(ILOGX.NE.0) THEN
DO I=1,NX
X(I)=LOG10(X(I))
END DO
DO I=1,NXX
XX(I)=LOG10(XX(I))
END DO
END IF
IF(ILOGY.NE.0) THEN
DO I=1,NX
Y(I)=LOG10(Y(I))
END DO
END IF
NM=(NPOL+1)/2
NM1=NM+1
NUP=NX+NM1-NPOL
DO ID=1,NXX
XXX=XX(ID)
DO I=NM1,NUP
IF(XXX.LE.X(I)) GO TO 70
END DO
I=NUP
70 J=I-NM
JJ=J+NPOL-1
YYY=0.
DO K=J,JJ
T=1.
DO 80 M=J,JJ
IF(K.EQ.M) GO TO 80
T=T*(XXX-X(M))/(X(K)-X(M))
80 CONTINUE
YYY=Y(K)*T+YYY
END DO
YY(ID)=YYY
END DO
IF(ILOGX.NE.0) THEN
DO I=1,NX
X(I)=EXP10(X(I))
END DO
DO I=1,NXX
XX(I)=EXP10(XX(I))
END DO
END IF
IF(ILOGY.NE.0) THEN
DO I=1,NX
Y(I)=EXP10(Y(I))
END DO
DO I=1,NXX
YY(I)=EXP10(YY(I))
END DO
END IF
RETURN
200 N=NX
IF(NXX.GE.NX) N=NXX
DO I=1,N
XX(I)=X(I)
YY(I)=Y(I)
END DO
RETURN
END
synspec/extracted/inthe2.f
+82
View File
@@ -0,0 +1,82 @@
SUBROUTINE INTHE2(W0,X0,Z0,IWL,ILINE)
C =====================================
C
C Interpolation in temperature and electron density from the
C Schoening and Butler tables for He II lines to the actual
C actual values of temperature and electron density
C
C This procedure is quite analogous to INTHYD for hydrogen lines
C
INCLUDE 'PARAMS.FOR'
PARAMETER (UN=1.)
COMMON/HE2DAT/WL2(36,19),XT2(6),XNE2(11,19),PRF2(36,6,11),
* NWL2,NT2,NE2
DIMENSION ZZ(3),XX(3),WX(3),WZ(3)
C
NX=3
NZ=3
C
C for values lower than the lowest grid value of electron density
C the profiles are determined by the approximate expression
C (see STARKA); not by an extrapolation in the tables which may
C be very inaccurate
C
IF(Z0.LT.XNE2(1,ILINE)*0.99.OR.Z0.GT.XNE2(NE2,ILINE)*1.01) THEN
CALL DIVHE2(A,DIV)
W0=STARKA(WL2(IWL,ILINE)/FXK,A,DIV,UN)*DBETA
W0=LOG10(W0)
GO TO 500
END IF
C
C Otherwise, one interpolates (or extrapolates for higher than the
C highes grid value of electron density) in the Schoening and
C Butler tables
C
DO 10 IZZ=1,NE2-1
IPZ=IZZ
IF(Z0.LE.XNE2(IZZ+1,ILINE)) GO TO 20
10 CONTINUE
20 N0Z=IPZ-NZ/2+1
IF(N0Z.LT.1) N0Z=1
IF(N0Z.GT.NE2-NZ+1) N0Z=NE2-NZ+1
N1Z=N0Z+NZ-1
C
DO 300 IZZ=N0Z,N1Z
I0Z=IZZ-N0Z+1
ZZ(I0Z)=XNE2(IZZ,iline)
C
C Likewise, the approximate expression instead of extrapolation
C is used for higher that the highest grid value of temperature,
C if the Doppler width expressed in beta units (BETAD) is
C sufficiently large (> 10)
C
IF(X0.GT.1.01*XT2(NT2).AND.BETAD.GT.10.) THEN
W0=STARKA(WL2(IWL,ILINE)/FXK,A,DIV,UN)*DBETA
W0=LOG10(W0)
GO TO 500
END IF
C
C Otherwise, normal inter- or extrapolation
C
C Both interpolations (in T as well as in electron density) are
C by default the quadratic interpolations in logarithms
C
DO 30 IX=1,NT2-1
IPX=IX
IF(X0.LE.XT2(IX+1)) GO TO 40
30 CONTINUE
40 N0X=IPX-NX/2+1
IF(N0X.LT.1) N0X=1
IF(N0X.GT.NT2-NX+1) N0X=NT2-NX+1
N1X=N0X+NX-1
DO 200 IX=N0X,N1X
I0=IX-N0X+1
XX(I0)=XT2(IX)
WX(I0)=PRF2(IWL,IX,IZZ)
200 CONTINUE
WZ(I0Z)=YINT(XX,WX,X0)
300 CONTINUE
W0=YINT(ZZ,WZ,Z0)
500 CONTINUE
RETURN
END
synspec/extracted/inthyd.f
+92
View File
@@ -0,0 +1,92 @@
SUBROUTINE INTHYD(W0,X0,Z0,IWL,ILINE)
C
C Interpolation in temperature and electron density from the
C hydrogen odening tables to the actual valus of
C temperature and electron density
C
INCLUDE 'PARAMS.FOR'
PARAMETER (TWO=2.)
DIMENSION ZZ(3),XX(3),WX(3),WZ(3)
C
NX=3
NZ=3
NT=NTH(ILINE)
NE=NEH(ILINE)
BETA=WL(IWL,ILINE)/FXK
IF(ILEMKE.EQ.1) THEN
BETA=WL(IWL,ILINE)/XK
NX=2
NZ=2
END IF
C
C for values lower than the lowest grid value of electron density
C the profiles are determined by the approximate expression
C (see STARKA); not by an extrapolation in the HYD tables which may
C be very inaccurate
C
IF(Z0.LT.XNE(1,ILINE)*0.99.OR.Z0.GT.XNE(NE,ILINE)*1.01) THEN
CALL DIVSTR(A,DIV)
W0=STARKA(BETA,A,DIV,TWO)*DBETA
W0=LOG10(W0)
GO TO 500
END IF
C
C Otherwise, one interpolates (or extrapolates for higher than the
C highes grid value of electron density) in the HYD tables
C
DO IZZ=1,NE-1
IPZ=IZZ
IF(Z0.LE.XNE(IZZ+1,ILINE)) GO TO 20
END DO
20 N0Z=IPZ-NZ/2+1
IF(N0Z.LT.1) N0Z=1
IF(N0Z.GT.NE-NZ+1) N0Z=NE-NZ+1
N1Z=N0Z+NZ-1
C
DO 300 IZZ=N0Z,N1Z
I0Z=IZZ-N0Z+1
ZZ(I0Z)=XNE(IZZ,ILINE)
C
C Likewise, the approximate expression instead of extrapolation
C is used for higher that the highest grid value of temperature,
C if the Doppler width expressed in beta units (BETAD) is
C sufficiently large (> 10)
C
IF(X0.GT.1.01*XT(NT,ILINE).AND.BETAD.GT.10.) THEN
CALL DIVSTR(A,DIV)
W0=STARKA(BETA,A,DIV,TWO)*DBETA
W0=LOG10(W0)
GO TO 500
END IF
C
C Otherwise, normal inter- or extrapolation
C
C Both interpolations (in T as well as in electron density) are
C by default the quadratic interpolations in logarithms
C
DO IX=1,NT-1
IPX=IX
IF(X0.LE.XT(IX+1,ILINE)) GO TO 40
END DO
40 N0X=IPX-NX/2+1
IF(N0X.LT.1) N0X=1
IF(N0X.GT.NT-NX+1) N0X=NT-NX+1
N1X=N0X+NX-1
DO IX=N0X,N1X
I0=IX-N0X+1
XX(I0)=XT(IX,ILINE)
WX(I0)=PRF(IWL,IX,IZZ,ILINE)
END DO
IF(WX(1).LT.-99..OR.WX(2).LT.-99..OR.WX(3).LT.-99.) THEN
CALL DIVSTR(A,DIV)
W0=STARKA(BETA,A,DIV,TWO)*DBETA
W0=LOG10(W0)
GO TO 500
ELSE
WZ(I0Z)=YINT(XX,WX,X0)
END IF
300 CONTINUE
W0=YINT(ZZ,WZ,Z0)
500 CONTINUE
RETURN
END
synspec/extracted/intrp.f
+44
View File
@@ -0,0 +1,44 @@
subroutine intrp(wltab,absop,wlgrid,abgrd,nfr,nfgrid)
c =====================================================
c
c a more efficient interpolation routine - using bisection
c
INCLUDE 'PARAMS.FOR'
dimension wltab(1),absop(1),wlgrid(1),abgrd(1)
dimension yint(mfgrid),jint(mfgrid)
c
c set up interpolation coefficients for an interpolation
c by bisection
c
fr1=wltab(1)
fr2=wltab(nfr)
do ij=1,nfgrid
xint=wlgrid(ij)
jl=0
ju=nfr+1
10 continue
if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((fr2.gt.fr1).eqv.(xint.gt.wltab(jm))) then
jl=jm
else
ju=jm
end if
go to 10
end if
j=jl
if(j.eq.nfr) j=j-1
if(j.eq.0) j=j+1
jint(ij)=j
c yint(ij)=un/log10(wltab(j+1)/wltab(j))
yint(ij)=1./(wltab(j+1)-wltab(j))
end do
c
do ij=1,nfgrid
j=jint(ij)
rc=(absop(j+1)-absop(j))*yint(ij)
c abgrd(ij)=rc*log10(wlgrid(ij)/wltab(j))+absop(j)
abgrd(ij)=rc*(wlgrid(ij)-wltab(j))+absop(j)
end do
return
end
synspec/extracted/intxen.f
+49
View File
@@ -0,0 +1,49 @@
SUBROUTINE INTXEN(W0B,W0R,X0,Z0,IWL,ILINE)
C ==========================================
C
C Interpolation in temperature and electron density from the
C Xenomorph tables for hydrogen lines to the actual valus of
C temperature and electron density
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION ZZ(3),XX(3),WXB(3),WZB(3),WXR(3),WZR(3)
C
NX=2
NZ=2
NT=NTHXEN(ILINE)
NE=NEHXEN(ILINE)
C
DO 10 IZZ=1,NE-1
IPZ=IZZ
IF(Z0.LE.XNEXEN(IZZ+1,ILINE)) GO TO 20
10 CONTINUE
20 N0Z=IPZ-NZ/2+1
IF(N0Z.LT.1) N0Z=1
IF(N0Z.GT.NE-NZ+1) N0Z=NE-NZ+1
N1Z=N0Z+NZ-1
C
DO IZZ=N0Z,N1Z
I0Z=IZZ-N0Z+1
ZZ(I0Z)=XNEXEN(IZZ,ILINE)
DO 30 IX=1,NT-1
IPX=IX
IF(X0.LE.XTXEN(IX+1,ILINE)) GO TO 40
30 CONTINUE
40 N0X=IPX-NX/2+1
IF(N0X.LT.1) N0X=1
IF(N0X.GT.NT-NX+1) N0X=NT-NX+1
N1X=N0X+NX-1
DO IX=N0X,N1X
I0=IX-N0X+1
XX(I0)=XTXEN(IX,ILINE)
WXB(I0)=PRFXB(ILINE,IWL,IX,IZZ)
WXR(I0)=PRFXR(ILINE,IWL,IX,IZZ)
END DO
WZB(I0Z)=YINT(XX,WXB,X0)
WZR(I0Z)=YINT(XX,WXR,X0)
END DO
W0B=YINT(ZZ,WZB,Z0)
W0R=YINT(ZZ,WZR,Z0)
RETURN
END
synspec/extracted/irwpf.f
+165
View File
@@ -0,0 +1,165 @@
subroutine irwpf(jatom,ion,indmol,t,u)
c ======================================
c
c partition functions adter Irwin (1981), ApJS. 45, 621.
c updated with the data of Barklem & Collet (2016)
C set to the Irwin format by Y. Ossorio
c
c Input: jatom - atomic number; if =0 - molecules
c ion - ionization degree
c indmol - index of a molecule in the new Tsuji-type
c indexing (from file tsuji.molec_bc2)
c t - temperature
c Output: u - partition function
c
c array IRWIND(I) - the Irwin index corresponding to Tsuji
c index I
c if =0 - molecule I has no data in the Irwin table
c
INCLUDE 'PARAMS.FOR'
real*8 a(6,3,92),aa(6),am(6,500),spec(500)
dimension irwind(478)
save iread,a,am
c
data irwind/
* 0, 1, 28, 4, 2, 7, 6, 5, 8, 10,
* 9, 3, 18, 25, 53, 29, 43, 0, 17, 153,
* 52, 55, 167, 44, 45, 182, 74, 46, 11, 187,
* 201, 31, 27, 99, 209, 24, 22, 20, 21, 65,
* 35, 19, 54, 23, 0, 14, 58, 0, 32, 12,
* 47, 16, 0, 34, 0, 0, 30, 0, 13, 33,
* 61, 63, 292, 57, 59, 66, 272, 0, 94, 175,
* 226, 286, 0, 0, 0, 176, 227, 287, 0, 0,
* 0, 96, 0, 177, 0, 267, 228, 288, 0, 0,
* 0, 0, 93, 147, 162, 5*0,
* 0, 50, 0, 0, 0, 0, 36, 0, 64, 0,
* 0, 48, 0, 0, 148, 0, 0, 26, 49, 70,
* 178, 97, 170, 229, 0, 180, 268, 230, 0, 289,
* 0, 0, 15, 181, 0, 269, 4*0,
* 0, 0, 0, 231, 0, 290, 0, 38, 0, 0,
* 152, 39, 40, 0, 41, 232, 0, 291, 0, 0,
* 0, 0, 0, 75, 154, 0, 0, 0, 183, 0,
* 0, 0, 0, 0, 0, 98, 184, 234, 185, 270,
* 0, 0, 0, 186, 0, 0, 271, 235, 0, 0,
* 62, 0, 0, 0, 0, 0, 0, 101, 0, 188,
* 0, 0, 0, 0, 0, 102, 189, 3*0,
* 236, 0, 294, 67, 0, 190, 0, 0, 0, 295,
* 0, 0, 104, 191, 237, 0, 105, 192, 274, 238,
* 296, 112, 245, 303, 113, 199, 0, 278, 246, 0,
* 304, 0, 0, 0, 0, 200, 0, 0, 279, 247,
* 0, 305, 0, 0, 172, 5*0,
* 0, 120, 122, 208, 0, 282, 255, 0, 312, 0,
* 7*0, 283, 256, 0,
* 10*0,
* 275, 194, 108, 241, 299, 202, 0, 68, 69, 71,
* 72, 73, 42, 37, 76, 77, 78, 79, 80, 81,
* 82, 83, 92, 95, 100, 103, 106, 107, 109, 110,
* 111, 114, 115, 116, 117, 118, 119, 121, 123, 124,
* 125, 126, 127, 128, 129, 149, 150, 151, 155, 156,
* 157, 158, 159, 163, 164, 165, 166, 168, 169, 170,
* 171, 193, 195, 196, 197, 198, 203, 204, 205, 206,
* 207, 210, 211, 212, 213, 214, 215, 216, 217, 218,
* 225, 233, 239, 240, 242, 243, 244, 248, 249, 250,
* 251, 252, 253, 254, 257, 258, 259, 260, 262, 262,
* 263, 264, 265, 266, 273, 276, 277, 280, 282, 284,
* 285, 293, 297, 298, 300, 301, 302, 306, 307, 308,
* 309, 310, 311, 60, 313, 314, 315, 316, 317, 318,
* 319, 320, 321, 322, 323, 324, 84, 85, 86, 87,
* 88, 89, 90, 91, 130, 131, 132, 133, 134, 135,
* 136, 137, 138, 139, 140, 141, 142, 143, 144, 145,
* 146, 160, 161, 173, 174, 210, 220, 221, 222, 223,
* 224,16*0, 56/
c
data iread /0/
c
c call old Irwin routine MPARTF if desired
c
if(irwtab.eq.0) then
call mpartf(jatom,ion,indmol,t,u)
return
end if
c
c read data if first call:
c
if(iread.ne.1) then
if(irwtab.eq.0) then
open(67,file= './data/irwin_orig.dat',status='old')
else
open(67,file= './data/irwin_bc.dat',status='old')
end if
read(67,*)
read(67,*)
do j=1,92
do i=1,3
if(j.eq.1.and.i.eq.3) goto 10
sp=float(j)+float(i-1)/100.
read(67,*) spc,aa
do k=1,6
a(k,i,j)=aa(k)
end do
10 continue
end do
end do
c
read(67,*)
read(67,*)
read(67,*)
do i=1,324
read(67,*,end=15) spec(i),aa
do j=1,6
am(j,i)=aa(j)
end do
end do
15 continue
close(67)
iread=1
endif
c
c evaluation of the partition function
c stop if T is out of limits of Irwin's tables
c
if(t.lt.1000.) then
stop 'partf; temp<1000 K'
else if(t.gt.16000.) then
stop 'partf; temp>16000 K'
endif
tl=log(t)
u=0.
c
c atomic species
c
if(jatom.gt.0.and.ion.gt.0) then
ulog= a(1,ion,jatom)+
* tl*(a(2,ion,jatom)+
* tl*(a(3,ion,jatom)+
* tl*(a(4,ion,jatom)+
* tl*(a(5,ion,jatom)+
* tl*(a(6,ion,jatom))))))
if(jatom.eq.5.and.ion.eq.3) ulog=1.
C write(*,*) 'bor',ion,tl,ulog
c * write(6,631) ion,tl,a(1,ion,jatom),tl*a(2,ion,jatom),
c tl**2*a(3,ion,jatom),tl**3*a(4,ion,jatom),tl**4*a(5,ion,jatom),
c * tl**5*a(6,ion,jatom),ulog
c 631 format('bor',i4,1p8e11.3)
u=exp(ulog)
return
end if
c
c molecular species
c
if(indmol.gt.0) then
indm=irwind(indmol)
if(indm.le.0) return
ulog= am(1,indm)+
* tl*(am(2,indm)+
* tl*(am(3,indm)+
* tl*(am(4,indm)+
* tl*(am(5,indm)+
* tl*(am(6,indm))))))
u=exp(ulog)
c if(t.gt.5128..and.t.lt.5129.)
c * write(6,631) t,indmol,indm,u
c 631 format('irwpf',f10.1,2i5,f16.3)
end if
return
end
synspec/extracted/ispec.f
+59
View File
@@ -0,0 +1,59 @@
FUNCTION ISPEC(IAT,ION,ALAM)
C ============================
C
C Auxiliary procedure for INISET
C
C Input: IAT - atomic number
C ION - ion (=1 for neutrals, =2 for once ionized, etc.)
C ALAM - wavelength in nanometers
C Output: ISPEC - parameter specifying whether the given line
C is taken with a special (pretabulated) absorption
C profile - only for hydrogen and helium
C = 0 - profile is taken as an ordinary Voigt profile
C > 0 - special profile
C
INCLUDE 'PARAMS.FOR'
C
ISPEC=0
IF(IAT.GT.2) RETURN
C
IF(IAT.EQ.1) THEN
ISPEC=1
RETURN
ELSE
IF(ION.EQ.1) THEN
IF(ABS(ALAM-447.1).LT.0.5.AND.IHE1PR.GT.0) ISPEC=2
IF(ABS(ALAM-438.8).LT.0.2.AND.IHE1PR.GT.0) ISPEC=3
IF(ABS(ALAM-402.6).LT.0.2.AND.IHE1PR.GT.0) ISPEC=4
IF(ABS(ALAM-492.2).LT.0.2.AND.IHE1PR.GT.0) ISPEC=5
ELSE
C
IF(ALAM.LT.163..OR.ALAM.GT.1012.7) RETURN
IF(ALAM.LT.321.) THEN
IF(ABS(ALAM-164.0).LT.0.2.AND.IHE2PR.GT.0) ISPEC=6
IF(ABS(ALAM-320.3).LT.0.2.AND.IHE2PR.GT.0) ISPEC=7
IF(ABS(ALAM-273.3).LT.0.2.AND.IHE2PR.GT.0) ISPEC=8
IF(ABS(ALAM-251.1).LT.0.2.AND.IHE2PR.GT.0) ISPEC=9
IF(ABS(ALAM-238.5).LT.0.2.AND.IHE2PR.GT.0) ISPEC=10
IF(ABS(ALAM-230.6).LT.0.2.AND.IHE2PR.GT.0) ISPEC=11
IF(ABS(ALAM-225.3).LT.0.2.AND.IHE2PR.GT.0) ISPEC=12
ELSE IF(ALAM.LT.541.) THEN
IF(ALAM.LT.392.3) RETURN
IF(ABS(ALAM-468.6).LT.0.2.AND.IHE2PR.GT.0) ISPEC=13
IF(ABS(ALAM-485.9).LT.0.2.AND.IHE2PR.GT.0) ISPEC=14
IF(ABS(ALAM-454.2).LT.0.2.AND.IHE2PR.GT.0) ISPEC=15
IF(ABS(ALAM-433.9).LT.0.2.AND.IHE2PR.GT.0) ISPEC=16
IF(ABS(ALAM-420.0).LT.0.2.AND.IHE2PR.GT.0) ISPEC=17
IF(ABS(ALAM-410.0).LT.0.2.AND.IHE2PR.GT.0) ISPEC=18
IF(ABS(ALAM-402.6).LT.0.2.AND.IHE2PR.GT.0) ISPEC=19
IF(ABS(ALAM-396.8).LT.0.2.AND.IHE2PR.GT.0) ISPEC=20
IF(ABS(ALAM-392.3).LT.0.2.AND.IHE2PR.GT.0) ISPEC=21
ELSE
IF(ABS(ALAM-1012.4).LT.0.2.AND.IHE2PR.GT.0) ISPEC=22
IF(ABS(ALAM-656.0).LT.0.2.AND.IHE2PR.GT.0) ISPEC=23
IF(ABS(ALAM-541.2).LT.0.2.AND.IHE2PR.GT.0) ISPEC=24
END IF
END IF
END IF
RETURN
END
synspec/extracted/levsol.f
+37
View File
@@ -0,0 +1,37 @@
SUBROUTINE LEVSOL(A,B,POPP,NLVCAL)
C ==================================
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION A(MLEVEL,MLEVEL),B(MLEVEL),POPP(MLEVEL),
* AP(MLEVEL,MLEVEL),BP(MLEVEL),POPP1(MLEVEL)
C
C new populations by inverting several partial rate matrices for the
C individual chemical species
C
if(nlvcal.le.0) return
DO 50 IAT=1,NATOM
N1=N0A(IAT)
NK=NKA(IAT)
IF(N1.LE.0) THEN
DO 1 I=N0A(IAT),NKA(IAT)
N1=I
IF(I.GT.0) GO TO 2
1 CONTINUE
2 CONTINUE
END IF
IF(N1.LE.0) GO TO 50
NLP=NK-N1+1
DO 20 I=N1,NK
DO 10 J=N1,NK
AP(I-N1+1,J-N1+1)=A(I,J)
10 CONTINUE
BP(I-N1+1)=B(I)
20 CONTINUE
CALL LINEQS(AP,BP,POPP1,NLP,MLEVEL)
DO 30 I=N1,NK
POPP(I)=POPP1(I-N1+1)
30 CONTINUE
50 CONTINUE
RETURN
END
synspec/extracted/lineqs.f
+63
View File
@@ -0,0 +1,63 @@
SUBROUTINE LINEQS(A,B,X,N,NR)
C =============================
C
C Solution of the linear system A*X=B
C by Gaussian elimination with partial pivoting
C
C Input: A - matrix of the linear system, with actual size (N x N),
C and maximum size (NR x NR)
C B - the rhs vector
C Output: X - solution vector
C Note that matrix A and vector B are destroyed here !
C
INCLUDE 'PARAMS.FOR'
DIMENSION A(NR,NR),B(NR),X(NR),D(MLEVEL)
DIMENSION IP(MLEVEL)
DO 70 I=1,N
DO 10 J=1,N
10 D(J)=A(J,I)
IM1=I-1
IF(IM1.LT.1) GO TO 40
DO 30 J=1,IM1
IT=IP(J)
A(J,I)=D(IT)
D(IT)=D(J)
JP1=J+1
DO 20 K=JP1,N
20 D(K)=D(K)-A(K,J)*A(J,I)
30 CONTINUE
40 AM=ABS(D(I))
IP(I)=I
DO 50 K=I,N
IF(AM.GE.ABS(D(K))) GO TO 50
IP(I)=K
AM=ABS(D(K))
50 CONTINUE
IT=IP(I)
A(I,I)=D(IT)
D(IT)=D(I)
IP1=I+1
IF(IP1.GT.N) GO TO 80
DO 60 K=IP1,N
60 A(K,I)=D(K)/A(I,I)
70 CONTINUE
80 DO 100 I=1,N
IT=IP(I)
X(I)=B(IT)
B(IT)=B(I)
IP1=I+1
IF(IP1.GT.N) GO TO 110
DO 90 J=IP1,N
90 B(J)=B(J)-A(J,I)*X(I)
100 CONTINUE
110 DO 140 I=1,N
K=N-I+1
SUM=0.
KP1=K+1
IF(KP1.GT.N) GO TO 130
DO 120 J=KP1,N
120 SUM=SUM+A(K,J)*X(J)
130 X(K)=(X(K)-SUM)/A(K,K)
140 CONTINUE
RETURN
END
synspec/extracted/linop.f
+158
View File
@@ -0,0 +1,158 @@
SUBROUTINE LINOP(ID,ABLIN,EMLIN,AVAB)
C =====================================
C
C TOTAL LINE OPACITY (ABLIN) AND EMISSIVITY (EMLIN)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
PARAMETER (UN = 1.,
* EXT0 = 3.17,
* TEN = 10.,
* C3 = 1.4387886,
* XET = 8067.6,
* XET3 = XET*C3)
DIMENSION ABLIN(MFREQ),EMLIN(MFREQ),ABLINN(MFREQ)
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
COMMON/NLTPOP/PNLT(MATOM,MION,MDEPTH)
common/lasers/lasdel
C
DO 10 IJ=1,NFREQ
ABLIN(IJ)=0.
ABLINN(IJ)=0.
EMLIN(IJ)=0.
10 CONTINUE
C
IF(NLIN.EQ.0) RETURN
C
C overall loop over contributing lines
C
TEM1=UN/TEMP(ID)
DO 100 I=1,NLIN
IL=INDLIN(I)
INNLT=INDNLT(IL)
IAT=INDAT(IL)/100
ION=MOD(INDAT(IL),100)
LPR=.TRUE.
ISP=ISPRF(IL)
IF(ISP.GT.1.AND.ISP.LE.5) LPR=.FALSE.
IF (ISP.GE.6) GO TO 100
CALL PROFIL(IL,IAT,ID,AGAM)
DOP1=DOPA1(IAT,ID)
FR0=FREQ0(IL)
IF(INNLT.EQ.0) THEN
AB0=EXP(GF0(IL)-EXCL0(IL)*TEM1)*RRR(ID,ION,IAT)*
* DOP1*STIM(ID)
ELSE IF(INNLT.GT.0) THEN
AB0=ABCENT(INNLT,ID)
SL0=SLIN(INNLT,ID)
ELSE
ILW=ILOWN(IL)
IUN=IUPN(IL)
COR=1.
PP=PNLT(IAT,ION,ID)
IF(ILW.GT.0) THEN
PI=POPUL(ILW,ID)/G(ILW)
ELSE
PI=PP*EXP((ENEV(IAT,ION)*XET3-EXCL0(IL))*TEM1)
END IF
IF(IUN.GT.0) THEN
PJ=POPUL(IUN,ID)/G(IUN)
cor=(excu0(il)-excl0(il)+
* (enion(iun)-enion(ilw))/1.38054e-16)*tem1
cor=exp(cor)
ELSE
PJ=PP*EXP((ENEV(IAT,ION)*XET3-EXCU0(IL))*TEM1)
END IF
if(pj.gt.0.) then
X=PI/PJ*cor
else
x=un
end if
IF(X.EQ.UN) X=EXP(4.79928E-11*FREQ0(IL)*TEM1)
SL0=BNUL(IL)/(X-UN)
ab0=0.
if(pi.gt.0.) AB0=PI*(UN-UN/X)*EXP(GF0(IL))*DOP1
END IF
if(ab0.le.0.and.lasdel) go to 100
C
C set up limiting frequencies where the line I is supposed to
C contribute to the opacity
C
EX0=AB0/AVAB*AGAM
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
EXT=EXT/DOP1
XIJEXT=DFRCON*EXT+1.5
c IJ1=MAX(IJCNTR(I)-IJEXT,3)
c IJ2=MIN(IJCNTR(I)+IJEXT,NFREQS)
IJ1=int(MAX(float(IJCNTR(I))-XIJEXT,3.))
IJ2=int(MIN(float(IJCNTR(I))+XIJEXT,float(NFREQS)))
IF(IJ1.GE.NFREQ.OR.IJ2.LE.2) GO TO 100
C
IF(INNLT.EQ.0) THEN
C
C *********
C LTE lines
C *********
C
IF(LPR) THEN
C
DO 40 IJ=IJ1,IJ2
XF=ABS(FREQ(IJ)-FR0)*DOP1
ABLIN(IJ)=ABLIN(IJ)+AB0*VOIGTK(AGAM,XF)
40 CONTINUE
C
C special expressions for 4 selected He I lines
C
ELSE
DO 60 IJ=3,NFREQ
FR=FREQ(IJ)
ABL=AB0*PHE1(ID,FR,ISP-1)
ABLIN(IJ)=ABLIN(IJ)+ABL
60 CONTINUE
END IF
C
C **********
C NLTE LINES
C **********
C
ELSE
IF(LPR) THEN
C
DO 80 IJ=IJ1,IJ2
XF=ABS(FREQ(IJ)-FR0)*DOP1
ABL=AB0*VOIGTK(AGAM,XF)
ABLINN(IJ)=ABLINN(IJ)+ABL
EMLIN(IJ)=EMLIN(IJ)+ABL*SL0
80 CONTINUE
C
C again, special expressions for 4 selected He I lines
C
ELSE
DO 90 IJ=3,NFREQ
FR=FREQ(IJ)
ABL=AB0*PHE1(ID,FR,ISP-1)
ABLINN(IJ)=ABLINN(IJ)+ABL
EMLIN(IJ)=EMLIN(IJ)+ABL*SL0
90 CONTINUE
END IF
END IF
100 CONTINUE
C
DO 110 IJ=3,NFREQ
EMLIN(IJ)=EMLIN(IJ)+ABLIN(IJ)*PLAN(ID)
ABLIN(IJ)=ABLIN(IJ)+ABLINN(IJ)
110 CONTINUE
C
C special routine for selected He II lines
C
IF(NSP.EQ.0) RETURN
DO 120 IS=1,NSP
ISP=ISP0(IS)
IF(ISP.GE.6.AND.ISP.LE.24) CALL PHE2(ISP,ID,ABLIN,EMLIN)
120 CONTINUE
C
RETURN
END
synspec/extracted/linopw.f
+241
View File
@@ -0,0 +1,241 @@
SUBROUTINE LINOPW(ID,ABLIN,EMLIN)
C =================================
C
C TOTAL LINE OPACITY (ABLIN) AND EMISSIVITY (EMLIN)
C (a variant for winds)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
INCLUDE 'WINCOM.FOR'
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
PARAMETER (UN = 1.,
* EXT0 = 3.17,
* TEN = 10.,
* C3 = 1.4387886,
* XET = 8067.6,
* XET3 = XET*C3)
DIMENSION ABLIN(MFREQ),EMLIN(MFREQ),ABLINN(MFREQ)
COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH)
COMMON/NLTPOP/PNLT(MATOM,MION,MDEPTH)
COMMON/IPOTLS/IPOTL(mlin0)
common/lasers/lasdel
common/linrej/ilne(mdepth),ilvi(mdepth)
common/velaux/velmax,iemoff,nltoff,itrad
C
DO 10 IJ=1,NFREQ
ABLIN(IJ)=0.
ABLINN(IJ)=0.
EMLIN(IJ)=0.
10 CONTINUE
wdil(id)=1.
plw=plan(id)*wdil(id)
c plw=xjcon(id)
C
IF(NLIN.EQ.0) RETURN
C
C overall loop over contributing lines
C
TEM1=UN/TEMP(ID)
HKT=HK*TEM1
xx=freq(nopac)-freq(1)
DFRCON=NOPAC-1
DFRCON=-DFRCON/XX
IFRCON=int(DFRCON)
DO 100 I=1,NLIN
IL=INDLIN(I)
INNLT=INDNLT(IL)
c
c rejecting lines for v > velmax
c
if(ilvi(id).gt.0) then
if(innlt.eq.0) then
go to 100
else
if(nltoff.ne.0) go to 100
end if
end if
c
c
c frequency indices of the line centers
c
if (id.eq.1) then
fr0=freq0(il)
XJC=3.+DFRCON*(FREQ(1)-FR0)
IJC=int(XJC)
IJCNTR(I)=IJC
if(ijc.le.1.or.ijc.ge.nopac) go to 255
if(fr0.lt.freq(ijc)) then
ijc0=ijc
dfr0=freq(ijc0)-fr0
252 ijc0=ijc0+1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0+1
dfr0=dfr
go to 252
end if
else if(fr0.gt.freq(ijc)) then
ijc0=ijc
dfr0=fr0-freq(ijc0)
254 ijc0=ijc0-1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0-1
dfr0=dfr
go to 254
end if
end if
IJCNTR(I)=IJC
255 continue
c write(80,*) i,ijcntr(i),2.997925e18/freq0(il)
endif
c
IAT=INDAT(IL)/100
ION=MOD(INDAT(IL),100)
FR0=FREQ0(IL)
LPR=.TRUE.
ISP=ISPRF(IL)
IF(ISP.GT.1.AND.ISP.LE.5) LPR=.FALSE.
IF (ISP.GE.6) GO TO 100
CALL PROFIL(IL,IAT,ID,AGAM)
DOP1=DOPA1(IAT,ID)/FR0
FR0=FREQ0(IL)
IF(INNLT.EQ.0) THEN
if(itrad.le.0) then
AB0=EXP(GF0(IL)-EXCL0(IL)*TEM1)*RRR(ID,ION,IAT)*
* DOP1*(1.-exp(-hkt*fr0))
else
trl=trad(ipotl(il),id)
xx=exp(-hkt*fr0)
AB0=EXP(GF0(IL)-EXCL0(IL)/trl)*RRR(ID,ION,IAT)*
* DOP1*(1.-xx)
if(excl0(il).gt.2000.) ab0=ab0*wdil(id)
pla=1.4743e-2*(fr0*1.e-15)**3*xx/(1.-xx)
sl0=pla*wdil(id)
end if
ELSE IF(INNLT.GT.0) THEN
AB0=ABCENT(INNLT,ID)
SL0=SLIN(INNLT,ID)
ELSE
ILW=ILOWN(IL)
IUN=IUPN(IL)
COR=1.
PP=PNLT(IAT,ION,ID)
IF(ILW.GT.0) THEN
PI=POPUL(ILW,ID)/G(ILW)
ELSE
PI=PP*EXP((ENEV(IAT,ION)*XET3-EXCL0(IL))*TEM1)
END IF
IF(IUN.GT.0) THEN
PJ=POPUL(IUN,ID)/G(IUN)
cor=(excu0(il)-excl0(il)+
* (enion(iun)-enion(ilw))/1.38054e-16)*tem1
cor=exp(cor)
ELSE
PJ=PP*EXP((ENEV(IAT,ION)*XET3-EXCU0(IL))*TEM1)
END IF
if(pj.gt.0.) then
X=PI/PJ*cor
else
x=un
end if
IF(X.EQ.UN) X=EXP(4.79928E-11*FREQ0(IL)*TEM1)
SL0=BNUL(IL)/(X-UN)
ab0=0.
if(pi.gt.0.) AB0=PI*(UN-UN/X)*EXP(GF0(IL))*DOP1
END IF
if(ab0.le.0.and.lasdel) go to 100
C
C set up limiting frequencies where the line I is supposed to
C contribute to the opacity
C
c if(ifwin.le.0) then
avabw=abstdw(ijcont(il),id)*relop
EX0=AB0/AVABw*AGAM
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
EXT=EXT/DOP1
IJEXT=int((DFRCON*EXT)+1.5)
IJ1=MAX(IJCNTR(I)-IJEXT,1)
IJ2=MIN(IJCNTR(I)+IJEXT,NFREQ)
IF(IJ1.GE.NFREQ.OR.IJ2.LE.2) GO TO 100
c else
c ij1=3
c ij2=nfreq
c end if
C
IF(INNLT.EQ.0.and.itrad.le.0) THEN
C
C *********
C LTE lines
C *********
C
IF(LPR) THEN
C
DO 40 IJ=IJ1,IJ2
XF=ABS(FREQ(IJ)-FR0)*DOP1
ABLIN(IJ)=ABLIN(IJ)+AB0*VOIGTK(AGAM,XF)
40 CONTINUE
C
C special expressions for 4 selected He I lines
C
ELSE
DO 60 IJ=1,NFREQ
FR=FREQ(IJ)
ABL=AB0*PHE1(ID,FR,ISP-1)
ABLIN(IJ)=ABLIN(IJ)+ABL
60 CONTINUE
END IF
C
C **********
C NLTE LINES
C **********
C
ELSE
IF(LPR) THEN
C
DO 80 IJ=IJ1,IJ2
XF=ABS(FREQ(IJ)-FR0)*DOP1
ABL=AB0*VOIGTK(AGAM,XF)
ABLINN(IJ)=ABLINN(IJ)+ABL
if(ilne(id).gt.0) go to 80
EMLIN(IJ)=EMLIN(IJ)+ABL*SL0
80 CONTINUE
C
C again, special expressions for 4 selected He I lines
C
ELSE
DO 90 IJ=1,NFREQ
FR=FREQ(IJ)
ABL=AB0*PHE1(ID,FR,ISP-1)
ABLINN(IJ)=ABLINN(IJ)+ABL
if(ilne(id).gt.0) go to 90
EMLIN(IJ)=EMLIN(IJ)+ABL*SL0
90 CONTINUE
END IF
END IF
100 CONTINUE
C
if(vel(id).le.velmax) then
DO 110 IJ=1,NFREQ
PLA=BNUE(IJ)/(EXP(HKT*FREQ(IJ))-1.)
EMLIN(IJ)=EMLIN(IJ)+ABLIN(IJ)*pla*wdil(id)
ABLIN(IJ)=ABLIN(IJ)+ABLINN(IJ)
110 CONTINUE
end if
C
C special routine for selected He II lines
C
IF(NSP.EQ.0) RETURN
DO 120 IS=1,NSP
ISP=ISP0(IS)
IF(ISP.GE.6.AND.ISP.LE.24) CALL PHE2(ISP,ID,ABLIN,EMLIN)
120 CONTINUE
C
RETURN
END
synspec/extracted/locate.f
+26
View File
@@ -0,0 +1,26 @@
SUBROUTINE locate(xx,n,x,j,nxdim)
c =================================
c
IMPLICIT REAL*8(A-H,O-Z)
dimension xx(nxdim)
c
jl=0
ju=n+1
10 if(ju-jl.gt.1)then
jm=(ju+jl)/2
if((xx(n).ge.xx(1)).eqv.(x.ge.xx(jm)))then
jl=jm
else
ju=jm
endif
goto 10
endif
if(x.eq.xx(1)) then
j=1
else if(x.eq.xx(n)) then
j=n-1
else
j=jl
endif
return
END
synspec/extracted/lyahhe.f
+61
View File
@@ -0,0 +1,61 @@
subroutine lyahhe(xl,ahe,prof)
c ==============================
c
c Lyman alpha broadening by helium - after N. Allard
c
INCLUDE 'PARAMS.FOR'
parameter (nxmax=1000)
c parameter (sthe=1.e21)
common/hhebrd/sthe,nunhhe
common/calhhe/xlhhe(nxmax),sighhe(nxmax),nxhhe
dimension xlhh0(nxmax),sighh0(nxmax)
data iread/0/
c
if(iread.eq.0) then
c nxhhe=679
c open(unit=67,
c * file='siglyhhe_21_T14500.lam',
c * status='old')
it=0
do i=1,nxmax
read(67,*,err=5,end=5) xl,sig
it=it+1
if(nunhhe.eq.1) xl=1./(1.e-8*xl+1./1215.67)
xlhh0(it)=xl
sighh0(it)=sig
end do
5 nxhhe=it
do i=1,nxhhe
xlhhe(i)=xlhh0(nxhhe-i+1)
sighhe(i)=sighh0(nxhhe-i+1)
end do
c do i=1,nxhhe
c j=nxhhe-i+1
c read(67,*) xlhhe(j),sighhe(j)
c end do
close(67)
iread=1
end if
c
prof=0.
if(xl.gt.xlhhe(nxhhe)) return
jl=0
ju=nxhhe+1
10 if(ju-jl.gt.1) then
jm=(ju+jl)/2
if((xlhhe(nxhhe).gt.xlhhe(1)).eqv.(xl.gt.xlhhe(jm))) then
jl=jm
else
ju=jm
endif
go to 10
endif
j=jl
c
if(j.eq.0) j=1
if(j.eq.nxhhe) j=j-1
a1=(xl-xlhhe(j))/(xlhhe(j+1)-xlhhe(j))
s1=(1.0-a1)*sighhe(j)+a1*sighhe(j+1)
prof=s1*ahe/sthe*6.2831855
return
end
synspec/extracted/lymlin.f
+68
View File
@@ -0,0 +1,68 @@
SUBROUTINE LYMLIN(ID,FREQ,ABLY,EMLY,SCLY)
C =========================================
C
C OPACITY OF THE LYMAN LINES WINGS (ALPHA - DELTA)
C WITH APPROXIMATE PARTIAL REDISTRIBUTION
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
DIMENSION SN(4),SR(4),SS(4),GS(4),FRLY(4),BNLY(4),GA(4)
DATA FRLY / 2.4660375E15, 2.9227111E15, 3.0825469E15, 3.156528E15/
* ,BNLY / 5.527E-2, 4.090E-2, 2.699E-2, 1.855E-2 /,
* SN / 1.308E5, 5.280E3, 5.847E2, 1.078E2 /,
* SR / 1.218E-16, 9.196E-17, 1.058E-16, 1.296E-16 /,
* SS / 9.478E-3, 1.600E-2, 1.441E-2, 1.547E-2 /,
* GS / 7.237E-8, 5.432E-6, 5.821E-5, 4.027E-4 /,
* GA / 1.000, 1.791, 2.362, 2.801 /
C
data icomp/0/
if(iath.le.0) return
if(icomp.eq.0) then
icomp=1
read(4,*,err=10,end=10) ifstrk,ifnat,ifres,ifprd,ifsti
go to 11
10 continue
ifstrk=0
ifnat=1
ifres=1
ifprd=0
ifsti=0
if(iophli.lt.0) then
ifstrk=1
ifprd=1
end if
11 continue
end if
c
ABLY=0.
EMLY=0.
SCLY=0.
if(freq.gt.3.3e15) return
P=POPUL(N0HN,ID)
T=TEMP(ID)
ANE=ELEC(ID)
DO 40 I=1,4
DFR=ABS(FRLY(I)-FREQ)
IF(DFR.LE.5.E11) DFR=1.E12
DFR2=DFR*DFR
DFRS=SQRT(DFR)
COR=(2.*FREQ/(FREQ+FRLY(I)))**2
F=1.
IF(iabs(IOPHLI).EQ.2) F=FEAUTR(FREQ,ID)
STARK=SS(I)*ANE*F/DFR2/DFRS
if(ifstrk.eq.0) stark=0.
if(ifnat.eq.0) sn(i)=0.
if(ifres.eq.0) sr(i)=0.
SGLY=SN(I)*(1.+SR(I)*P)*COR/DFR2+STARK
sgly=sgly*wnhint(i+1,id)
GAMA=1./(GA(I)+GS(I)*ANE*F/DFRS)
if(ifprd.eq.0) gama=0.
ABLY=ABLY+P*SGLY
EMLY=EMLY+POPUL(N0HN+I,ID)*SGLY*BNLY(I)*(1.-GAMA)
if(ifsti.ne.0) ably=ably-popul(n0hn+i,id)*sgly/(i+1)/(i+1)
SCLY=SCLY+P*SGLY*GAMA
40 CONTINUE
RETURN
END
synspec/extracted/matinv.f
+76
View File
@@ -0,0 +1,76 @@
SUBROUTINE MATINV(A,N,NR)
C =========================
C
C Matrix inversion
C by LU decomposition
C
C A - matrix of actual size (N x N) and maximum size (NR x NR)
C to be inverted;
C Inversion is accomplished in place and the original matrix is
C replaced by its inverse
C
INCLUDE 'PARAMS.FOR'
DIMENSION A(NR,NR)
IF(N.EQ.1) GO TO 250
DO 50 I=2,N
IM1=I-1
DO 20 J=1,IM1
JM1=J-1
DIV=A(J,J)
SUM=0.
IF(JM1.LT.1) GO TO 20
DO 10 K=1,JM1
10 SUM=SUM+A(I,K)*A(K,J)
20 A(I,J)=(A(I,J)-SUM)/DIV
DO 40 J=I,N
SUM=0.
DO 30 K=1,IM1
30 SUM=SUM+A(I,K)*A(K,J)
40 A(I,J)=A(I,J)-SUM
50 CONTINUE
DO 80 II=2,N
I=N+2-II
IM1=I-1
IF(IM1.LT.1) GO TO 80
DO 70 JJ=1,IM1
J=I-JJ
JP1=J+1
SUM=0.
IF(JP1.GT.IM1) GO TO 70
DO 60 K=JP1,IM1
60 SUM=SUM+A(I,K)*A(K,J)
70 A(I,J)=-A(I,J)-SUM
80 CONTINUE
DO 110 II=1,N
I=N+1-II
DIV=A(I,I)
IP1=I+1
IF(IP1.GT.N) GO TO 110
DO 100 JJ=IP1,N
J=N+IP1-JJ
SUM=0.
DO 90 K=IP1,J
90 SUM=SUM+A(I,K)*A(K,J)
A(I,J)=-SUM/DIV
100 CONTINUE
110 A(I,I)=1.0D0/A(I,I)
C
DO 240 I=1,N
DO 230 J=1,N
K0=I
IF(J.GE.I) GO TO 220
SUM=0.
200 DO 210 K=K0,N
210 SUM=SUM+A(I,K)*A(K,J)
GO TO 230
220 K0=J
SUM=A(I,K0)
IF(K0.EQ.N) GO TO 230
K0=K0+1
GO TO 200
230 A(I,J)=SUM
240 CONTINUE
RETURN
250 A(1,1)=1.0D0/A(1,1)
RETURN
END
synspec/extracted/moleq.f
+262
View File
@@ -0,0 +1,262 @@
subroutine moleq(id,tt,an,aein,ane,ipri)
c ========================================
c
c calculation of the equilibrium state of atoms and molecules
c
c Input: id - depth point
c tt - temperature [K]
c an - number density
c aein - initial estimate of the electron density
c
c Output: ane - electron density
c
C Output through common/atomol:
c rrr(id,j,i) - N/U for the atom with atomic number i and
c ion j (j=1 for neutral, and j=2 for 1st ions)
c rrmol(imol,id) - N/U for the molecule with index imol
c (the index is given by the ordering of
c in the input file tsuji.molec
c
c
c Input data for molecules iven in the file
c tsuji.molec
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
character*128 MOLEC
COMMON/COMFH1/C(600,5),PPMOL(600),APMLOG(600),P(100),
* XIP(100),XI2(100),CCOMP(100),UIIDUI(100),
* FP(100),XKP(100),XK2(100),EPS,SWITER,
* NELEM(5,600),NATO(5,600),MMAX(600),
* NELEMX(100),NMETAL,NIMAX
common/moltst/pfmol(600,mdepth),anmol(600,mdepth),
* pfato(100,mdepth),anato(100,mdepth),
* pfion(100,mdepth),anion(100,mdepth)
common/ioniz2/anion2(30,mdepth)
DIMENSION NATOMM(5),NELEMM(5),
* emass(100),uelem(100),ull(100),anden(800),
* aelem(100)
dimension denso(mdepth),eleco(mdepth),wmmo(mdepth)
c
data nmetal/92/
c
data iread/1/
c
MOLEC ='data/tsuji.molec_bc2'
if(moltab.eq.0) MOLEC='data/tsuji.molec_orig'
c
ECONST=4.342945E-1
AVO=0.602217E+24
SPA=0.196E-01
GRA=0.275423E+05
AHE=0.100E+00
tk=1./(tt*1.38054e-16)
pgas=an/tk
sahcon=1.87840e20*tt*sqrt(tt)
nimax=3000
eps=1.e-5
switer=0.0
C
C---- data for atoms ----------------
C
if(iread.eq.1) then
c
do i=1,nmetal
ia=i
nelemx(i)=ia
ccomp(ia)=abndd(ia,id)
xip(ia)=enev(ia,1)
xi2(ia)=enev(ia,2)
emass(ia)=amas(ia)
end do
c
c---- read molecular data from a table ----------------------
c
J=0
OPEN(UNIT=26,FILE=MOLEC,STATUS='OLD')
10 J=J+1
IF(MOLTAB.GE.1)
* READ (26,510,end=20) CMOL(J),(C(J,K),K=1,5),MMAX(J),
* (NELEMM(M),NATOMM(M),M=1,4)
IF(MOLTAB.EQ.0)
* READ (26,511,end=20) CMOL(J),(C(J,K),K=1,5),MMAX(J),
* (NELEMM(M),NATOMM(M),M=1,4)
510 format(a8,5e13.5,9i3)
511 FORMAT (A8,E11.5,4E12.5,I1,(I2,I3),3(I2,I2))
c
c for now, exclude all molecules with 4 or more C atoms
c
do m=1,4
if(nelemm(m).eq.6.and.natomm(m).ge.5) then
j=j-1
go to 10
end if
end do
c
MMAXJ=MMAX(J)
IF(MMAXJ.EQ.0) GO TO 20
DO M=1,MMAXJ
NELEM(M,J)=NELEMM(M)
NATO(M,J)=NATOMM(M)
END DO
c write(6,680) j,cmol(j)
c 680 format(i5,a10)
GO TO 10
20 NMOLEC=J-1
close(26)
c
DO I=1,NMETAL
NELEMI=NELEMX(I)
P(NELEMI)=1.D-70
END DO
iread=0
endif
c
c---- end of reading atomic and molecular data ----------------------
c
p(99)= aein/tk
pesave=p(99)
p(99)=pesave
c
THETA=5040./tt
TEM=tt
PGLOG=log10(Pgas)
PG=Pgas
c
CALL RUSSEL(TEM,PG)
c
PE=P(99)
ane=pe*tk
PELOG=log10(PE)
emass(99)=5.486e-4
uelem(99)=2.
aelem(99)=pe*tk/(2.*sahcon*emass(nelemi)**1.5)
ull(99)=log10(aelem(99))
c
c----atoms-----------------------------------------------------------------
c
tmass=0.
DO I=1,NMETAL
NELEMI=NELEMX(I)
FPLOG=log10(FP(NELEMI))
anden(i)=(p(nelemi)+1.D-70)*tk
tmass=tmass+anden(i)*emass(nelemi)
call irwpf(nelemi,1,0,tt,u0)
uelem(nelemi)=u0
aelem(nelemi)=anden(i)/(u0*sahcon*emass(nelemi)**1.5)
ull(nelemi)=log10(aelem(nelemi))
rrr(id,1,nelemi)=anden(i)/u0
anato(nelemi,id)=anden(i)
pfato(nelemi,id)=u0
END DO
an1=anden(1)
c
c---- positive ions ---------------------------------------------------------
c
DO I=1,NMETAL
NELEMI=NELEMX(I)
PLOG= log10(P(NELEMI)+1.0D-70)
XKPLOG=log10(XKP(NELEMI)+1.0D-70)
PIONL=PLOG+XKPLOG-PELOG
anden(i+nmetal)=exp(pionl/econst)*tk
tmass=tmass+anden(i+nmetal)*emass(nelemi)
call irwpf(nelemi,2,0,tt,u1)
anion(nelemi,id)=anden(i+nmetal)
pfion(nelemi,id)=u1
rrr(id,2,nelemi)=anden(i+nmetal)/u1
if(nelemi.ge.2.and.nelemi.le.30) then
x2log=log10(XK2(NELEMI)+1.0D-70)
pion2=pionl+x2log-pelog
anion2(nelemi,id)=exp(pion2/econst)*tk
end if
END DO
anion2(1,id)=0.
c
c---- molecules-------------------------------------------------------------
c
DO J=1,NMOLEC
jm=j+2*nmetal
PMOLL=log10(PPMOL(J)+1.0D-70)
anden(jm)=exp(pmoll/econst)*tk
rrmol(j,id)=0.
umoll=1.
if(pmoll.gt.-30.) then
umoll=log10(anden(jm))+c(j,2)*theta
amasm=0.
do jjj=1,mmax(j)
i=nelem(jjj,j)
amasm=amasm+NATO(jjj,j)*emass(i)
umoll=umoll-NATO(jjj,j)*ull(i)
end do
ammol(j)=amasm
tmass=tmass+anden(jm)*amasm
umoll=exp(umoll/econst)/(sahcon*amasm**1.5)
c
c replace with EXOMOL data whenever available
c
um=0.
if(ipfexo.gt.0.and.tt.le.9000.)
* call exopf(j,tt,um)
if(um.gt.0.) then
umoll=um
else
c
c or with modified Irwin (Barklem & Collet) data whenever available
c
call irwpf(0,0,j,tt,um)
if(um.gt.0.) umoll=um
end if
c H-
c
if(j.eq.1) umoll=1.
c
c set up array RRR = number density/partition function
c
rrmol(j,id)=anden(jm)/umoll
end if
c
anmol(j,id)=anden(jm)
pfmol(j,id)=umoll
END DO
jm=2*nmetal
anhm(id)=anden(1+jm)
anh2(id)=anden(2+jm)
anch(id)=anden(5+jm)
anoh(id)=anden(4+jm)
C
C
C save new density, molecular weight, and abundances of
c atomic species
c
ipri1=ipri
denso(id)=dens(id)
eleco(id)=elec(id)
wmmo(id)=wmm(id)
dens(id)=tmass*hmass
elec(id)=pe*tk
wmm(id)=dens(id)/(an-elec(id))
ane=elec(id)
c
do i=1,nmetal
NELEMI=NELEMX(I)
ia=iatex(nelemi)
if(ia.gt.0) then
attot(ia,id)=(anato(nelemi,id)+anion(nelemi,id))
end if
end do
c
if(id.eq.nd) then
write(86,610)
do iid=1,nd
write(86,611) iid,dm(iid),temp(iid),elec(iid),eleco(iid),
* dens(iid),denso(iid),wmm(iid),wmmo(iid)
end do
end if
610 format(/' id m T ne(old) ne(new)',
* ' dens(old) dens(new) wmm(old) wmm(new)'/)
611 format(i4,1p8e10.2)
C
RETURN
END
synspec/extracted/molini.f
+78
View File
@@ -0,0 +1,78 @@
subroutine molini
c =================
c
c Initialization of the molecular equilibrium
c
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
common/moltst/pfmol(600,mdepth),anmol(600,mdepth),
* pfato(100,mdepth),anato(100,mdepth),
* pfion(100,mdepth),anion(100,mdepth)
dimension hpo(mdepth)
c
aeinit=1.0
c
do 10 id=1,nd
t=temp(id)
tln=log(t)*1.5
thl=11605./t
t32=exp(tln)
do i=1,MMOLEC
rrmol(i,id)=0.
end do
hpo(id)=DENS(ID)/WMM(ID)/YTOT(ID)
if(t.gt.tmolim) go to 10
HPOP=DENS(ID)/WMM(ID)/YTOT(ID)
an=dens(id)/wmm(id)+elec(id)
aeinit=0.1*an
if(t.lt.4000.) aeinit=0.01*an
call moleq(id,t,an,aeinit,ane,0)
c next initial guess will be the last ane determined for
c previous depth point
aeinit=ane
c
if (id.eq.idstd) then
write(6,600)
nmol=nmolec
if(id.eq.1) nmol=32
do i=1,nmol
write(6,601) i, cmol(i), rrmol(i,id), rrmol(i,id)/hpop
end do
end if
600 format(/ 'Molecular number densities at the standard depth'/)
601 format(i4,1x,A8,1x,1pe12.2,1x,e12.2)
10 continue
c update atomic populations once molecular densities are calculated
if(imode.lt.-4) then
do i=1,nlevel
iat=numat(iatm(i))
ion=iz(iel(i))
ii=nfirst(iel(i))
ener=(enion(ii)-enion(i))/bolk
if((enion(i).eq.0).and.(ilk(i).gt.0)) then
ener=0.
ion=ion+1
end if
if(ifwop(i).ge.0) then
do id=1,nd
popul(i,id)=rrr(id,ion,iat)*g(i)
* *exp(-ener/temp(id))
if(iat.eq.1.and.ion.eq.0) popul(i,id)=anhm(id)
end do
endif
end do
end if
c
return
end
synspec/extracted/molop.f
+61
View File
@@ -0,0 +1,61 @@
SUBROUTINE MOLOP(ID,ABLIN,EMLIN,AVAB,ILIST)
C ===========================================
C
C Total molecular line opacity (ABLIN) and emissivity (EMLIN)
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
PARAMETER (UN = 1.,
* EXT0 = 3.17,
* TEN = 10.)
DIMENSION ABLIN(MFREQ),EMLIN(MFREQ)
C
DO IJ=1,NFREQ
ABLIN(IJ)=0.
EMLIN(IJ)=0.
END DO
C
if(temp(id).gt.tmolim) return
IF(NLINML(ILIST).EQ.0) RETURN
if(inactm(ilist).ne.0) return
C
C overall loop over contributing lines
C
TEM1=UN/TEMP(ID)
ANE=ELEC(ID)
DO I=1,NLINML(ILIST)
IL=INMLIN(I,ILIST)
IMOL=INDATM(IL,ILIST)
DOP1=DOPMOL(IMOL,ID)
AGAM=(GRM(IL,ILIST)+GSM(IL,ILIST)*ANE+
* GVDW(IL,ILIST,ID))*DOP1
FR0=FREQM(IL,ILIST)
AB0=EXP(GFM(IL,ILIST)-EXCLM(IL,ILIST)*TEM1)*RRMOL(IMOL,ID)*
* DOP1*STIM(ID)
C
C set up limiting frequencies where the line I is supposed to
C contribute to the opacity
C
EX0=AB0/AVAB*AGAM
EXT=EXT0
IF(EX0.GT.TEN) EXT=SQRT(EX0)
EXT=EXT/DOP1
XIJEXT=DFRCON*EXT+1.5
IJ1=int(MAX(float(IJCMTR(I,ILIST))-XIJEXT,3.))
IJ2=int(MIN(float(IJCMTR(I,ILIST))+XIJEXT,float(NFREQS)))
IF(IJ1.LT.NFREQ.AND.IJ2.GT.2) THEN
DO IJ=IJ1,IJ2
XF=ABS(FREQ(IJ)-FR0)*DOP1
ABLIN(IJ)=ABLIN(IJ)+AB0*VOIGTK(AGAM,XF)
END DO
END IF
END DO
C
DO IJ=3,NFREQ
EMLIN(IJ)=EMLIN(IJ)+ABLIN(IJ)*PLAN(ID)
END DO
C
RETURN
END
synspec/extracted/molset.f
+143
View File
@@ -0,0 +1,143 @@
SUBROUTINE MOLSET(ILIST)
C ========================
C
C Selection of molecular lines that may contribute,
C set up auxiliary fields containing line parameters.
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
COMMON/LIMPAR/ALAM0,ALAM1,FRMIN,FRLAST,FRLI0,FRLIM
COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
common/alendm/alend(mmlist)
SAVE IMLAST
C
DATA CNM /2.997925D17/
C
if(inactm(ilist).ne.0) return
IL0=0
IPRSEM(ILIST)=0
NLINM=0
IREADM(ILIST)=1
IF(IBLANK.LE.1.OR.IMODE.EQ.1.OR.IMODE.EQ.-1) IREADM(ILIST)=0
IF(IBLANK.LE.1) APREV=0.
ALA0=CNM/FREQ(1)
ALA1=CNM/FREQ(2)
c
c skip if current wavelength larger than the largest wavelngth in the
c line list
c
if(ala0.gt.alend(ilist)) then
inactm(ilist)=1
return
end if
c
FRMINM=CNM/ALA0
FRM=FRMINM
SPACE=SPACE0
IF(ALAMC.GT.0.) SPACE=SPACE0*ALA0/ALAMC
IF(SPACE0.LT.0.) SPACE=-SPACE0
CUTOFF=CUTOF0*0.2
DOPSTD=1.E7/ALA0*DSTD
DISTAN=0.15*DOPSTD
SPAC=3.E16/ALA0/ALA0*SPACE
DISTA0=0.14*SPAC
IF(IBLANK.GE.2.AND.IMODE.EQ.-1) IL0=IMLAST
FRLI0=FRMINM
ASTD=1.0
AVAB=ABSTD(IDSTD)*RELOP
C
20 CONTINUE
C
C set up indices of lines
C IL0 - is the current index of line in the numbering of all lines
C
IF(IREADM(ILIST).EQ.1) THEN
IPRSEM(ILIST)=IPRSEM(ILIST)+1
IL0=INMLIP(IPRSEM(ILIST),ILIST)
IF(FREQM(IL0,ILIST).LT.FRMINM) THEN
IREADM(ILIST)=0
IL0=INMLIP(IPRSEM(ILIST)-1,ILIST)+1
END IF
ELSE
IL0=IL0+1
END IF
IF(IL0.GT.NLINM0(ILIST)) GO TO 210
FRLIM=FRLI0
FR0=FREQM(IL0,ILIST)
ALAM=CNM/FR0
C
IF(ALAM.LT.ALA0-CUTOFF) GO TO 20
IF(ALAM.GT.ALA1+CUTOFF) GO TO 210
C
C SECOND SELECTION : FOR LINE STRENGHTS
C
EXT=EXTINM(IL0,ILIST)
FRLI0=FR0-EXT-SPAC
IF(FRLI0.GT.FRLIM) FRLI0=FRLIM
IF(ALAM.LT.ALA0.AND.FR0-FRMINM.GT.EXT+SPAC) GO TO 20
IF(FREQ(NFREQS)-FR0.GT.EXT+SPAC) GO TO 20
C
NLINM=NLINM+1
if(nlinm.gt.mlinm) then
write(*,*) 'nlinm,mlinm',nlinm,mlinm
call quit('too many molecular lines in a set')
end if
INMLIN(NLINM,ILIST)=IL0
GO TO 20
c
c frequency indices of the line centers
c
210 CONTINUE
XX=FREQ(2)-FREQ(1)
DFRCON=NFREQ-3
DFRCON=-DFRCON/XX
IFRCON=INT(DFRCON)
DO 255 IL=1,NLINM
fr0=freqm(inmlin(il,ilist),ILIST)
XJC=3.+DFRCON*(FREQ(1)-FR0)
IJC=INT(XJC)
IJCMTR(IL,ILIST)=IJC
if(ijc.le.3.or.ijc.ge.nfreq) go to 255
if(fr0.lt.freq(ijc)) then
ijc0=ijc
dfr0=freq(ijc0)-fr0
252 ijc0=ijc0+1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0+1
dfr0=dfr
go to 252
end if
else if(fr0.gt.freq(ijc)) then
ijc0=ijc
dfr0=fr0-freq(ijc0)
254 ijc0=ijc0-1
dfr=abs(freq(ijc0)-fr0)
if(dfr.lt.dfr0) then
ijc=ijc0
ijc0=ijc0-1
dfr0=dfr
go to 254
end if
end if
IJCMTR(IL,ILIST)=IJC
255 continue
C
DO IL=1,NLINM
INMLIP(IL,ILIST)=INMLIN(IL,ILIST)
END DO
NLINML(ILIST)=NLINM
IMLAST=INMLIN(NLINML(ILIST),ILIST)
C
CALL INIBLM
C
c write(6,611) inmlin(1,ilist),inmlin(nlinm,ilist),
c * 2.997925e18/freqm(inmlin(1,ilist),ILIST),
c * 2.997925e18/freqm(inmlin(nlinm,ilist),ILIST)
c 611 format('mols',2i7,2f10.3)
RETURN
END

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