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/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