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