355 lines
8.6 KiB
Fortran
355 lines
8.6 KiB
Fortran
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
|