PROGRAM TLUSTY C C ****************** Version TLUSTY207 ******************** C C Non-LTE model stellar atmospheres computer program C Universal code for stellar atmospheres and accretion disks C C ********************************************************* C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ALIPAR.FOR' C OPEN(UNIT=91,STATUS='SCRATCH',FORM='UNFORMATTED') OPEN(UNIT=92,STATUS='SCRATCH',FORM='UNFORMATTED') OPEN(UNIT=93,STATUS='SCRATCH',FORM='UNFORMATTED') C C Initialization C INIT=1 ITER=0 CALL START LFIN=.FALSE. IF(NITER.EQ.0) LFIN=.TRUE. C C Basic iteration loop of the hybrid CL/ALI method: C 10 ITER=ITER+1 C C 1. Formal solution step C CALL RESOLV c CALL TIMING(1,ITER) INIT=0 IF(LFIN) GO TO 20 C C 1b. Acceleration of convergence C IF(IACC.GT.0) CALL ACCEL2 c IF(LAC2) GO TO 10 C C 2. Solution of the linearized equations C IF(IFRYB.EQ.0) THEN IF(NN.GT.MSMX) THEN CALL SOLVE ELSE CALL SOLVES END IF ELSE CALL RYBSOL END IF C CALL TIMING(2,ITER) GO TO 10 20 CONTINUE C STOP END C C C **************************************************************** C C BLOCK DATA C ========== C C Hydrogenic oscillator strentghs C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' C DATA ((OSH(I,J),I=1,20),J=1,16)/20*0., * 0.4162,19*0.,7.910D-2,0.6407,18*0.,2.899D-2,0.1193, * 0.8421,17*0.,1.394D-2,4.467D-2,0.1506,1.038,16*0.,7.799D-3, * 2.209D-2,5.584D-2,0.1793,1.231,15*0.,4.814D-3,1.270D-2,2.768D-2, * 6.549D-2,0.2069,1.424,14*0.,3.183D-3,8.036D-3,1.604D-2,3.23D-2, * 7.448D-2,0.234,1.616,13*0.,2.216D-3,5.429D-3,1.023D-2,1.87D-2, * 3.645D-2,8.315D-2,0.2609,1.807,12*0.,1.605D-3,3.851D-3,6.98D-3, * 1.196D-2,2.104D-2,4.038D-2,9.163D-2,0.2876,1.999,11*0.,1.201D-3, * 2.835D-3,4.996D-3,8.187D-3,1.344D-2,2.32D-2,4.416D-2,0.1,0.3143, * 2.19,10*0.,9.214D-4,2.151D-3,3.711D-3,5.886D-3,9.209D-3,1.479D-2, * 2.525D-2,4.787D-2,0.1083,0.3408,2.381,9*0.,7.227D-4,1.672D-3, * 2.839D-3,4.393D-3,6.631D-3,1.012D-2,1.605D-2,2.724D-2,5.152D-2, * 0.1166,0.3673,2.572,8*0.,5.744D-4,1.326D-3,2.224D-3,3.375D-3, * 4.959D-3,7.289D-3,1.097D-2,1.726D-2,2.918D-2,5.513D-2,0.1248, * 0.3938,2.763,7*0.,4.686D-4,1.07D-3,1.776D-3,2.656D-3,3.821D-3, * 5.455D-3,7.891D-3,1.177D-2,1.843D-2,3.109D-2,5.872D-2,0.133, * 0.4202,2.954,6*0.,3.856D-4,8.764D-4,1.443D-3,2.131D-3,3.014D-3, * 4.207D-3,5.905D-3,8.456D-3,1.254D-2,1.958D-2,3.298D-2,6.228D-2, * 0.1412,0.4467,3.145,5*0./ DATA ((OSH(I,J),I=1,20),J=17,20)/3.211D-4, * 7.270D-4,1.188D-3,1.739D-3, * 2.425D-3,3.324D-3,4.556D-3,6.323D-3,8.995D-3,.01328,.0207,.03486, * .06584,.1494,0.4731,3.336,4*0.,2.702D-4,6.099D-4,9.916D-4, * 1.439D-3,1.984D-3,2.679D-3,3.602D-3,4.877D-3,6.719D-3,9.515D-3, * 0.01402,.02182,.03672,.06938,.1575,.4995,3.527,3*0.,2.296D-4, * 5.167D-4,8.361D-4,1.204D-3,1.646D-3,2.196D-3,2.905D-3,3.856D-3, * 5.180D-3,7.099D-3,.01002,.01474,.02292,.03858,.07292,.1657,.5259, * 3.718,2*0.,1.967D-4,4.416D-4,7.118D-4,1.019D-3,1.382D-3,1.825D-3, * 2.383D-3,3.112D-3,4.094D-3,5.468D-3,7.468D-3,.01052,.01545, * .02402,.04043,.07644,0.1738,.5523,3.909,0./ END C C C **************************************************************** C C SUBROUTINE START C ================ C C General input and initialization procedure C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' common/hediff/ hcmass,radstr C read(1,*,end=10,err=10) idisk 10 continue call initia if(hcmass.gt.0.) call hedif nn0=nn CALL COMSET call prdini return end C C C **************************************************************** C C SUBROUTINE INITIA C ================= C C driver for input and initializations - "new" routine C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (T15=1.D-15) parameter (xcon=8.0935d-21) CHARACTER*20 FINSTD CHARACTER*40 FILEI CHARACTER*4 TYPIOI DIMENSION IGLE(18),IGMN(25),IGFE(26),IGNI(28) dimension fst(mfreq),extrd0(mfreq) COMMON/STRPAR/IMER,ITR,IC,IL,IP,NLASTE,NHOD,LASV COMMON/INUNIT/IUNIT common/freqcl/frmin,frmax,nfrecl 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/ C C ---------------------- C Basic input parameters C ---------------------- C CALL READBF(0) FRTABM=0. C C for a stellar atmosphere C IF(IDISK.EQ.0) THEN READ(IBUFF,*) TEFF,GRAV WRITE(6,601) TEFF,GRAV GRAV=EXP(2.3025851*GRAV) C C for an accretion disk C ELSE READ(IBUFF,*) XMSTAR,XMDOT,RSTAR,RELDST END IF c c the rest of input is the same for atmospheres and disks C READ(IBUFF,*) LTE,LTGREY READ(IBUFF,*) FINSTD CALL NSTPAR(FINSTD) C C ------------------------ C Specific input for disks C ------------------------ C IF(IDISK.EQ.1) CALL INPDIS C C ------------------------ c Initialize opacity table C ------------------------ c if(ioptab.ne.0) call tabini C C ---------------------------- C Frequency points and weights C ---------------------------- C C NFREAD - number of "continuum" frequency points which are C read. May be less than NFREQ - the actual number of C frequencies, because the frequency points in lines C can be calculated. C FREQ(IJ) - frequency (in sec**-1) of the IJ-th freq. point C W(IJ) - corresponding frequency quadrature weight C READ(IBUFF,*) NFREAD NJREAD=NFREAD if(njread.gt.mfreq) CALL QUIT('njread.gt.mfreq',njread,mfreq) C IF(NJREAD.LE.0) THEN frmin = FRCMIN frmax = FRCMAX NFREQ=-NJREAD if(ifrset.ge.0) then nfreq=ifrset frmin=frtab(numfreq) frmax=frtab(1) end if if(ifrset.lt.0) nfreqc=-ifrset nfreqc=nfreq if(nfreq.eq.1) then freq(1)=frmin w(1)=1. ijali(1)=1 else do ij=1,nfreq fr=log(frmin)+(log(frmax)-log(frmin))*(ij-1)/(nfreq-1) freq(nfreq-ij+1)=exp(fr) ijali(ij)=1 end do end if C C setting simple quadrature weights - trapezoidal integration C if(nfreq.gt.1) then w(1)=0.5*(freq(1)-freq(2)) w(nfreq)=0.5*(freq(nfreq-1)-freq(nfreq)) do ij=2,nfreq-1 w(ij)=0.5*(freq(ij-1)-freq(ij+1)) end do end if ELSE NFREQC=NJREAD END IF C C ---------------------------------------------------- C Initialize 1/i*i, 1/i*i*i; and turbulent velocities C ---------------------------------------------------- C DO I=1,NLMX X=I XI2(I)=UN/(X*X) XI3(I)=XI2(I)/X END DO C IF(ABS(VTB).LT.1.E3) VTB=VTB*1.E5 DO ID=1,ND IF(VTB.GT.0.) VTURB(ID)=VTB IF(IPTURB.EQ.0) VTURB(ID)=0. VTURBS(ID)=ABS(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 STATE(0,ID,X1,X2) ID=1 WRITE(6,602) YTOT(ID),WMY(ID),WMM(ID) C C check consistency of the opacity table C c if(ioptab.gt.0.and.iopold.eq.0) call chctab c DO I=1,MLEVEL ILK(I)=0 DO J=1,MLEVEL ITRA(J,I)=0 END DO END DO c if(nfrecl.gt.nfreq) nfrecl=nfreq do ij=1,nfrecl ijali(ij)=0 end do C IF(NFFIX.EQ.2) THEN DO IJ=1,NFREQC IJALI(IJ)=1 END DO END IF C C -------------------------------------------------------------- C Input of parameters for explicit ions, levels, and transitions C -------------------------------------------------------------- C ILEV=0 IATLST=0 ION=0 IA=0 IUNIT=20 NATOM=0 NLEVEL=0 10 CONTINUE READ(IBUFF,*,END=20,ERR=20) IATII,IZII,NLEVSI,ILASTI,ILVLIN, * NONSTD,TYPIOI,FILEI IF(ILASTI.EQ.0) THEN ION=ION+1 if(ion.gt.mion) CALL QUIT('ion.gt.mion',ion,mion) IATI(ION)=IATII IZI(ION)=IZII ILTION(ION)=0 if(nlevsi.lt.0) then iltion(ion)=2 nlevsi=-nlevsi end if NLEVS(ION)=NLEVSI TYPION(ION)=TYPIOI FIDATA(ION)=FILEI NLLIM(ION)=ILVLIN INODF1(ION)=0 INODF2(ION)=0 IUPSUM(ION)=0 ICUP(ION)=16 FF(ION)=0. 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.1.AND.IZI(ION).EQ.-1) THEN IUPSUM(ION)=0 ICUP(ION)=0 MODEFF=3 END IF IF(IATI(ION).EQ.2.AND.IZI(ION).EQ.1) THEN MODEFF=2 ICUP(ION)=32 END IF IF(NONSTD.GT.0) THEN READ(IBUFF,*) IUPSUM(ION),ICUP(ION),MODEFF,NFF ELSE IF(NONSTD.LT.0) THEN READ(IBUFF,*) INODF1(ION),INODF2(ION),FIODF1(ION), * FIODF2(ION),FIBFCS(ION) IKOBS(ION)=IABS(NONSTD) if(ispodf.ge.1) then IF(INODF1(ION).EQ.0) THEN IUNIT=IUNIT+1 INODF1(ION)=IUNIT END IF IF(INODF2(ION).EQ.0) THEN IUNIT=IUNIT+1 INODF2(ION)=IUNIT END IF end if IF(FIBFCS(ION).NE.' ') THEN IUNIT=IUNIT+1 INBFCS(ION)=IUNIT END IF IUPSUM(ION)=1 ICUP(ION)=0 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) if(ilev.gt.mlevel) CALL QUIT('ilev.gt.mlevel',ilev,mlevel) IZ(ION)=IZI(ION)+1 CHARG2(ION)=IZ(ION)*IZ(ION) IF(IFMOFF.gt.0) THEN NFF=NQUANT(NLAST(ION))+1 IF(NFF.GT.0) FF(ION)=EH/H*IZ(ION)*IZ(ION)/NFF/NFF END IF N0I=NFIRST(ION) N1I=NLAST(ION) NKI=NNEXT(ION) ITRA(NKI,NKI)=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) THEN IELHM=ION IOPHMI=0 END IF 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(ION.EQ.1) WRITE(6,603) WRITE(6,604) ION,TYPION(ION),N0I,N1I,NKI,IZ(ION), * IUPSUM(ION),ICUP(ION),FF(ION) C ELSE IF(ILASTI.GT.0) THEN ENION(ILEV)=0. G(ILEV)=ILASTI NQUANT(ILEV)=1 TYPLEV(ILEV)=TYPIOI IMODL(ILEV)=0 IFWOP(ILEV)=0 IEL(ILEV)=ION NKA(IA)=NNEXT(ION) if(modref.ge.0) nref(ia)=nka(ia) 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(ioptab.gt.0.and.iopold.eq.0) call chctab write(6,631) * iopadd,irsct,irsche,irsch2,iophmi,ioph2p,iopoh,iopch 631 format(/'iopadd,irsct,irsche,irsch2,iophmi,ioph2p,iopoh,iopch', * 8i6) C IMER=0 ITR=0 ITRX=0 IC=0 IL=0 IP=0 IF(NFREAD.LE.0) THEN NLASTE=NFREQC NFREQ=NFREQC ELSE NLASTE=0 NFREQ=0 END IF LBPFX=.TRUE. C lasv=.false. DO ION=1,NION CALL RDATA(ION) IF(IFMOFF.gt.0) THEN NFF=NQUANT(NLAST(ION))+1 IF(NFF.GT.0) FF(ION)=EH/H*IZ(ION)*IZ(ION)/NFF/NFF END IF END DO C NTRANS=ITR NFREQ=NLASTE NCON=IC if(ntrans.gt.mtrans) CALL QUIT('ntrans.gt.mtrans',ntrans,mtrans) C CALL LEVSET C c WRITE(6,605) DO I=1,NLEVEL IF(I.EQ.1) WRITE(6,605) WRITE(6,606) I,TYPLEV(I),TYPION(IEL(I)),ENION(I)/H,G(I), * NQUANT(I),IEL(I),ILK(I),IATM(I), * IMODL(I),ILTLEV(I),IIEXP(I),IIFOR(I) END DO C C ----------------------------------------------------------- C useful quantities for later use C ----------------------------------------------------------- C DO 125 IT=1,NTRANS FRQMX(IT)=0. LINEXP(IT)=(.NOT.LINE(IT).OR.INDEXP(IT).EQ.0) IF(LINEXP(IT)) GO TO 125 FFMX=0. DO IJ=IFR0(IT),IFR1(IT) FFMX=MAX(FFMX,FREQ(IJ)) END DO FRQMX(IT)=FFMX 125 CONTINUE C C ------------------------------------------------------ C setup continuum frequencies (if they are not read) C ------------------------------------------------------ C if(nfreq.gt.mfreq) CALL QUIT('nfreq.gt.mfreq',nfreq,mfreq) if(nfreqc.gt.mfreqc) CALL QUIT('nfreqc.gt.mfreqc',nfreqc,mfreqc) IF(NFREAD.GT.0.AND.ISPODF.EQ.0) THEN IF(IOPTAB.EQ.0) THEN CALL INIFRC(0) ELSE IF(IOPTAB.GT.0) THEN CALL INIFRT END IF END IF IF(ISPODF.GE.1) CALL INIFRS IF(FRLMAX.LE.0.) FRLMAX=FREQ(1) C C --------------------------------------------------------- C setup depth-independent line profiles (sampling mode) C --------------------------------------------------------- C IF(ISPODF.GE.1) THEN TSTD=0.75*TEFF DO 80 IT=1,NTRANS IF(LINEXP(IT)) GOTO 80 INDXPA=IABS(INDEXP(IT)) IF(INDXPA.GE.2 .AND. INDXPA.LE.4) GO TO 80 CALL DOPGAM(IT,1,TSTD,DOP,AGAM) CALL LINSPL(IT,DOP,AGAM) 80 CONTINUE END IF C call rdatax(0,ic,0) C C check the dimensions C if(nd.gt.mdepth) CALL QUIT('nd.gt.mdepth',nd,mdepth) if(nfreq.gt.mfreq) CALL QUIT('nfreq.gt.mfreq',nfreq,mfreq) if(nfreqc.gt.mfreqc) CALL QUIT('nfreqc.gt.mfreqc',nfreqc,mfreqc) if(nfreqe.gt.mfrex) CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex) if(nlevel.gt.mlevel) CALL QUIT('nlevel.gt.mlevel',nlevel,mlevel) if(ntrans.gt.mtrans) CALL QUIT('ntrans.gt.mtrans',ntrans,mtrans) if(natom.gt.matom) CALL QUIT('natom.gt.matom',natom,matom) if(nion.gt.mion) CALL QUIT('nion.gt.mion',nion,mion) if(ibfint.eq.0.and.nfreq.gt.mfreqc) * CALL QUIT('nfreq.gt.mfreqc for ibfint.eq.0',nfreq,mfreqc) if(ntrans.gt.32767) * call quit(' Too many transitions to define ITRLIN as INTEGER*2', * ntrans,ntrans) nncdw=0 do ibft=1,ntranc itr=itrbf(ibft) icdw=mcdw(itr) if(icdw.ge.1) nncdw=nncdw+1 end do if(nncdw.gt.mmcdw) & call quit(' Too many pseudo-continua',nncdw,mmcdw) c C ----------------------------------------------------------- C read the input model C ----------------------------------------------------------- C IF(.NOT.LTGREY) THEN CALL INPMOD IF(ICHANG.NE.0) CALL CHANGE END IF C CALL LINSET(0,0,0,0,0.d0,0.d0,0.d0) C C ----------------------------------------------------------- C There is no additional input for ODF transitions (i.e. ABS(MODE)=3) C from standard input; all information is taken from corresponding C input files (subroutine ODFSET) C C Input parameters for ODF lines or for iron line sampling C ----------------------------------------------------------- C DOPSTD=SQRT(TWO*BOLK*TEFF/HMASS+VTB*VTB) IF(NHOD.GT.0) CALL ODFHYS(DOPSTD) IF(ISPODF.EQ.0) THEN CALL ODFSET ELSE IF(ISPODF.GE.1) THEN CALL IROSET END IF C C ----------------------------------------------------------- C select explicit continuum frequencies C ----------------------------------------------------------- C c IF(NFREAD.GT.0.AND.ISPODF.EQ.0.and.ioptab.eq.0) CALL INIFRC(1) IF(NFREAD.GT.0.AND.ISPODF.GE.0) CALL INIFRC(1) C CALL TRAINI C c C -------------------------------------------------------- c Interpolate the opacity table to current frequencies C -------------------------------------------------------- c if(ioptab.ne.0) then call tabint call rayini do ij=1,nfreqc ijx(ij)=1 end do end if C C ----------------------------------------------------------- C sorting frequencies & new weights C ----------------------------------------------------------- C DO IJ=NFREQC+1,NFREQ IJX(IJ)=1 END DO if(ioptab.ge.0) then CALL SRTFRQ else do ij=1,nfreq ijfr(ij)=ij jik(ij)=ij end do end if C C ----------------------------------------------------------- C other frequency-dependent quantities C ----------------------------------------------------------- C if(ifryb.gt.0.or.nfrecl.ge.nfreq) then do ij=1,nfreq ijali(ij)=0 ijfr(ij)=ij end do end if c CALL CORRWM C do ij=1,nfreq if(icompt.eq.0) then sigec(ij)=sige else c c first-order expression c if(knish.eq.0) then SIGEC(IJ)=SIGE*(un-two*freq(ij)*xcon) c C Use full Klein-Nishina cross section c (Rybicki & Lightman 1975): c else xf=xcon*freq(ij) if(xf.lt.1.d-1) then SIGEC(IJ)=SIGE*(1.-xf*(2.-xf*(26./5.-xf*(13.3 * -xf*(1144./35.-xf*(544./7.-xf*(3784./21. * -xf*(6148./15.-xf*(151552./165. * -xf*111872./55.))))))))) else if(xf.gt.1.d3) then SIGEC(IJ)=SIGE*3./8./xf*(log(2.*xf)+0.5) else SIGEC(IJ)=SIGE*0.75*((1.+xf)/xf**3*(2.*xf*(1.+xf)/ * (1.+2.*xf)-log(1.+2.*xf)) * +0.5*log(1.+2.*xf)/xf * -(1.+3.*xf)/(1.+2.*xf)**2) endif endif endif end do c CALL RTEANG C C ----------------------------------------------------------- C print out some important transition parameters C ----------------------------------------------------------- C if(iptran.gt.0) then WRITE(6,607) NTRANS c cone=3.28805e15*6.6256e-27/109678.758 cone=3.2880869e15*6.6256e-27/109678.758 DO IT=1,NTRANS IF(FR0(IT).GT.0.) THEN ALAM=2.997925D18/FR0(IT) ELSE ALAM=0. END IF if(indexp(it).ne.0) then ii=ilow(it) io=iel(ii) n1=nfirst(io)-1 WRITE(6,608) IT,ILOW(IT),IUP(IT), * typion(io),ii-n1,iup(it)-n1, * INDEXP(IT),ICOL(IT), * IFR0(IT),IFR1(IT),OSC0(IT),FR0(IT),ALAM itr=it if(ioptab.gt.0.and.line(itr)) then jj=iup(itr) iaa=numat(iatm(ii)) atn=float(iaa)+(float(iz(io))-un)*0.01 gf=log10(osc0(itr)*g(ii)) eel=-(enion(ii)-enion(n1+1))/cone xl=(g(ii)-1.)/2. eeu=-(enion(jj)-enion(n1+1))/cone xu=(g(jj)-1.)/2. wlam=alam if(wlam.gt.2000.) then ALM=1.E8/(alam*alam) xn1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM) wlam=alam/(xn1*1.d-6+un) end if write(66,666) alam,wlam,atn,gf,eel,xl,eeu,xu 666 format(2f11.3,f7.2,f7.3,f12.3,f6.1,f12.3,f6.1) end if end if END DO end if C C -------------------------------------------------------- C Evaluation of the photoionization cross-sections in both C explicit and fixed-option continuum transitions C C array CROSS(transition,frequency) C -------------------------------------------------------- C NFREQB=NFREQ IF(IBFINT.GT.0) NFREQB=NFREQC if(lasv) call sigave DO 220 ITR=1,NTRANS IF(LINE(ITR).OR.INDEXP(ITR).EQ.0) GO TO 220 IC=ITRCON(ITR) if(ibf(ic).gt.49.and.ibf(ic).lt.100) go to 220 ISIK=0 MODW=IABS(INDEXP(ITR)) IF(MODW.EQ.5 .OR. MODW.EQ.15) ISIK=1 DO IJ=1,NFREQB FR=FREQ(IJ) IF(ISPODF.GE.1) FR=FREQ(IFREQB(IJ)) CS=SIGK(FR,ITR,ISIK) BFCS(IC,IJ)=real(CS) IF(FR.LT.FR0PC(ITR)) BFCS(IC,IJ)=0. IF(IFWOP(ILOW(ITR)).LT.0) BFCS(IC,IJ)=1.E-30 END DO 220 CONTINUE C call rdatax(-1,ic,0) c call gomini C C ----------------------------------------- C Input parameters for additional opacities C ----------------------------------------- C IF(IOPADD.GT.0) THEN C C procedure OPADD0 now sets up array CROSS that C contain relevant cross-sections C DO IJ=1,NFREQB CALL OPADD0(IJ) END DO END IF C IF(IOPHL1.NE.0 .OR. IOPHL2.NE.0) then if(ielh.le.0) * CALL QUIT('ielh.le.0 for iophl1.gt.0',ielh,iophl1) CALL OPAHST end if if(iophe1.gt.0.and.ielhe1.le.0) * CALL QUIT('iophe1.gt.0.and.ielhe1.le.0',iophe1,ielhe1) if(iophe2.gt.0.and.ielhe2.le.0) * CALL QUIT('iophe2.gt.0.and.ielhe2.le.0',iophe2,ielhe2) if(iphe2c.gt.0.and.ielhe2.le.0) * CALL QUIT('iophe2c.gt.0.and.ielhe2.le.0',iophe2c,ielhe2) C C -------------------------------------------------------------------- C Parameters specifying the overall organization and structure of the C global matrices of complete linearization C -------------------------------------------------------------------- C if(hmix0.gt.0..and.iconv.eq.0) iconv=1 IF(HMIX0.GT.0.and.inpc.gt.0.and.inse.gt.0) THEN INDL = 3 INPC = 4 INSE = 5 INZD = 0 END IF c if(ifryb.gt.0) then inhe=0 inre=1 indl=0 inpc=0 inmp=0 inse=0 inzd=0 do ij=1,nfreq ijali(ij)=0 end do end if c nn=nfreqe if(inhe.gt.0) nn=nn+1 if(inre.gt.0) nn=nn+1 if(inpc.gt.0) nn=nn+1 if(inmp.gt.0) nn=nn+1 if(indl.gt.0) nn=nn+1 if(inzd.gt.0) nn=nn+1 nngg=nn if(inse.gt.0) nn=nn+NLVEXP LCHMAT=.FALSE. c C change LCHC and IRSPLT in case that INPC=0 C IF(INPC.EQ.0) THEN IRSPLT=1 LCHC=.TRUE. END IF C C -------------------------------------------------------------------- C Acceleration parameters C -------------------------------------------------------------------- C C if ITEK > 0, full iteration after Ng accelerations C < 0, only first ITEK iterations are full iterations; C KANT=0 - signifies a full complete linearization iteration; C KANT=1 - a Kantorovich iteration C DO IKT=1,NITER KANT(IKT)=0 END DO IF(ORELAX.EQ.0.) ORELAX=UN IACC0=IACC-3 LAC2=.FALSE. LRES2=.TRUE. IF(ITEK.GT.0) THEN DO IKT=ITEK+1,NITER KANT(IKT)=1 END DO DO IKT=IACC,18,IACD KANT(IKT)=0 END DO ELSE IF(ITEK.LT.0) THEN ITEK=ABS(ITEK) DO IKT=ITEK+1,NITER KANT(IKT)=1 END DO END IF C IF(KSNG.EQ.0) THEN DO I=1,NN LSNG(I)=.TRUE. END DO ELSE DO I=1,NN LSNG(I)=.FALSE. END DO END IF IF(KSNG.EQ.1) THEN DO I=1,NFREQE LSNG(I)=.TRUE. END DO IF(INSE.GT.0) THEN DO ION=1,NION N0=NFIRST(ION) N0G=NNGG+ABS(IIEXP(N0)) LSNG(N0G)=.TRUE. NKE=NNEXT(ION) NKG=NNGG+ABS(IIEXP(NKE)) LSNG(NKG)=.TRUE. END DO END IF END IF IF(INHE.GT.0) LSNG(NFREQE+INHE)=.TRUE. IF(INRE.GT.0) LSNG(NFREQE+INRE)=.TRUE. IF(INPC.GT.0) LSNG(NFREQE+INPC)=.TRUE. IF(INMP.GT.0) LSNG(NFREQE+INMP)=.TRUE. IF(INDL.GT.0) LSNG(NFREQE+INDL)=.TRUE. C C ------------------------------------ C Wind-blanketing parameters - albedos; or irradiation intensity C ------------------------------------ C IF(IWINBL.EQ.1) THEN READ(IBUFF,*) (ALBE(I),I=1,NFREQ) ELSE IF(IWINBL.EQ.2) THEN READ(IBUFF,*) (ALBE(I),I=1,NFREQ) ELSE IF(IWINBL.EQ.3) THEN READ(IBUFF,*) ALCON0,ALCHE2,ALLIN0 DO IJ=1,NFREQC ALBE(IJ)=ALCON0 IF(FREQ(IJ).GT.1.315D16) ALBE(IJ)=ALCHE2 END DO DO IJ=NFREQC+1,NFREQ ALBE(IJ)=ALLIN0 END DO READ(IBUFF,*) NUMMOD IF(NUMMOD.GT.0) THEN DO I=1,NUMMOD READ(IBUFF,*) IJ1,IJ2,ALB DO IJ=IJ1,IJ2 ALBE(IJ)=ALB END DO END DO END IF END IF C C ------------------------------------ C External irradiation intensity C ------------------------------------ C if(wdil.le.0..and.adist.gt.0.) * wdil=4.*(rstar/adist)**2 EXTOT=0. IF(TRAD.EQ.0) THEN DO IJ=1,NFREQ EXTRAD(IJ)=0. END DO ELSE IF(TRAD.GT.0) THEN DO IJ=1,NFREQ EXTRAD(IJ)=BNUE(IJ)/(EXP(HK*FREQ(IJ)/TRAD)-UN)*WDIL EXTOT=EXTOT+W(IJ)*EXTRAD(IJ) END DO ELSE open(48,file='stellarspectrum.dat',status='old') nfreq0=-ifix(real(trad)) DO IJ=NFREQ0,1,-1 read(48,*) fst(ij), EXTRD0(IJ) end do close(48) call interp(fst,extrd0,freq,extrad,nfreq0,nfreq,2,0,0) DO IJ=1,NFREQ EXTRAD(IJ)=EXTRAD(IJ)*WDIL EXTOT=EXTOT+W(IJ)*EXTRAD(IJ) END DO END IF DO IJ=1,NFREQ DO IMU=1,NMU EXTINT(IJ,IMU)=EXTRAD(IJ) END DO HEXTRD(IJ)=HALF*EXTRAD(IJ) END DO TSTAR=TRAD EXTOT=EXTOT/SIG4P/4. EXTOT0=WDIL*TRAD*TRAD*TRAD*TRAD write(6,496) extot0,extot 496 format(/' EXTERNAL IRRADIATION - EXTOT0, EXTOT: ',1p2e12.3/) C if(nd.gt.mdepth) CALL QUIT('nd.gt.mdepth',nd,mdepth) if(nfreq.gt.mfreq) CALL QUIT('nfreq.gt.mfreq',nfreq,mfreq) if(nfreqe.gt.mfrex) CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex) if(nlevel.gt.mlevel) CALL QUIT('nlevel.gt.mlevel',nlevel,mlevel) if(ntrans.gt.mtrans) CALL QUIT('ntrans.gt.mtrans',ntrans,mtrans) if(natom.gt.matom) CALL QUIT('natom.gt.matom',natom,matom) if(nion.gt.mion) CALL QUIT('nion.gt.mion',nion,mion) if(nn.gt.mtot) CALL QUIT('nn.gt.mtot',nn,mtot) if(nlambd.gt.mlambd) CALL QUIT('nlambd.gt.mlambd',nlambd,mlambd) if(nhod.gt.mhod) CALL QUIT('nhod.gt.mhod',nhod,mhod) if(ntrans.gt.32767) * call quit(' Too many transitions to define ITRLIN as INTEGER*2', * ntrans,ntrans) C C ----------------------------------------------------------- C calculate the input LTE-grey model, if needed C ----------------------------------------------------------- C IF(LTGREY.AND.IDISK.EQ.0) CALL LTEGR IF(LTGREY.AND.IDISK.GT.0) CALL LTEGRD C CALL NSTOUT CALL DMDER C C 601 FORMAT(1H1,'*******************************'// * ' M O D E L A T M O S P H E R E'// * ' *******************************'// * ' TEFF =',F10.0/' LOG G =',F10.2/) c 602 FORMAT(1H0//' YTOT =',F11.5/ c * ' WMY =',1PD15.5/' WMM =',D15.5/) 602 FORMAT(' YTOT WMY WMM ',F11.5,1P2D15.5) 603 FORMAT(1H0//' EXPLICIT IONS INCLUDED'/ * ' ----------------------'// * ' NO. ION N0 N1 NK IZ IUPSUM ICUP FF'/) 604 FORMAT(1H ,I3,2X,A4,6I6,1PD15.3) 605 FORMAT(1H0//' EXPLICIT ENERGY LEVELS INCLUDED'/ * ' -------------------------------'// * ' NO. LEVEL ION ION.FREQ.(s^-1) G NQ', * ' IEL ILK IAT IMOD ILT IIE IIF'/) 606 FORMAT(1H ,I4,1X,A10,A4,1PD15.7,0PF10.2,8I5) 607 FORMAT(1H0//' TRANSITION PARAMETERS (TOTAL OF',I6,' )'/ * ' ---------------------'// * ' ITR ILOW IUP',14x,' INDEXP ICOL IFR0 IFR1 OSC', * ' FR0',8X,' LAMBDA'/) 608 FORMAT(1H ,I6,2I5,a6,2i4,2i5,2I7,1P2D12.3,0PF12.3) c 609 FORMAT(1H0//' FREQUENCY POINTS AND WEIGHTS - EXPLICIT'/ c * ' ---------------------------------------'// c * ' IJ ',7X,'FREQ',13X,'WEIGHT',11X,'PROF'/) c 610 FORMAT(1H ,I7,1P2D17.8,D15.5,I5,D17.8) C RETURN END C C C ************************************************************************ C C C SUBROUTINE RDATA(ION) C ===================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' COMMON/STRPAR/IMER,ITR,IC,IL,IP,NLASTE,NHOD,LASV COMMON/INUNIT/IUNIT common/imodlc/imodl0(mlevel) PARAMETER (T15=1.D-15) CHARACTER*1 A CHARACTER(len=100) :: DUM c ihydp0=0 IUNIT=21 OPEN(IUNIT,FILE=FIDATA(ION),STATUS='OLD') C C read the first record - a label for the energy level input C READ(IUNIT,501) A 501 FORMAT(A1) C C ----------------------------------------------------- C input parameters for explicit energy levels C ----------------------------------------------------- C DO IL=1,NLEVS(ION) I=IL+NFIRST(ION)-1 IE=IEL(I) N0I=NFIRST(IE) NKI=NNEXT(IE) IQ=I-N0I+1 X=IQ*IQ READ(IUNIT,*) * ENION(I),G(I),NQUANT(I),TYPLEV(I),ifwop(i),FRODF(I),IMODL(I) if(ifwop(i).lt.0.and.i.ne.nlast(ie)) * CALL QUIT('ifwop(i).lt.0.and.i.ne.nlast(ie)',i,nlast(ie)) imodl0(i)=imodl(i) E=ABS(ENION(I)) E0=E IF(E.EQ.0.) E0=EH*IZ(IE)*IZ(IE)/X IF(E.GT.1.D-7.AND.E.LT.100.) E0=1.6018D-12*E IF(E.GT.100..AND.E.LT.1.D7) E0=1.9857D-16*E IF(E.GT.1.D7) E0=H*E IF(ENION(I).GE.0.) THEN ENION(I)=E0 ELSE ENION(I)=-E0 END IF IF(G(I).EQ.0.) G(I)=2.D0*X IF(NQUANT(I).EQ.0) NQUANT(I)=IQ iltlev(i)=0 if(nquant(i).lt.0) then iltlev(i)=1 nquant(i)=iabs(nquant(i)) end if if(ispodf.eq.0 .and. ifwop(i).ge.2) ifwop(i)=0 if(ifwop(i).lt.0) then enion(i)=0. IMER=IMER+1 IMRG(I)=IMER IIMER(IMER)=I endif LBPFX = LBPFX .AND. IMODL(I).EQ.0 .AND. IIFIX(IATM(I)).EQ.0 if(imodl(i).gt.100) then iguide(i)=imodl(i)-100+NFIRST(ION)-1 imodl(i)=6 end if END DO c C ---------------------------------------------------------------------- C C skip lines if more levels than needed, and skip the continuum C transition label C 5 READ(IUNIT,501) A IF(A.NE.'*') GO TO 5 II0=NFIRST(ION)-1 ILLIM=NLLIM(ION)+II0 JCORR=0 JJCX=0 C C ----------------------------------------------------- C input parameters for continuum transitions C ----------------------------------------------------- C 10 CONTINUE READ(IUNIT,'(A100)',END=19) DUM READ(DUM,*,IOSTAT=KSTAT) II,JJ,MODE, * IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM,NCOL IF (KSTAT.NE.0) THEN READ(DUM,*,ERR=15) II,JJ,MODE, * IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM NCOL=0 END IF IFFR0=0 IF(IABS(MODE).GT.100) THEN IF(MODE.GT.0) MODE=MODE-100 IF(MODE.LT.0) MODE=MODE+100 IFFR0=1 READ(IUNIT,*) FR0INP IF(FR0INP.LT.1.E10) FR0INP=2.997925D18/FR0INP END IF ITR=ITR+1 C IF(JJ.LT.1000) THEN IF(II.EQ.1 .OR. JJCX.EQ.1) JCORR=NLEVS(ION)+1-JJ II=II+II0 JJ=JJ+II0+JCORR ELSE II=II+II0 JJCX=1 END IF ILOW(ITR)=II IUP(ITR)=JJ INDEXP(ITR)=MODE OSC0(ITR)=OSC ICOL(ITR)=ICOLIS CPAR(ITR)=CPARAM LALI(ITR)=.FALSE. LEXP(ITR)=.FALSE. FR0PCI=0. IF(IABS(MODE).EQ.5 .OR. IABS(MODE).EQ.15) THEN READ(IUNIT,*) FR0PCI if(ion.eq.ielh) then if(ii.eq.1.and.cutlym.ne.0) fr0pci=cutlym if(ii.eq.2.and.cutbal.ne.0) fr0pci=cutbal end if IF(FR0PCI.LT.1.E10) FR0PCI=2.997925D18/FR0PCI END IF FR0PC(ITR)=FR0PCI INDEXP(ITR)=MODE IC=IC+1 NTRANC=IC if(ifancy.eq.15) then ibf(ic)=ifancy itrbf(ic)=itr call rdatax(itr,ic,IUNIT) go to 10 end if IF(ITRA(II,JJ).EQ.0) THEN ITRA(II,JJ)=ITR ELSE ICOL(ITR)=99 END IF IE=IEL(II) N0I=NFIRST(IE) NKI=NNEXT(IE) LINE(ITR)=.FALSE. IFC0(ITR)=IFRQ0 IFC1(ITR)=IFRQ1 FR0(ITR)=(ENION(II)-ENION(JJ)+ENION(NKI))/H IF(IFFR0.EQ.1) FR0(ITR)=FR0INP C C ----------------------------------------------------- C Additional input parameters for continuum transitions C ----------------------------------------------------- C C Only for IFANCY = 2, 3, or 4 C S0, ALF, BET, GAM - parameters for evaluation the C photoionization cross-section C NTRANC=IC IF(IFANCY.GE.2.AND.IFANCY.LE.4) THEN READ(IUNIT,*) S0CS(IC),ALFCS(IC),BETCS(IC),GAMCS(IC) ELSE IF(IFANCY.EQ.6) THEN READ(IUNIT,*) (CTOP(IFIT,IC),IFIT=1,6) END IF C C ----------------------------------------------------- C Additional input parameters for continuum transitions -TOPBASE DATA C ----------------------------------------------------- C C Only for IFANCY > 100 there are IFANCY-100 fit points C C XTOP(MFIT,MCROSS) - x = alog10(nu/nu0) of a fit point C CTOP(MFIT,MCROSS) - sigma = alog10(sigma/10^-18) of a fit point C C there are IFANCY-100 fit points C IF(IFANCY.GT.100) THEN NFIT=IFANCY-100 IF(NFIT.GT.MFIT) CALL QUIT('nfit.gt.mfit',nfit,mfit) READ(IUNIT,*) (XTOP(IFIT,IC),IFIT=1,NFIT) READ(IUNIT,*) (CTOP(IFIT,IC),IFIT=1,NFIT) END IF C C ----------------------------------------------- C Additional input parameters for continuum transitions -COLLISIONAL DATA C ---------------------------------------------- IF (NCOL.NE.0) THEN DUM1=0 DO IIC=1,NCOL READ(IUNIT,*) ITYPE, NCTEMP IF (ITYPE.GT.MXTCOL) CALL QUIT('itype.gt.mxtcol',ITYPE,MXTCOL) READ(IUNIT,*) (CTEMP(ITYPE,IFIT,ITR),IFIT=1,NCTEMP) READ(IUNIT,*) (CRATE(ITYPE,IFIT,ITR),IFIT=1,NCTEMP) DUM1=DUM1+2**(ITYPE-1) idum1=ifix(real(dum1)) END DO IF (ICOL(ITR).EQ.99) GO TO 10 IF (MOD(DUM1,TWO).EQ.1.and.ICOL(ITR).lt.10) THEN c IN ORDER TO KEEP THE INFO FOR ELECTRON COLLISIONS FROM ICOL ICOL(ITR)=1000*iDUM1 ELSE IF (ICOL(ITR).LT.0) THEN ICOL(ITR)=-1000*iDUM1+ICOL(ITR)-1 ELSE ICOL(ITR)=1000*iDUM1+ICOL(ITR)+1 ENDIF END IF c END IF C IBF(IC)=IFANCY if(ifancy.gt.49.and.ifancy.lt.100) lasv=.true. ITRA(JJ,II)=IC ITRBF(IC)=ITR ITRCON(ITR)=IC IF(FR0(ITR).GT.0.) THEN ALAM=2.997925D18/FR0(ITR) ELSE ALAM=0. END IF C if(icolis.eq.0.and.ifancy.le.1.and.osc.eq.0.) then zz=iz(iel(ii)) xq=nquant(ii) if(fr0(itr).gt.0..and.xq.gt.0.) * sig0=2.815d-20*zz*zz/(fr0(itr)*1.d-16)**3/xq**5 if(zz.gt.1.9) sig0=sig0*2. if(zz.gt.2.9) sig0=sig0*1.5 osc0(itr)=sig0 end if C IF(II.LT.NLAST(ION)) GO TO 10 15 READ(IUNIT,501,end=19,err=19) A IF(A.NE.'*') GO TO 15 C C ----------------------------------------------------------- C Input parameters for line transitions C ----------------------------------------------------------- C 19 CONTINUE IIP=0 JJP=0 20 CONTINUE READ(IUNIT,'(A100)',END=30) DUM READ(DUM,*,IOSTAT=KSTAT) II,JJ,MODE,IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM,NCOL IF (KSTAT.NE.0) THEN READ(DUM,*,END=30,ERR=30) II,JJ,MODE,IFANCY, * ICOLIS,IFRQ0,IFRQ1,OSC,CPARAM NCOL=0 END IF IF(ISPODF.GE.1) THEN INDXPA=IABS(MODE) LIJP=II.EQ.IIP .AND. JJ.EQ.JJP LOD34=INDXPA.EQ.3 .OR. INDXPA.EQ.4 IF(LIJP .AND. LOD34) THEN IF (NCOL.NE.0) GO TO 29 GO TO 20 ENDIF IIP=II JJP=JJ END IF IFFR0=0 IF(IABS(MODE).GT.100) THEN IF(MODE.GT.0) MODE=MODE-100 IF(MODE.LT.0) MODE=MODE+100 IFFR0=1 READ(IUNIT,*) FR0INP IF(FR0INP.LT.1.E10) FR0INP=2.997925D18/FR0INP END IF IF(JJ.GT.NLEVS(ION)) THEN IF(IABS(MODE).EQ.2) THEN READ(IUNIT,*) K1,K2,K3,X1,X2,X3,K4 IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF IF(IABS(MODE).EQ.1) READ(IUNIT,*) LCMP IF(IABS(IFANCY).EQ.1) READ(IUNIT,*) GAMRL IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF ITR=ITR+1 II=II+II0 JJ=JJ+II0 ILOW(ITR)=II IUP(ITR)=JJ INDEXP(ITR)=MODE OSC0(ITR)=OSC ICOL(ITR)=ICOLIS CPAR(ITR)=CPARAM LALI(ITR)=.FALSE. LEXP(ITR)=.FALSE. IFC0(ITR)=IFRQ0 IFC1(ITR)=IFRQ1 ITRCON(ITR)=0 IF(ITRA(II,JJ).EQ.0) THEN ITRA(II,JJ)=ITR ELSE ICOL(ITR)=99 END IF IE=IEL(II) N0I=NFIRST(IE) NKI=NNEXT(IE) LINE(ITR)=.TRUE. IFR0(ITR)=IFRQ0 IFR1(ITR)=IFRQ1 FR0(ITR)=(ENION(II)-ENION(JJ))/H IF(IFFR0.EQ.1) FR0(ITR)=FR0INP c write(6,632) itr,ilow(itr),iup(itr),ifr0(itr),ifr1(itr) c 632 format(' itr ',5i8) IF(OSC.EQ.0..and.nquant(ii).le.20.and.nquant(jj).le.20) THEN IF(MODE.NE.3.AND.MODE.NE.4) THEN GH=2.D0*NQUANT(II)*NQUANT(II) OSC0(ITR)=OSH(NQUANT(II),NQUANT(JJ))*G(II)/GH ENDIF IF(ifwop(jj).lt.0) THEN OSC0(ITR)=0. JJ0=NQUANT(JJ-1) J20=MIN(20,NLMX) IF(J20.GE.JJ0) THEN DO JTR=JJ0,J20 OSC0(ITR)=OSC0(ITR)+OSH(NQUANT(II),JTR) END DO END IF IF(NLMX.GT.20) THEN XII=NQUANT(II)*NQUANT(II) SUF=0. DO JTR=21,NLMX XJ=JTR XJJ=XJ*XJ XJTR=XJ/(XJJ-XII) SUF=SUF+XJTR*XJTR*XJTR END DO XITR=(400.-XII)/20. OSC0(ITR)=OSC0(ITR)+OSH(NQUANT(II),20)*SUF*XITR*XITR*XITR END IF END IF END IF C IF(FR0(ITR).GT.0.) THEN ALAM=2.997925D18/FR0(ITR) ELSE ALAM=0. END IF IF(MODE.EQ.0) THEN IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF IF(IABS(MODE).EQ.2) GO TO 25 C C change the status of treatment of superlines, C if specified in the "offset-setting" record, or C because of too loo or too high frequency C IF(IABS(MODE).EQ.3.OR.IABS(MODE).EQ.4) THEN IF(II.LT.ILLIM.OR.FR0(ITR).LE.FRLMIN.OR. * FR0(ITR).GE.FRLMAX) INDEXP(ITR)=0 IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF C C ----------------------------------------------------------- C Additional input parameters for "clasical" line transitions C (i.e. those not represented by ODF's - ie ABS(MODE)=1) C ----------------------------------------------------------- C C LCOMP - mode of considering absorption profile: C = false - depth-independent profile C = true - depth-dependent profile C INTMOD - mode of evaluating frequency points in the line C = 0 - means that frequency points and weights have C already been read amongst the NJREAD or NFREAD C frequencies; C ne 0 - frequency points and weights will be evaluated: C the meaning of the individual values: C = 1 - equidistant frequencies, trapezoidal integration C = 2 - equidistant frequencies, Simpson integration C = 3 - modified Simpson integration C 3-point Simpson integrations with each subsequent C integration interval doubled, until the whole C integration area is covered C = 4 - frequencies (in units of standard x) and weights C (for integration over x) are read; C C NF - number of frequency points in the line C (has the meaning only for INTMOD ne 0) C C XMAX = 0 - program sets up default XMAX=4.55 C > 0 - means that the line is assumed symmetric around the C center, frequency points are set up between x=0 and C x=XMAX, where x is frequency difference from the C line center in units of the standard Doppler width C (standard Doppler width is the Doppler width C calculated with standard temperature TSTD and C standard turbulent velocity VTB); C < 0 - frequency points are set between x=XMAX and x=-XMAX C C IMPORTANT NOTE: all lines are C set by default to the full-profile mode. Thefore, if XMAX was C positive, it is reset to XMAX --> -XMAX, and NF --> 2*NF - 1 C C TSTD > 0 - standard temperature (see above); C = 0 - the program assigns for the standard temperature the C default value TSTD = 0.75*TEFF C READ(IUNIT,*) LCOMP(ITR),INTMOD(ITR),NF,XMAX,TSTD IPROF(ITR)=IFANCY IF(IABS(IPROF(ITR)).EQ.1) THEN IP=IP+1 if(ip.gt.mvoigt) CALL QUIT('ip.gt.mvoigt',ip,mvoigt) ITRA(JJ,II)=IP END IF if(ion.eq.ielh) then if(ihydpr.eq.1) then if(nquant(ii).le.4.and.nquant(jj).lt.20) iprof(itr)=3 else if(ihydpr.eq.2) then if(nquant(ii).le.2.and.nquant(jj).le.10) iprof(itr)=4 end if if(iprof(itr).eq.3) ihydp0=1 if(iprof(itr).eq.4) ihydp0=2 end if C C if Voigt profile is assumed (ie. if IPROF = 1), an additional C input record is required which specifies an evaluation of the C relevant damping parameter - see procedure DOPGAM) C C GAMR - for > 0 - has the meaning of natural damping C parameter (=Einstein coefficient for C spontaneous emission) C = 0 - classical natural damping assumed C < 0 - damping is given by a non-standard, C user supplied procedure GAMSP C STARK1 - = 0 - Stark broadening neglected C < 0 - scaled classical expression C (ie gam = -STARK1 * classical Stark) C > 0 - Stark broadening given by C n(el)*[STARK1*T**STARK2 + STARK3] C STARK2, STARK3 - see above C VDWH - .le.0 - Van der Waals broadening neglected C > 0 - scaled classical expression C IF(IABS(IPROF(ITR)).EQ.1) THEN READ(IUNIT,*) GAMAR(IP),STARK1(IP),STARK2(IP),STARK3(IP), * VDWH(IP) IF(GAMAR(IP).GT.0..AND.GAMAR(IP).LT.10.) * GAMAR(IP)=EXP(2.3025851*GAMAR(IP)) IF(STARK1(IP).LT.0.) STARK1(IP)=EXP(2.3025851*STARK1(IP)) END IF c c set the profile coefficient for lines to IPROF=1 (Voigt) profile c if it was not set before, and for IOPTAB=1 c IF(IOPTAB.GT.0.AND.IPROF(ITR).EQ.1) THEN if(nf.lt.25) nf=25 if(xmax.lt.4000.) xmax=4000. END IF C IF(IOPTAB.GT.0.AND.IPROF(ITR).EQ.0.AND.ION.NE.IELH) THEN IPROF(ITR)=1 IP=IP+1 if(ip.gt.mvoigt) CALL QUIT('ip.gt.mvoigt',ip,mvoigt) ITRA(JJ,II)=IP GAMAR(IP)=0. STARK1(IP)=0. VDWH(IP)=1. LCOMP=.TRUE. INTMOD(ITR)=3 if(ii.eq.ii0+1) then if(nf.lt.25) nf=25 if(xmax.lt.4000.) xmax=4000. else if(ii.le.ii0+3) then if(nf.lt.21) nf=21 if(xmax.lt.1000.) xmax=2000. else if(ii.le.ii0+5) then if(nf.lt.17) nf=17 if(xmax.lt.300.) xmax=600. else if(ii.le.ii0+10) then if(nf.lt.13) nf=13 if(xmax.lt.100.) xmax=200. else if(nf.lt.9) nf=9 if(xmax.lt.30.) xmax=60. end if END IF C C change the status of treatment of lines, in virtue of: C a) too low frequency (FRLMIN); or C b) if specified in the "offset-setting" record C IF(II.LT.ILLIM.OR.FR0(ITR).LE.FRLMIN.OR.FR0(ITR).GE.FRLMAX) THEN INDEXP(ITR)=0 IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF C IF(TSTD.EQ.0.) TSTD=0.75*TEFF IF(XMAX.EQ.0.) XMAX=4.55 if(xmax.gt.0.) then xmax=-xmax nf=2*nf-1 end if CALL DOPGAM(ITR,1,TSTD,DOP,AGAM) INTM=INTMOD(ITR) IF(INTM.NE.0) IFR0(ITR)=NLASTE+1 IF(INTM.NE.0) IFR1(ITR)=NLASTE+NF IF(INTM.NE.0) NLASTE=IFR1(ITR) CALL LINSET(ITR,IUNIT,IFRQ0,IFRQ1,XMAX,DOP,AGAM) c write(6,631) itr,ilow(itr),iup(itr),ifr0(itr),ifr1(itr), c * 2.997925e18/freq(ifr0(itr)),2.997925e18/freq(ifr1(itr)) c 631 format(i6,2i5,2i7,2f10.1) IF (NCOL.NE.0) GO TO 29 GO TO 20 C C ----------------------------------------------------------- C Additional input parameters for a "merged superline" transition C (i.e. transition to a merged level, treated by means of an ODF C - i.e. for ABS(MODE)=2) C ----------------------------------------------------------- C C KDO(1),KDO(2),KDO(3),XDO(1),XDO(2),XDO(3),KDO(4) - C have the following meaning: C The superline is represented by four frequency intervals. C Going away from the peak of ODF, the first interval is c represented by a KDO(1)-point Simpson integration, with a C distance XDO(1) fiducial Doppler widths between the points. C The same for the second and third interval. C The rest (the interval between the last point and the C coresponding edge) is represented by a KDO(4)-point C Simpson integration. C The fiducial Doppler width is that corresponding to the C effective temperature and the standard turbulent velocity. C 25 NHOD=NHOD+1 if(ifwop(jj).ge.0) CALL QUIT('ifwop(jj).ge.0',ifwop(jj),jj) READ(IUNIT,*) (KDO(IHI,NHOD),IHI=1,3),(XDO(IHI,NHOD),IHI=1,3), * KDO(4,NHOD) C C again, change status of treatment of lines if required C IF(II.LT.ILLIM.OR.FR0(ITR).LE.FRLMIN.OR.FR0(ITR).GE.FRLMAX) THEN INDEXP(ITR)=0 IF (NCOL.NE.0) GO TO 29 GO TO 20 END IF JNDODF(ITR)=NHOD C ---------------------------------------------- C Additional input parameters for spectral lines - COLLISIONAL DATA C ---------------------------------------------- 29 CONTINUE IF (NCOL.NE.0) THEN DUM1=0 DO IIC=1,NCOL READ(IUNIT,*) ITYPE, NCTEMP IF (ITYPE.GT.MXTCOL) CALL QUIT('itype.gt.mxtcol',ITYPE,MXTCOL) READ(IUNIT,*) (CTEMP(ITYPE,IFIT,ITR),IFIT=1,NCTEMP) READ(IUNIT,*) (CRATE(ITYPE,IFIT,ITR),IFIT=1,NCTEMP) DUM1=DUM1+2**(ITYPE-1) idum1=ifix(real(dum1)) END DO IF (MOD(DUM1,TWO).EQ.1) THEN ICOL(ITR)=1000*iDUM1 ELSE IF (ICOL(ITR).LT.0) THEN ICOL(ITR)=-1000*iDUM1+ICOL(ITR)-1 ELSE ICOL(ITR)=1000*iDUM1+ICOL(ITR)+1 ENDIF ENDIF ENDIF IF(II.LT.NLAST(ION)) GO TO 20 30 CONTINUE C C ----------------------------------------------------------- C Additional input parameters for iron-peak superlevels: C Energy bands (only read in sampling mode!) C ----------------------------------------------------------- C IF(ISPODF.EQ.1 .AND. INODF1(ION).GT.0) THEN READ(IUNIT,*,ERR=50,END=50) NEVKU(ION) DO I=1,NEVKU(ION) READ(IUNIT,*,ERR=50,END=50) XEV(I,ION) END DO READ(IUNIT,*,ERR=50,END=50) NODKU(ION) DO I=1,NODKU(ION) READ(IUNIT,*,ERR=50,END=50) XOD(I,ION) END DO IF(NEVKU(ION).GT.MLEVEL) * CALL QUIT('NEVKU(ION).GT.MLEVEL',NEVKU(ION),MLEVEL) IF(NODKU(ION).GT.MLEVEL) * CALL QUIT('NODKU(ION).GT.MLEVEL',NODKU(ION),MLEVEL) END IF C CLOSE(IUNIT) if(itr.gt.mtrans) CALL QUIT('ntrans.gt.mtrans',itr,mtrans) c c initialization of Lemke hydrogen line broadening tables, if needed c if(ion.eq.ielh) then if(ihydp0.eq.1) ihydpr=21 if(ihydpr.eq.2) ihydpr=22 if(ihydp0.gt.0) then call lemini call xenini end if end if c RETURN 50 CALL QUIT(' Missing data for iron superlevels',0,0) END c c C ***************************************************************** c C SUBROUTINE NSTPAR(FINSTD) C ========================== C C setting up the default values of various input flags, and C input of non-standard values of various input flags and parameters C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 common/freqcl/frmin,frmax,nfrecl common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal common/hediff/hcmass,radstr common/irwint/iirwin common/deridt/dert common/icnrsp/iconrs common/imucnn/imucon common/ichndm/ichanm common/ipricr/iprcrs,nprcrs common/temlim/tfloor common/derdif/dift,difp common/adiaba/grdad0,itgrad common/ifpzpa/ifpzev common/moldat/moltab,irwtab C PARAMETER(MVAR=236) PARAMETER(INPFI=4) CHARACTER*(*) FINSTD CHARACTER*6 PVALUE(MVAR) CHARACTER*80 TEXT CHARACTER VARNAM(MVAR)*6 CHARACTER*20 BLNK CHARACTER*6 BLNK6 C DATA VARNAM /'ISPLIN','IRTE ','IBC ','ILMCOR','ILPSCT', * 'ILASCT','DJMAX ','NTRALI','IPSLTE','IOPTAB', * 'IFMOL ','IFENTR','NFRECL','IFRYB ','IFRAYL', * 'HCMASS','RADSTR','BERGFC','IHYDPR','IIRWIN', * 'ICOMPT','IZSCAL','IBCHE ','IVISC ','ALPHAV', * 'ZETA0 ','ZETA1 ','FRACTV','DMVISC','REYNUM', * 'IFZ0 ','IHESO6','ICOLHN', * 'IFALI ','IFPOPR','JALI ','IFRALI','IFALIH', * 'IFPREC','IELCOR','ICHC ','IRSPLT','IATREF', * 'MODREF','IACPP ','IACDP ','IFLEV ','IDLTE ', * 'POPZER','POPZR2','POPZCH','NITZER','RADZER', * 'IFDIEL','IFCHTR','SHFAC ', * 'QTLAS ','ITLUCY','IACLT ','IACLDT','IFMOFF', * 'IOVER ','ITLAS ','NITER ','NLAMBD','IFRSET', * 'ND ','JIDS ','IDMFIX','ITNDRE', * 'NMU ','IOSCOR', * 'NELSC ','IHECOR','IBFINT','IRDER ', * 'CHMAX ','ILDER ','IBPOPE','CHMAXT','NLAMT ', * 'INTRPL','ICHANG','IFIXMO','IFIXDE', * 'INHE ','INRE ','INPC ','INZD ','INSE ', * 'INMP ','INDL ','NDRE ','TAUDIV','IDLST ', * 'NRETC ','ICONV ','IPRESS','ITEMP ', * 'ITMCOR','ICONRE','IDEEPC','NDCGAP','CRFLIM', * 'IOPHMI','IOPH2P','IOPHEM','IOPCH ','IOPOH ', * 'IOPH2M','IOH2H2','IOH2HE','IOH2H ','IOHHE ', * 'IOPLYM', * 'IOPOLD','IRWTAB','MOLTAB', * 'IRSCT ','IRSCH2','IRSCHE','KEEPOP', * 'IQUASI','NUNALP','NUNBET','TQMPRF', * 'IACC ','IACD ','KSNG ','ITEK ','ORELAX', * 'IWINBL','ICOMGR', * 'ICRSW ','SWPFAC','SWPLIM','SWPINC', * 'TAUFIR','TAULAS','ABROS0','TSURF ','ALBAVE', * 'DION0 ','NDGREY','IDGREY','NCONIT','IPRING', * 'DM1 ','ABPLA0','ABPMIN','ITGMAX','NNEWD ', * 'IHM ','IH2 ','IH2P ','IFTENE', * 'TRAD ','WDIL ', * 'TDISK ','TFLOOR','TMOLIM', * 'HMIX0 ','MLTYPE','VTB ','IPTURB','ILGDER', * 'XGRAD ','STRL1 ','STRL2 ','STRLX ', * 'FRCMAX','FRCMIN','FRLMAX','FRLMIN','CFRMAX', * 'DFTAIL','NFTAIL','TSNU ','VTNU ','DDNU ', * 'IELNU ','CNU1 ','CNU2 ','ISPODF', * 'DPSILG','DPSILT','DPSILN','DPSILD', * 'ICOMST','ICOMDE','ICOMBC','ICOMVE','ICOMRT', * 'ICMDRA','KNISH ','FRLCOM','ICHCOO', * 'NCFOR1','NCFOR2','NCCOUP','NCITOT','NCFULL', * 'IFPRD ','XPDIV ','IFPZEV', * 'IPRINI','IDCONZ','INTENS', * 'ICOOLP','IPRIND','IPRINP','ICHCKP','IPOPAC', * 'ILBC ','IUBC ','DERT ','ICONRS','IMUCON', * 'IFPRAD','ICHANM','CUTLYM','CUTBAL','IHXENB', * 'IHGOM ','HGLIM ','IPRCRS','NPRCRS','FRTLIM', * 'DIFT ','DIFP ','GRDAD0','ITGRAD', * 'IPRYBH','IPELCH','IPELDO','IPCONF'/ C DATA PVALUE /' 0',' 0',' 3',' 3',' 1', * ' 0',' 1.D-3',' 3',' 0',' 0', * ' 0',' 1',' 0',' 0',' 1', * ' 0.',' 0.',' 1.',' 0',' 1', * ' 0',' 0',' 1',' 0',' 0.1', * ' 0.0',' 0.0',' -1',' 0.01',' 0.', * ' 9',' 0',' 0', * ' 5',' 4',' 1',' 0',' 0', * ' 1',' -1',' 1',' 1',' 1', * ' 1',' 7',' 4',' 0',' 1000', * '1.D-20','1.D-20','1.D-15',' 1','1.D-20', * ' 0',' 0',' 0.', * ' 1.D30',' 0',' 7',' 4',' 0', * ' 1',' 100',' 30',' 2',' 0', * ' 70',' 0',' 1',' 1', * ' 3',' 0', * ' 0',' 0',' 1',' 3', * ' 1.D-3',' 0',' 1',' 0.01',' 1', * ' 0',' 0',' 0',' 0', * ' 1',' 2',' 3',' 0',' 4', * ' 0',' 0',' 0',' 0.5',' 5', * ' 0',' 0',' 0',' 0', * ' 0',' 1',' 2',' 2',' 0.7', * ' 1',' 1',' 1',' 1',' 1', * ' 1',' 1',' 1',' 1',' 1', * ' 0', * ' 0',' 1',' 1', * ' 1',' 1',' 1',' 0', * ' 0',' 3',' 0',' 0.', * ' 7',' 4',' 0',' 4',' 1.D0', * ' -1',' 0', * ' 0',' 1.D-1',' 1.D-3',' 3.D0', * ' 1.D-7',' 316.0',' 0.4',' 0.',' 0.', * ' 1.',' 0',' 0',' 0',' 0', * ' 1.D-3',' 3.D-1',' 1.D-5',' 10',' 0', * ' 0',' 0',' 0',' 0', * ' 0.',' 0.', * ' 0.',' 8000.',' 9000.', * ' -1.',' 1',' 0.',' 1',' 0', * ' 0.',' 0.001',' 0.02','1.D-10', * ' 0.',' 1.D12',' 0.',' 1.D13',' 0.', * ' 0.25',' 21',' 0.',' 0.',' 0.75', * ' 0',' 4.5',' 3.',' 0', * ' 10.',' 1.25',' 10.',' 1.25', * ' 1',' 1',' 1',' 0',' 0', * ' 0',' 0','8.2D14',' 1', * ' 0',' 1',' 0',' 1',' 1', * ' 0',' 3.D0',' 0', * ' 0',' 31',' 10', * ' 0',' 0',' 1',' 0',' 0', * ' 0',' 0',' 0.01',' 10',' 10', * ' 1',' 1',' 0.',' 0.',' 0', * ' 0',' 1.D18',' 0',' 0','3.2880', * ' 0.01',' 0.01',' 0.',' 0', * ' 0',' 0',' 0',' 0'/ C DATA BLNK/' '/,BLNK6/' '/ C IF(FINSTD.NE.BLNK) * OPEN(UNIT=INPFI,FILE=FINSTD,STATUS='UNKNOWN') C DO ID=1,MDEPTH CRSW(ID)=UN END DO C INDV=-1 C C go through the input file line by line c write(6,601) 601 format(/' INPUT KEYWORD PARAMETERS:'/ * ' -------------------------') 10 CONTINUE K0=1 READ(INPFI,500,END=70,ERR=70) TEXT 500 FORMAT(A) WRITE(6,*) TEXT 20 CONTINUE CALL GETWRD(TEXT,K0,K1,K2) IF(K1.EQ.0) GO TO 60 K0=K2+2 IF(TEXT(K1:K2).EQ.'=') GO TO 20 INDV=-INDV IF(INDV.EQ.1) THEN DO I=1,MVAR IF(TEXT(K1:K2).EQ.VARNAM(I)(1:K2-K1+1)) GO TO 50 END DO CALL GETWRD(TEXT,K0,K1,K2) IF(K1.EQ.0) THEN K0=1 45 READ(INPFI,500,END=70) TEXT CALL GETWRD(TEXT,K0,K1,K2) IF(K1.EQ.0) GO TO 45 END IF K0=K2+2 INDV=-INDV GO TO 20 50 CONTINUE IVAR=I ELSE PVALUE(IVAR)=BLNK6 PVALUE(IVAR)(6-K2+K1:6)=TEXT(K1:K2) END IF GO TO 20 60 CONTINUE GO TO 10 70 CONTINUE C DO I=1,MVAR WRITE(84,684) PVALUE(I) 684 FORMAT(1X,A) END DO C CLOSE(UNIT=84) REWIND(84) READ(84,*) * ISPLIN,IRTE ,IBC ,ILMCOR,ILPSCT, * ILASCT,DJMAX ,NTRALI,IPSLTE,IOPTAB, * IFMOL ,IFENTR,NFRECL,IFRYB ,IFRAYL, * HCMASS,RADSTR,BERGFC,IHYDPR,IIRWIN, * ICOMPT,IZSCAL,IBCHE ,IVISC ,ALPHAV, * ZETA0 ,ZETA1 ,FRACTV,DMVISC,REYNUM, * IFZ0 ,IHESO6,ICOLHN, * IFALI ,IFPOPR,JALI ,IFRALI,IFALIH, * IFPREC,IELCOR,ICHC ,IRSPLT,IATREF, * MODREF,IACPP ,IACDP ,IFLEV ,IDLTE , * POPZER,POPZR2,POPZCH,NITZER,RADZER, * IFDIEL,IFCHTR,SHFAC , * QTLAS ,ITLUCY,IACLT ,IACLDT,IFMOFF, * IOVER ,ITLAS ,NITER ,NLAMBD,IFRSET, * ND ,JIDS ,IDMFIX,ITNDRE, * NMU ,IOSCOR, * NELSC ,IHECOR,IBFINT,IRDER , * CHMAX ,ILDER ,IBPOPE,CHMAXT,NLAMT , * INTRPL,ICHANG,IFIXMO,IFIXDE, * INHE ,INRE ,INPC ,INZD ,INSE , * INMP ,INDL ,NDRE ,TAUDIV,IDLST , * NRETC ,ICONV ,IPRESS,ITEMP , * ITMCOR,ICONRE,IDEEPC,NDCGAP,CRFLIM, * IOPHMI,IOPH2P,IOPHEM,IOPCH ,IOPOH , * IOPH2M,IOH2H2,IOH2HE,IOH2H ,IOHHE , * IOPLYM, * IOPOLD,IRWTAB,MOLTAB, * IRSCT ,IRSCH2,IRSCHE,KEEPOP, * IQUASI,NUNALP,NUNBET,TQMPRF, * IACC ,IACD ,KSNG ,ITEK ,ORELAX, * IWINBL,ICOMGR, * ICRSW ,SWPFAC,SWPLIM,SWPINC, * TAUFIR,TAULAS,ABROS0,TSURF ,ALBAVE, * DION0 ,NDGREY,IDGREY,NCONIT,IPRING, * DM1 ,ABPLA0,ABPMIN,ITGMAX,NNEWD , * IHM ,IH2 ,IH2P ,IFTENE, * TRAD ,WDIL , * TDISK ,TFLOOR,TMOLIM, * HMIX0 ,MLTYPE,VTB ,IPTURB,ILGDER, * XGRAD ,STRL1 ,STRL2 ,STRLX , * FRCMAX,FRCMIN,FRLMAX,FRLMIN,CFRMAX, * DFTAIL,NFTAIL,TSNU ,VTNU ,DDNU , * IELNU ,CNU1 ,CNU2 ,ISPODF, * DPSILG,DPSILT,DPSILN,DPSILD, * ICOMST,ICOMDE,ICOMBC,ICOMVE,ICOMRT, * ICMDRA,KNISH ,FRLCOM,ICHCOO, * NCFOR1,NCFOR2,NCCOUP,NCITOT,NCFULL, * IFPRD ,XPDIV ,IFPZEV, * IPRINI,IDCONZ,INTENS, * ICOOLP,IPRIND,IPRINP,ICHCKP,IPOPAC, * ILBC ,IUBC ,DERT ,ICONRS,IMUCON, * IFPRAD,ICHANM,CUTLYM,CUTBAL,IHXENB, * IHGOM ,HGLIM ,IPRCRS,NPRCRS,FRTLIM, * DIFT ,DIFP ,GRDAD0,ITGRAD, * IPRYBH,IPELCH,IPELDO,IPCONF C IF(LTGREY) ISPODF=0 IF(LTE) IFLEV=1 IF(IFRYB.GE.1) IDLST=0 LCHC=.FALSE. IF(ICHC.EQ.1) LCHC=.TRUE. NFFIX=IFRALI IF(IACC.LE.4) IACC=7 if(frtlim.lt.1.e6) frtlim=frtlim*1.e15 if(frcmax.lt.1.e6) frcmax=frcmax*1.e15 if(frlmax.lt.1.e6) frlmax=frlmax*1.e15 if(frcmin.lt.1.e6) frcmin=frcmin*1.e13 if(frlmin.lt.1.e6) frlmin=frlmin*1.e13 IF(FRLMAX.EQ.0.) FRLMAX=max(1.D11*CNU1*TEFF,3.288e15) if(idisk.eq.0.and.cfrmax.eq.0.) cfrmax=2. if(trad.ne.0.) iwinbl=-1 if(nitzer.gt.itek) nitzer=itek if(nitzer.gt.iacc-iacd) nitzer=iacc-iacd if(ielhm.gt.0) iophmi=0 if(teff.gt.15000.) then ioph2p=0 iopch=0 iopoh=0 irsch2=0 ioph2m=0 ioh2h2=0 ioh2he=0 ioh2h=0 iohhe=0 end if iopadd=iophmi+ioph2p+iophem+iopch+iopoh iopadd=iopadd+ioph2m+ioh2h2+ioh2he+ioh2h+iohhe iopadd=iopadd+irsct+irsch2+irsche c if(ioptab.lt.0.or.ifmol.gt.0) ielcor=-1 c RRDIL=un IF(IDISK.EQ.0) IFZ0=-1 ITGMX0=ITGMAX DO ITL=1,NITER+1 NITLAM(ITL)=0 END DO IF(NLAMBD.LT.0) THEN NLAMBD=-NLAMBD IF(LTE) NLAMBD=1 DO ITL=1,12 NITLAM(ITL)=NLAMBD END DO DO ITL=13,NITER+1 NITLAM(ITL)=2 END DO ELSE IF(NLAMBD.GT.0) THEN IF(LTE) NLAMBD=1 DO ITL=1,NITER+1 NITLAM(ITL)=NLAMBD END DO END IF IF(ILMCOR.GE.3) ILPSCT=1 C IF(IDISK.EQ.1.AND.INZD.EQ.0.AND.IZSCAL.EQ.0.AND.IVISC.LE.1) THEN if(ifryb.eq.0) then INZD=4 INSE=5 end if END IF C IF(IFIXMO.GT.0) THEN INHE=0 INRE=0 INPC=0 INZD=0 INSE=1 END IF c IF(IFIXDE.GT.0) THEN INHE=1 INRE=0 INPC=2 INZD=0 INSE=3 END IF C if(iprcrs.gt.0) then niter=0 nlambd=1 end if C c initialize the convection parameters c aconml=1./8. bconml=half cconml=16. if(mltype.eq.2) then aconml=1. bconml=2. cconml=16. end if nungam=0 nunbal=0 if(iquasi.gt.0) call getlal c if(nd.gt.mdepth) CALL QUIT('nd.gt.mdepth',nd,mdepth) if(ndgrey.gt.mdepth) CALL QUIT('ndgrey.gt.mdepth',ndgrey,mdepth) if(nlambd.gt.mlambd) CALL QUIT('nlambd.gt.mlambd',nlambd,mlambd) if(iacc.le.2) CALL QUIT('Ng too early',iacc,iacc) if(nmu.gt.mmu) CALL QUIT('nmu.gt.mmu',nmu,mmu) RETURN END C C C *************************************************************** C C SUBROUTINE NSTOUT C ================= C C Diagnostic print of the input flags and parameters c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' C if(lchc) ichc=1 write(6,602) * ISPLIN,IRTE ,IBC ,ILMCOR,ILPSCT, * ILASCT,DJMAX ,NTRALI,IPSLTE, * ICOMPT,IZSCAL,IBCHE ,IVISC , * IFALI ,IFPOPR,JALI ,IFRALI, * IFPREC,IELCOR,ICHC ,IRSPLT,IATREF, * MODREF,IACPP ,IACPD ,IFLEV, IDLTE, * POPZER,POPZR2,RADZER,NITZER,IFDIEL, * IOVER ,ITLAS ,NITER ,NLAMBD,ND, * JIDS ,IDMFIX,NMU , * NELSC ,IHECOR,IBFINT,IRDER , * CHMAX ,ILDER ,IBPOPE,CHMAXT,NLAMT write(6,603) INTRPL,ICHANG, * INHE ,INRE ,INPC ,INSE ,INMP , * INDL ,NDRE ,TAUDIV,IDLST ,NRETC , * ICONV ,IPRESS,ITEMP , * IOPADD,IRSCT ,IOPHMI,IOPH2P, * IACC ,IACD ,KSNG ,ITEK ,ORELAX, * IWINBL, * ICRSW ,SWPFAC,SWPLIM,SWPINC, * IFPRD ,XPDIV write(6,604) TRAD ,WDIL , * HMIX0 ,VTB/1.e5 ,IPTURB, * XGRAD ,STRL1 ,STRL2 ,STRLX , * FRCMAX,FRCMIN,FRLMAX,FRLMIN,CFRMAX, * DFTAIL,NFTAIL,TSNU ,VTNU/1.e5 ,DDNU , * IELNU ,CNU1 ,CNU2 ,ISPODF, * DPSILG,DPSILT,DPSILN,DPSILD write(6,605) ICOMST,ICOMDE,ICOMBC, * ICMDRA,KNISH, * NCFOR1,NCFOR2,NCCOUP,NCITOT,NCFULL IF(LTGREY) WRITE(6,606) * TAUFIR,TAULAS,ABROS0,TSURF ,ALBAVE, * ABPLA0,ABPMIN, * DION0 ,NDGREY,IDGREY,NCONIT,IPRING, * IHM ,IH2 ,IH2P c 602 FORMAT(/' VALUES OF SOME KEYWORD PARAMETERS:'/ * ' =================================='// * 'ISPLIN=',I6,2X,'IRTE =',I6,2X,'IBC =',I6,2X, * 'ILMCOR=',I6,2X,'ILPSCT=',I6,2X/ * 'ILASCT=',I6,2X,'DJMAX =',F6.3,2X,'NTRALI=',I6,2X, * 'IPSLTE=',I6,2X/ * 'ICOMPT=',I6/ * 'IZSCAL=',I6,2X,'IBCHE =',I6,2X,'IVISC =',I6,2X/ * 'IFALI =',I6,2X,'IFPOPR=',I6,2X,'JALI =',I6,2X, * 'IFRALI=',I6,2X/ * 'IFPREC=',I6,2X,'IELCOR=',I6,2X,'ICHC =',I6,2X, * 'IRSPLT=',I6,2X,'IATREF=',I6,2X/ * 'MODREF=',I6,2X,'IACPP =',I6,2X,'IACPD =',I6,2X, * 'IFLEV =',I6,2X,'IDLTE =',I6,2X/ * 'POPZER=',1PE6.0,2X,'POPZR2=',1PE6.0,2X, * 'RADZER=',1PE6.0,2X,'NITZER=',I6,2X,'IFDIEL=',I6,2X/ * 'IOVER =',I6,2X,'ITLAS =',I6,2X/ * 'NITER =',I6,2X,'NLAMBD=',I6,2X,'ND =',I6/ * 'JIDS =',I6,2X,'IDMFIX=',I6/ * 'NMU =',I6/ * 'NELSC =',I6,2X,'IHECOR=',I6,2X,'IBFINT=',I6,2X, * 'IRDER =',I6,2X,'CHMAX =',0PF6.3,2X/ * 'ILDER =',I6,2X,'IBPOPE=',I6,2X, * 'CHMAXT=',F6.3,2X,'NLAMT =',I6,2X) 603 FORMAT('INTRPL=',I6,2X,'ICHANG=',I6,2X/ * 'INHE =',I6,2X,'INRE =',I6,2X,'INPC =',I6,2X, * 'INSE =',I6,2X,'INMP =',I6,2X/ * 'INDL =',I6,2X,'NDRE =',I6,2X,'TAUDIV=',F6.3,2X, * 'IDLST =',I6,2X,'NRETC =',I6,2X/ * 'ICONV =',I6,2X,'IPRESS=',I6,2X,'ITEMP =',I6,2X/ * 'IOPADD=',I6,2X,'IRSCT =',I6,2X,'IOPHMI=',I6,2X, * 'IOPH2P=',I6,2X/ * 'IACC =',I6,2X,'IACD =',I6,2X,'KSNG =',I6,2X, * 'ITEK =',I6,2X,'ORELAX=',F6.3,2X/ * 'IWINBL=',I6,2X/ * 'ICRSW =',I6,2X,'SWPFAC=',F6.3,2X,'SWPLIM=',F6.3,2X, * 'SWPINC=',F6.3,2X/ * 'IFPRD =',I6,2X,'XPDIV =',F6.1/) 604 FORMAT('TRAD =',F6.0,2X,'WDIL =',F5.3/ * 'HMIX0 =',F6.1,2X,'VTB =',F6.0,2X,I6/ * 'XGRAD =',F6.2,2X,'STRL1 =',1PE6.0,2X,'STRL2 =',E6.0/ * 'STRLX =',1PE6.0/ * 'FRCMAX=',1PE6.0,2X,'FRCMIN=',1PE6.0,2X, * 'FRLMAX=',1PE6.0,2X,'FRLMIN=',1PE6.0,/, * 'CFRMAX=',0PF6.2,/ * 'DFTAIL=',0PF6.3,2X,'NFTAIL=',I6,/ * 'TSNU =',F6.0,2X,'VTNU =',F6.2,2X,'DDNU =',F6.3,/ * 'IELNU =',I6,2X,'CNU1 =',F6.2,2X,'CNU2 =',F6.2,/ * 'ISPODF=',I6,/ * 'DPSILG=',F6.2,2X,'DPSILT=',F6.2,2X,'DPSILN=',F6.2,2X, * 'DPSILD=',F6.2,/) 605 FORMAT('ICOMST=',I6,2X,'ICOMDE=',I6,2X,'ICOMBC=',I6/ * 'ICMDRA=',I6,2X,'KNISH =',I6/ * 'NCFOR1=',I6,2X,'NCFOR2=',I6,2X,'NCCOUP=',I6,2X, * 'NCITOT=',I6,2X,'NCFULL=',I6) 606 FORMAT('TAUFIR=',1PE6.0,2X,'TAULAS=',0PF6.1,2X,'ABROS0=',F6.3,2X, * 'TSURF =',F6.3,2X,'ALBAVE=',F6.3/ * 'ABPLAO=',F6.3,2X,'ABPMIN=',1PE6.0/ * 'DION0 =',0PF6.3,2X,'NDGREY=',I6,2X,'IDGREY=',I6,2X, * 'NCONIT=',I6,2X,'IPRING=',I6,2X/ * 'IHM =',I6,2X,'IH2 =',I6,2X,'IH2P =',I6,2X/) C C Outdated options (or options not yet implemented C for distributed processing!) C IF(ISPODF.GE.1) THEN IF(IFPREC.EQ.0) * CALL QUIT('inconsistent ispodf and ipfrec',ispodf,ifprec) END IF C RETURN END C C C **************************************************************** C C 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 I=K0,LEN(TEXT) IF(K1.EQ.0) THEN DO J=1,MSEPAR IF(TEXT(I:I).EQ.SEPAR(J)) GO TO 10 END DO K1=I C C NOT START OF WORD C 10 CONTINUE ELSE DO J=1,MSEPAR IF(TEXT(I:I).EQ.SEPAR(J)) GO TO 20 END DO END IF END DO C C NO NEW WORD. RETURN K1=K2=0 C K1=0 K2=0 GO TO 30 C C NEW WORD IN TEXT(K1:I-1) C 20 CONTINUE K2=I-1 C 30 CONTINUE RETURN END C C C **************************************************************** C C SUBROUTINE STATE(MODE,ID,T,ANE) C =============================== C C For MODE=0 - initialization of the basic parameters for the C chemical species C for MODE=2 - solves the set of LTE Saha equations to determine C the total charge due to ionization of non-explicit C chemical species C for MODE=3 - similar as MODE=2, but also with derivatives wrt C temperature and electron density (called from BPOP, C ie. from the linearization step) C for MODE=1 - similar as MODE=2, but the total charge is evaluated C summing the contributions of both non-explicit and C explicit chemical species (called from LTEGR) C C Input for MODE > 0: C C T - temperature C ANE - electron density C C Output for MODE > 0 (through COMMON/STATEP) C C C Q - total charge, relative to the reference atom C QM - charge of H- (in LTE), evaluated only if H- is not C explicit ion, and if desired (if IHM=1) C DQT - derivative of Q wrt temperature C DQN - derivative of Q wrt electron density C DQM - derivative of QM wrt temperature C ENER - internal energy (of all species in all considered C ionization stages (needed only for evaluating C thermodynamic derivatoves if convection is considerd) C QREF - total charge due to the reference species C DQTR - derivative of QREF wrt temperature C DQNR - derivative of QREF wrt electron density C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' CHARACTER*4 TYPAT,DYP COMMON/PFSTDS/PFSTD(matom,30),MODPF(matom) common/terden/rhoter,anta,entrp DIMENSION TYPAT(matom),ABND(matom),D(3,matom), * abnref(mdepth),DYP(matom), * xio(8,matom), * abun0(matom),abun1(matom) dimension xio2(9,22), xio3(9,13) dimension ffi(matom),pfstu(matom),pfstt(matom),pfstn(matom), * entot(matom) dimension idat(30),uu(30,17) 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) PARAMETER (TH0=5.0404D3,XMX0=2.154D4,THL0=2.3025851,FI0=3.6113D1, * TRHA=1.5D0,c1qm=1.0353d-16,c2qm=8762.9, * ev2erg=1.6018d-12) character*80 dum C 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)) C DATA DYP/' H ',' He ',' Li ',' Be ',' B ',' C ', * ' N ',' O ',' F ',' Ne ',' Na ',' Mg ', * ' Al ',' Si ',' P ',' S ',' Cl ',' Ar ', * ' K ',' Ca ',' Sc ',' Ti ',' V ',' Cr ', * ' Mn ',' Fe ',' Co ',' Ni ',' Cu ',' Zn ', * ' Ga ',' Ge ',' As ',' Se ',' Br ',' Kr ', * ' Rb ',' Sr ',' Y ',' Zr ',' Nb ',' Mo ', * ' Tc ',' Ru ',' Rh ',' Pd ',' Ag ',' Cd ', * ' In ',' Sn ',' Sb ',' Te ',' I ',' Xe ', * ' Cs ',' Ba ',' La ',' Ce ',' Pr ',' Nd ', * ' Pm ',' Sm ',' Eu ',' Gd ',' Tb ',' Dy ', * ' Ho ',' Er ',' Tm ',' Yb ',' Lu ',' Hf ', * ' Ta ',' W ',' Re ',' Os ',' Ir ',' Pt ', * ' Au ',' Hg ',' Tl ',' Pb ',' Bi ',' Po ', * ' At ',' Rn ',' Fr ',' Ra ',' Ac ',' Th ', * ' Pa ',' U ',' Np ',' Pu ',' Am ',' Cm ', * ' Bk ',' Cf ',' Es '/ C C Standard atomic constants for first 99 species C Abundances for the first 30 from Grevesse & Sauval, C (1998, Space Sci. Rev. 85, 161) C C Element Atomic Solar Std. C weight abundance highest C C ionization stage DATA D/ 1.008, 1.0D0, 2., * 4.003, 1.00D-1, 3., * 6.941, 1.26D-11, 3., * 9.012, 2.51D-11, 3., * 10.810, 5.0D-10, 4., * 12.011, 3.31D-4, 5., * 14.007, 8.32D-5, 5., * 16.000, 6.76D-4, 5., * 18.918, 3.16D-8, 4., * 20.179, 1.20D-4, 4., * 22.990, 2.14D-6, 4., * 24.305, 3.80D-5, 4., * 26.982, 2.95D-6, 4., * 28.086, 3.55D-5, 5., * 30.974, 2.82D-7, 5., * 32.060, 2.14D-5, 5., * 35.453, 3.16D-7, 5., * 39.948, 2.52D-6, 5., * 39.098, 1.32D-7, 5., * 40.080, 2.29D-6, 5., * 44.956, 1.48D-9, 5., * 47.900, 1.05D-7, 5., * 50.941, 1.00D-8, 5., * 51.996, 4.68D-7, 5., * 54.938, 2.45D-7, 5., * 55.847, 3.16D-5, 5., * 58.933, 8.32D-8, 5., * 58.700, 1.78D-6, 5., * 63.546, 1.62D-8, 5., * 65.380, 3.98D-8, 5., * 69.72 , 1.34896324e-09 , 3., * 72.60 , 4.26579633e-09 , 3., * 74.92 , 2.34422821e-10 , 3., * 78.96 , 2.23872066e-09 , 3., * 79.91 , 4.26579633e-10 , 3., * 83.80 , 1.69824373e-09 , 3., * 85.48 , 2.51188699e-10 , 3., * 87.63 , 8.51138173e-10 , 3., * 88.91 , 1.65958702e-10 , 3., * 91.22 , 4.07380181e-10 , 3., * 92.91 , 2.51188630e-11 , 3., * 95.95 , 9.12010923e-11 , 3., * 99.00 , 1.00000000e-24 , 3., * 101.1 , 6.60693531e-11 , 3., * 102.9 , 1.23026887e-11 , 3., * 106.4 , 5.01187291e-11 , 3., * 107.9 , 1.73780087e-11 , 3., * 112.4 , 5.75439927e-11 , 3., * 114.8 , 6.60693440e-12 , 3., * 118.7 , 1.38038460e-10 , 3., * 121.8 , 1.09647810e-11 , 3., * 127.6 , 1.73780087e-10 , 3., * 126.9 , 3.23593651e-11 , 3., * 131.3 , 1.69824373e-10 , 3., * 132.9 , 1.31825676e-11 , 3., * 137.4 , 1.62181025e-10 , 3., * 138.9 , 1.58489337e-11 , 3., * 140.1 , 4.07380293e-11 , 3., * 140.9 , 6.02559549e-12 , 3., * 144.3 , 2.95120943e-11 , 3., * 147.0 , 1.00000000e-24 , 3., * 150.4 , 9.33254366e-12 , 3., * 152.0 , 3.46736869e-12 , 3., * 157.3 , 1.17489770e-11 , 3., * 158.9 , 2.13796216e-12 , 3., * 162.5 , 1.41253747e-11 , 3., * 164.9 , 3.16227767e-12 , 3., * 167.3 , 8.91250917e-12 , 3., * 168.9 , 1.34896287e-12 , 3., * 173.0 , 8.91250917e-12 , 3., * 175.0 , 1.31825674e-12 , 3., * 178.5 , 5.37031822e-12 , 3., * 181.0 , 1.34896287e-12 , 3., * 183.9 , 4.78630102e-12 , 3., * 186.3 , 1.86208719e-12 , 3., * 190.2 , 2.39883290e-11 , 3., * 192.2 , 2.34422885e-11 , 3., * 195.1 , 4.78630036e-11 , 3., * 197.0 , 6.76082952e-12 , 3., * 200.6 , 1.23026887e-11 , 3., * 204.4 , 6.60693440e-12 , 3., * 207.2 , 1.12201834e-10 , 3., * 209.0 , 5.12861361e-12 , 3., * 210.0 , 1.00000000e-24 , 3., * 211.0 , 1.00000000e-24 , 3., * 222.0 , 1.00000000e-24 , 3., * 223.0 , 1.00000000e-24 , 3., * 226.1 , 1.00000000e-24 , 3., * 227.1 , 1.00000000e-24 , 3., * 232.0 , 1.20226443e-12 , 3., * 231.0 , 1.00000000e-24 , 3., * 238.0 , 3.23593651e-13 , 3., * 237.0 , 1.00000000e-24 , 3., * 244.0 , 1.00000000e-24 , 3., * 243.0 , 1.00000000e-24 , 3., * 247.0 , 1.00000000e-24 , 3., * 247.0 , 1.00000000e-24 , 3., * 251.0 , 1.00000000e-24 , 3., * 254.0 , 1.00000000e-24 , 3./ c data abun0 / * 12.00,10.93, 1.05, 1.38, 2.70, 8.39, 7.78, 8.66, 4.56, 7.84, * 6.17, 7.53, 6.37, 7.51, 5.36, 7.14, 5.50, 6.18, 5.08, 6.31, * 3.05, 4.90, 4.00, 5.64, 5.39, 7.45, 4.92, 6.23, 4.21, 4.60, * 2.88, 3.58, 2.29, 3.33, 2.56, 3.28, 2.60, 2.92, 2.21, 2.59, * 1.42, 1.92,-9.99, 1.84, 1.12, 1.69, 0.94, 1.77, 1.60, 2.00, * 1.00, 2.19, 1.51, 2.27, 1.07, 2.17, 1.13, 1.58, 0.71, 1.45, * -9.99, 1.01, 0.52, 1.12, 0.28, 1.14, 0.51, 0.93, 0.00, 1.08, * 0.06, 0.88,-0.17, 1.11, 0.23, 1.45, 1.38, 1.64, 1.01, 1.13, * 0.90, 2.00, 0.65,-9.99,-9.99,-9.99,-9.99,-9.99, 9.99, 0.06, * -9.99,-0.52,-9.99,-9.99,-9.99,-9.99,-9.99,-9.99,-9.99/ c data abun1 / * 12.00,10.93, 3.26, 1.38, 2.79, 8.43, 7.83, 8.69, 4.56, 7.93, * 6.24, 7.60, 6.45, 7.51, 5.41, 7.12, 5.50, 6.40, 5.08, 6.34, * 3.15, 4.95, 3.93, 5.64, 5.43, 7.50, 4.99, 6.22, 4.19, 4.56, * 3.04, 3.65, 2.30, 3.34, 2.54, 3.25, 2.36, 2.87, 2.21, 2.58, * 1.46, 1.88,-9.99, 1.75, 1.06, 1.65, 1.20, 1.71, 0.76, 2.04, * 1.01, 2.18, 1.55, 2.24, 1.08, 2.18, 1.10, 1.58, 0.72, 1.42, * -9.99, 0.96, 0.52, 1.07, 0.30, 1.10, 0.48, 0.92, 0.10, 0.92, * 0.10, 0.85,-0.12, 0.65, 0.26, 1.40, 1.38, 1.62, 0.80, 1.17, * 0.77, 2.04, 0.65,-9.99,-9.99,-9.99,-9.99,-9.99,-9.99, 0.06, * -9.99,-0.54,-9.99,-9.99,-9.99,-9.99,-9.99,-9.99,-9.99/ C C C Ionization potentials for first 99 species: DATA XIo/ C C Element Ionization potentials (eV) C I II III IV V VI VII VIII C * 13.595, 0. , 0. , 0. , 0. , 0. , 0. , 0. , * 24.580, 54.400, 0. , 0. , 0. , 0. , 0. , 0. , * 5.392, 75.619,122.451, 0. , 0. , 0. , 0. , 0. , * 9.322, 18.206,153.850,217.713, 0. , 0. , 0. , 0. , * 8.296, 25.149, 37.920,259.298,340.22, 0. , 0. , 0. , * 11.264, 24.376, 47.864, 64.476,391.99,489.98, 0. , 0. , * 14.530, 29.593, 47.426, 77.450, 97.86,551.93,667.03, 0. , * 13.614, 35.108, 54.886, 77.394,113.87,138.08,739.11,871.39, * 17.418, 34.980, 62.646, 87.140,114.21,157.12,185.14,953.6 , * 21.559, 41.070, 63.500, 97.020,126.30,157.91,207.21,239.0 , * 5.138, 47.290, 71.650, 98.880,138.37,172.09,208.44,264.16, * 7.664, 15.030, 80.120,102.290,141.23,186.49,224.9 ,265.96, * 5.984, 18.823, 28.440,119.960,153.77,190.42,241.38,284.53, * 8.151, 16.350, 33.460, 45.140,166.73,205.11,246.41,303.07, * 10.484, 19.720, 30.156, 51.354, 65.01,220.41,263.31,309.26, * 10.357, 23.400, 35.000, 47.290, 72.50, 88.03,280.99,328.8 , * 12.970, 23.800, 39.900, 53.500, 67.80, 96.7 ,114.27,348.3 , * 15.755, 27.620, 40.900, 59.790, 75.00, 91.3 ,124.0 ,143.46, * 4.339, 31.810, 46.000, 60.900, 82.6 , 99.7 ,118.0 ,155.0 , * 6.111, 11.870, 51.210, 67.700, 84.39,109.0 ,128.0 ,147.0 , * 6.560, 12.890, 24.750, 73.900, 92.0 ,111.1 ,138.0 ,158.7 , * 6.830, 13.630, 28.140, 43.240, 99.8 ,120.0 ,140.8 ,168.5 , * 6.740, 14.200, 29.700, 48.000, 65.2 ,128.9 ,151.0 ,173.7 , * 6.763, 16.490, 30.950, 49.600, 73.0 , 90.6 ,161.1 ,184.7 , * 7.432, 15.640, 33.690, 53.000, 76.0 , 97.0 ,119.24,196.46, * 7.870, 16.183, 30.652, 54.800, 75.0 , 99.1 ,125.0 ,151.06, * 7.860, 17.060, 33.490, 51.300, 79.5 ,102.0 ,129.0 ,157.0 , * 7.635, 18.168, 35.170, 54.900, 75.5 ,108.0 ,133.0 ,162.0 , * 7.726, 20.292, 36.830, 55.200, 79.9 ,103.0 ,139.0 ,166.0 , * 9.394, 17.964, 39.722, 59.400, 82.6 ,108.0 ,134.0 ,174.0 , * 6.000, 20.509, 30.700, 99.99,99.99,99.99,99.99,99.99, * 7.89944,15.93462, 34.058, 45.715,99.99,99.99,99.99,99.99, * 9.7887, 18.5892, 28.351, 99.99,99.99,99.99,99.99,99.99, * 9.750,21.500, 32.000, 99.99,99.99,99.99,99.99,99.99, * 11.839,21.600, 35.900, 99.99,99.99,99.99,99.99,99.99, * 13.995,24.559, 36.900, 99.99,99.99,99.99,99.99,99.99, * 4.175,27.500, 40.000, 99.99,99.99,99.99,99.99,99.99, * 5.692,11.026, 43.000, 99.99,99.99,99.99,99.99,99.99, * 6.2171,12.2236, 20.5244,60.607,99.99,99.99,99.99,99.99, * 6.63390,13.13,23.17,34.418,80.348,99.99,99.99,99.99, * 6.879,14.319, 25.039, 99.99,99.99,99.99,99.99,99.99, * 7.099,16.149, 27.149, 99.99,99.99,99.99,99.99,99.99, * 7.280,15.259, 30.000, 99.99,99.99,99.99,99.99,99.99, * 7.364,16.759, 28.460, 99.99,99.99,99.99,99.99,99.99, * 7.460,18.070, 31.049, 99.99,99.99,99.99,99.99,99.99, * 8.329,19.419, 32.920, 99.99,99.99,99.99,99.99,99.99, * 7.574,21.480, 34.819, 99.99,99.99,99.99,99.99,99.99, * 8.990,16.903, 37.470, 99.99,99.99,99.99,99.99,99.99, * 5.784,18.860, 28.029, 99.99,99.99,99.99,99.99,99.99, * 7.342,14.627, 30.490,72.3,99.99,99.99,99.99,99.99, * 8.639,16.500, 25.299,44.2,55.7,99.99,99.99,99.99, * 9.0096,18.600, 27.96, 37.4,58.7,99.99,99.99,99.99, * 10.454,19.090, 32.000, 99.99,99.99,99.99,99.99,99.99, * 12.12984,20.975,31.05,45.,54.14,99.99,99.99,99.99, * 3.893,25.100, 35.000, 99.99,99.99,99.99,99.99,99.99, * 5.210,10.000, 37.000, 99.99,99.99,99.99,99.99,99.99, * 5.580,11.060, 19.169, 99.99,99.99,99.99,99.99,99.99, * 5.650,10.850, 20.080, 99.99,99.99,99.99,99.99,99.99, * 5.419,10.550, 23.200, 99.99,99.99,99.99,99.99,99.99, * 5.490,10.730, 20.000, 99.99,99.99,99.99,99.99,99.99, * 5.550,10.899, 20.000, 99.99,99.99,99.99,99.99,99.99, * 5.629,11.069, 20.000, 99.99,99.99,99.99,99.99,99.99, * 5.680,11.250, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.159,12.100, 20.000, 99.99,99.99,99.99,99.99,99.99, * 5.849,11.519, 20.000, 99.99,99.99,99.99,99.99,99.99, * 5.930,11.670, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.020,11.800, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.099,11.930, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.180,12.050, 23.700, 99.99,99.99,99.99,99.99,99.99, * 6.250,12.170, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.099,13.899, 19.000, 99.99,99.99,99.99,99.99,99.99, * 7.000,14.899, 23.299, 99.99,99.99,99.99,99.99,99.99, * 7.879,16.200, 24.000, 99.99,99.99,99.99,99.99,99.99, * 7.86404,17.700, 25.000, 99.99,99.99,99.99,99.99,99.99, * 7.870,16.600, 26.000, 99.99,99.99,99.99,99.99,99.99, * 8.500,17.000, 27.000, 99.99,99.99,99.99,99.99,99.99, * 9.100,20.000, 28.000, 99.99,99.99,99.99,99.99,99.99, * 8.95868,18.563,33.227, 99.99,99.99,99.99,99.99,99.99, * 9.220,20.500, 30.000, 99.99,99.99,99.99,99.99,99.99, * 10.430,18.750, 34.200, 99.99,99.99,99.99,99.99,99.99, * 6.10829,20.4283,29.852,50.72,99.99,99.99,99.99,99.99, * 7.416684,15.0325,31.9373,42.33,69.,99.99,99.99,99.99, * 7.285519,16.679, 25.563,45.32,56.0,88.,99.99,99.99, * 8.430,19.000, 27.000, 99.99,99.99,99.99,99.99,99.99, * 9.300,20.000, 29.000, 99.99,99.99,99.99,99.99,99.99, * 10.745,20.000, 30.000, 99.99,99.99,99.99,99.99,99.99, * 4.000,22.000, 33.000, 99.99,99.99,99.99,99.99,99.99, * 5.276,10.144, 34.000, 99.99,99.99,99.99,99.99,99.99, * 6.900,12.100, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99, * 6.000,12.000, 20.000, 99.99,99.99,99.99,99.99,99.99/ C c additional ionization potentials c ix x xi xii xiii xiv xv xvi xvii c c energies added for Sc, Ti, V, Cr, Co,Ni, Cy,Zn c source G. C. Rodrigues et al. , c Systematic calculation of total atomic energies of ground state configurations, c Atomic Data and Nuclear Data Tables, Vol. 86, Issue 2, March 2004, P.117-233. data xio2/ * 1103., 0., 0., 0., 0., 0., 0., 0., 0., ! F * 1196., 1362., 0., 0., 0., 0., 0., 0., 0., ! Ne * 300., 1465.,1649., 0., 0., 0., 0., 0., 0., ! Na * 328., 367.,1762.,1963., 0., 0., 0., 0., 0., ! Mg * 330., 398., 442.,2085.,2304., 0., 0., 0., 0., ! Al * 351., 401., 476., 523.,2438.,2673., 0., 0., 0., ! Si * 372., 424., 480., 560., 612.,2816.,3069., 0., 0., ! P * 379., 447., 505., 565., 652., 707.,3223.,3494., 0., ! S * 400., 456., 529., 592., 657., 750., 809.,3658.,3946., ! Cl * 422., 479., 539., 618., 686., 756., 854., 918.,4121., ! Ar * 176., 503., 564., 629., 714., 787., 862., 968.,1034., ! K * 188., 211., 591., 656., 726., 817., 895., 974.,1087., ! Ca * 180., 225., 250., 686., 755., 830., 926.,1010.,1094., ! Sc * 193., 216., 265., 291., 787., 861., 940.,1042.,1132., ! Ti * 206., 230., 255., 308., 336., 896., 974.,1060.,1165., ! V * 209., 244., 271., 298., 355., 384.,1010.,1095.,1185., ! Cr * 222., 248., 286., 314., 344., 404., 435.,1136.,1222., ! Mn * 235., 262., 290., 331., 361., 392., 457., 490.,1266., ! Fe * 186., 276., 305., 336., 379., 411., 444., 512., 547., ! Co * 193., 224., 321., 352., 384., 430., 464., 499., 571., ! Ni * 199., 232., 266., 369., 401., 435., 484., 520., 557., ! Cu * 203., 238., 274., 311., 420., 454., 490., 542., 579./ ! Zn c c even higher ionization potentials c 18 19 20 21 22 23 24 25 26 c data xio3/ * 4426., 0., 0., 0., 0., 0., 0., 0., 0., ! Ar * 4611., 4934., 0., 0., 0., 0., 0., 0., 0., ! K * 1158., 5129.,5470., 0., 0., 0., 0., 0., 0., ! Ca * 1206., 1288.,5675.,6034., 0., 0., 0., 0., 0., ! Sc * 1222., 1346.,1425.,6249., 0., 0., 0., 0., 0., ! Ti * 1261., 1356.,1480.,1569., 0., 0., 0., 0., 0., ! V * 1294., 1397.,1497.,1627., 0., 0., 0., 0., 0., ! Cr * 1318., 1431.,1540.,1645.,1782., 0., 0., 0., 0., ! Mn * 1357., 1459.,1574.,1689.,1799.,1958.,2346.,8828.,9278., ! Fe * 1396., 1496.,1603.,1723.,1847.,1963.,2112., 0., 0., ! Co * 606., 1538.,1643.,1756.,1880.,2011.,2133.,2288., 0., ! Ni * 628., 670.,1688.,1797.,1915.,2043.,2183.,2310.,2472., ! Cu * 616., 693., 737.,1844.,1958.,2082.,2214.,2362.,2494./ ! Zn C C C data for additional ionization potentials for the Opacity C project species (IDAT sets the internal OP indexing) C 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 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(MODE.NE.0) GO TO 50 C C For MODE=0, STATE serves as an auxiliary procedure for START C Input of basic parameters for individual chemical species C C An element (hydrogen through zinc) can be considered in one of C the three following options: C 1. explicitly - some of energy levels of some of its ionization C states are considered explicitly, ie. their C populations are determined by solving statistical C equilibrium C 2. implicitly - the atom is assumed not to contribute to C opacity; but is allowed to contribute to the C total number of particles and to the total charge; C the latter is evaluated assuming LTE ionization C balance, ie. by solving a set of Saha equations C 3. not considered at all C C Input: C NATOMS - the highest atomic number of an element that is C considered (explicitly or non-explicitly) C < 0 - then NATOMS=-NATOMS, and all Opacity Project C species are treated as with MODPF>0, i.e. C their partition functions are evaluated from C the Opacity Project ionization fractions C C For each element from 1 (hydrogen) to NATOMS, the following C parameters: C C MA = 0 - if the element is not considered (option 3) C = 1 - if the element is non-explicit (option 2) C = 2 - if the element is explicit (option 1) C ABN - if ABN=0, solar abundance is assumed (given above; C abundance here is assumed as relative C to hydrogen by number C if ABN>0, non-solar abundance ABN is assumed; in an C arbitrary scale C if ABN<0, non-solar abundance ABN is assumed; C (-ABN times the solar value) C if ABN>1.e6, depth-dpendent abundance (additional input) C iabset=0 read(ibuff,'(a80)') dum read(dum,*,iostat=kstat) natoms,iabset if(kstat.ne.0) READ(dum,*) NATOMS if(natoms.eq.0) then do id=1,nd ytot(id)=1.11 wmy(id)=1.41 wmm(id)=2.17e-24 end do iatref=0 return end if c do i=1,matom iadop(i)=0 if(iabset.eq.1) then d(2,i)=10.**(abun1(i)-12.) else if(iabset.ne.2) then d(2,i)=10.**(abun0(i)-12.) end if end do c WRITE(6,600) IAT=0 IREFA=0 IFOPPF=0 IF(NATOMS.LT.0) THEN NATOMS=-NATOMS IFOPPF=2 END IF C natms=natoms if(ifmol.gt.0) natms=92 DO 20 I=1,NATMS LGR(I)=.TRUE. LRM(I)=.TRUE. IATEX(I)=-1 if(i.le.natoms) then READ(IBUFF,*) MA,ABN,MODPF0 else ma=1 abn=0. modpf0=0 end if c IF(MA.EQ.0) GO TO 20 TYPAT(I)=DYP(I) AMAS(I)=D(1,I) ABND(I)=D(2,I) IF(MA.EQ.0.or.i.gt.natoms) then abnd(i)=d(2,i)*1.e-10 enev(i,1)=xio(1,i) enev(i,2)=xio(2,i) amas(i)=d(1,i) DO ID=1,ND ABNDD(I,ID)=ABND(I) END DO GO TO 20 end if IONIZ(I)=int(D(3,I)) MODPF(I)=MODPF0 C C increase the standard highest ionization for Teff larger C than 50000 K for N, O, Ne, and Fe C IF(TEFF.GT.5.D4) THEN IF(I.EQ.7) IONIZ(I)=6 IF(I.EQ.8) IONIZ(I)=7 IF(I.EQ.10) IONIZ(I)=9 IF(I.EQ.26) IONIZ(I)=9 END IF C DO J=1,8 ENEV(I,J)=xio(J,I) END DO c if(i.ge.9.and.i.le.30) then do j=9,17 enev(i,j)=xio2(j-8,i-8) end do endif if(i.ge.18.and.i.le.30) then do j=18,26 enev(i,j)=xio3(j-17,i-17) end do end if c LGR(I)=.FALSE. IF(MODPF(I).GT.0) IFOPPF=1 IF(IFOPPF.EQ.2.and.idat(i).gt.0) MODPF(I)=1 if(modpf(i).gt.0) then if(idat(i).eq.0) modpf(i)=0 if(modpf(i).gt.0) then ioniz(i)=i+1 if(i.ge.10) then do j=9,i enev(i,j)=uu(j,idat(i))*0.1239529d0 end do end if end if end if IF(ABN.GT.0) ABND(I)=ABN IF(ABN.LT.0) ABND(I)=ABS(ABN)*D(2,I) IF(ION.NE.0) IONIZ(I)=ION IF(ABN.GT.1.E6) THEN READ(IBUFF,*) (ABNDD(I,ID),ID=1,ND) ELSE DO ID=1,ND ABNDD(I,ID)=ABND(I) END DO END IF IF(MA.EQ.1) THEN LRM(I)=.FALSE. IATEX(I)=0 ELSE IAT=IAT+1 IIFIX(IAT)=0 IF(MA.LE.-2) IIFIX(IAT)=1 IATEX(I)=IAT IF(IAT.EQ.IATREF) THEN IREFA=I DO ID=1,ND ABNREF(ID)=ABNDD(I,ID) END DO END IF C C store parameters for explicit atoms C AMASS(IAT)=AMAS(I)*HMASS NUMAT(IAT)=I if(iabs(ma).eq.3) iadop(i)=1 END IF 20 CONTINUE C C renormalize abundances to have the standard element abundance C equal to unity C if(abnref(1).eq.0.or.ioptab.gt.0) then do id=1,nd abnref(id)=1. end do end if c DO 30 I=1,NATOMS IAT=IATEX(I) IF(IAT.LT.0) GO TO 30 DO ID=1,ND ABNDD(I,ID)=ABNDD(I,ID)/ABNREF(ID) YTOT(ID)=YTOT(ID)+ABNDD(I,ID) WMY(ID)=WMY(ID)+ABNDD(I,ID)*AMAS(I) END DO ABNR=ABND(I)/D(2,I) IF(IAT.EQ.0) THEN WRITE(6,601) I,TYPAT(I),ABND(I),ABNR ELSE DO ID=1,ND ABUND(IAT,ID)=ABNDD(I,ID) END DO WRITE(6,602) I,TYPAT(I),ABND(I),ABNR,IAT END IF 30 CONTINUE DO ID=1,ND WMM(ID)=WMY(ID)*HMASS/YTOT(ID) END DO c c initialization of the Opacity Project ionization fractions c (if required) c if(ifoppf.gt.0) call opfrac(0,0,t,ane,pf,fra) c 600 FORMAT(/' '/' CHEMICAL ELEMENTS INCLUDED'/ * ' --------------------------'// * ' NUMBER ELEMENT ABUNDANCE'/1H ,16X, * 'A=N(ELEM)/N(H) A/A(SOLAR)'/) 601 FORMAT(1H ,I4,3X,A5,1P2E14.2) 602 FORMAT(1H ,I4,3X,A5,1P2E14.2,3X, * 'EXPLICIT: IAT=',I3) RETURN C 50 TLN=LOG(T)*TRHA TK=BOLK*T TKLN15=TRHA*LOG(TK) ENTCON=103.973 THET=TH0/T THL=THL0*THET XMX=XMX0*SQRT(SQRT(T/ANE)) DCH=EH/(XMX*XMX*TK) Q=0. QM=0. DQT=0. DQN=0. DQM=0. ENER=0. ENTR=0. hpop=dens(id)/wmm(id)/ytot(id) DO 70 I=1,NATOMS IF(MODE.GT.1.AND.LRM(I).OR.MODE.EQ.1.AND.LGR(I)) GO TO 70 ION=IONIZ(I) DRQT=0. DRQN=0. DRST=0. DRSN=0. DFT=0. DFN=0. ENTOT(1)=0. RS=UN CALL PARTF(I,1,T,ANE,XMX,UM,DUTM,DUNM) if(i.eq.1) pfhyd=max(um,two) pfstu(1)=um pfstt(1)=dutm pfstn(1)=dunm JMAX=1 DO J=2,ION J1=J-1 DCHT=DCH*J1 TE=ENEV(I,J1)*THL ENTOT(J)=ENTOT(J1)+TE dcht=0. FI=FI0+TLN-TE+DCHT X=J XMAX=XMX*SQRT(X) CALL PARTF(I,J,T,ANE,XMAX,U,DUT,DUN) pfstu(j)=u pfstt(j)=dut pfstn(j)=dun FFI(J)=0. IF(FI.GT.-20.) FFI(J)=EXP(FI)*U/UM/ANE IF(FFI(J).GT.UN) JMAX=J UM=U END DO RQ=JMAX-1 RI=ENTOT(JMAX) RE=PFSTT(JMAX)/PFSTU(JMAX)*T if(jmax.lt.ion) then R=UN DO J=JMAX+1,ION J1=J-1 DCHT=DCH*J1 TE=ENEV(I,J1)*THL R=R*FFI(J) c RR(I,J)=R/pfstu(j) RR(I,J)=R RS=RS+R RQ=RQ+J1*R RI=RI+R*ENTOT(J) RE=RE+R*PFSTT(J)/PFSTU(J)*T DFIT=pfstt(j)/pfstu(j)-pfstt(j1)/pfstu(j1) . +(TRHA+TE-TRHA*DCHT)/T DFIN=pfstn(j)/pfstu(j)-pfstn(j1)/pfstu(j1) . +(HALF*DCHT-UN)/ANE DFT=DFT+DFIT DFN=DFN+DFIN DFIT=DFT*R DFIN=DFN*R DRST=DRST+DFIT DRSN=DRSN+DFIN DRQT=DRQT+J1*DFIT DRQN=DRQN+J1*DFIN END DO end if if(jmax.gt.1) then R=UN DFT=0. DFN=0. jmin=min(4,jmax-1) DO JJ=1,JMIN J=JMAX-JJ J1=J-1 JP1=J+1 DCHT=DCH*J TE=ENEV(I,J)*THL R=R/FFI(JP1) C RR(I,J)=R/pfstu(j) RR(I,J)=R RS=RS+R RQ=RQ+J1*R RI=RI+R*ENTOT(J) RE=RE+R*PFSTT(J)/PFSTU(J)*T DFIT=pfstt(jp1)/pfstu(jp1)-pfstt(j)/pfstu(j) * +(TRHA+TE-TRHA*DCHT)/T DFIN=pfstn(jp1)/pfstu(jp1)-pfstn(j)/pfstu(j) * +(HALF*DCHT-UN)/ANE DFT=DFT-DFIT DFN=DFN-DFIN DFIT=DFT*R DFIN=DFN*R DRST=DRST+DFIT DRSN=DRSN+DFIN DRQT=DRQT+J1*DFIT DRQN=DRQN+J1*DFIN END DO endif X=RQ/RS ABND(I)=ABNDD(I,ID) X1=ABND(I)/RS RR(I,JMAX)=X1 DO J=1,ION IF(J.NE.JMAX) RR(I,J)=RR(I,J)*X1 END DO c RR(I,JMAX)=RR(I,JMAX)/PFSTU(JMAX) c c internal energy and entropy (per 1 hydrogen atom) c chip=0 c antm=(anta-ane)/ytot(id) c do j=1,ion do j=1,2 dulog=0. c aden=rr(i,j)*antm if(aden.lt.1.e-20) aden=1.e-20 if(pfstu(j).lt.un) pfstu(j)=un if(pfstt(j).gt.0.) dulog=pfstt(j)*t/pfstu(j) ener=ener+(chip*ev2erg+tk*dulog)*aden entr=entr+(tkln15-log(aden)+log(pfstu(j))+ * trha*log(amas(i))+dulog+entcon)*aden c entr=entr+(tkln15+log(pfstu(j))+ c * trha*log(amas(i))+dulog+entcon)*aden chip=chip+enev(i,j) end do c aref=dens(id)/wmm(id)/ytot(id) c rr(i,99)=0. if(irefa.eq.0) irefa=1 IF(I.EQ.IREFA) THEN QREF=X*ABND(I) c DQTR=(DRQT-X*DRST)*X1 c DQNR=(DRQN-X*DRSN)*X1 ELSE Q=X*ABND(I)+Q c DQT=DQT+(DRQT-X*DRST)*X1 c DQN=DQN+(DRQN-X*DRSN)*X1 END IF do j=2,ion rr(i,99)=rr(i,99)+rr(i,j)*aref end do 70 CONTINUE c c c entropy of electrons c c entel=tkln15-log(ane)+1.5*log(emass(99))+entcon entel=tkln15-log(ane)-11.2622+entcon entr=entr+entel*ane C C Negative hydrogen ion C c IF(IHM.EQ.1) THEN tinv=un/t QM=C1QM*Tinv/SQRT(T)*EXP(C2QM*Tinv) DQM=-QM*Tinv*(TRHA+C2QM*Tinv) c END IF RETURN END c c c ************************************************** c c 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 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, scale DEPTH replaces DM; C i.e. DEPTH will be used as DM, regardless of which C values of DM were read in subroutine START C > 0 - polynomial interpolation of the (INTRPL-1)th order C C < 0 - reads different initial models (eg. -1 : Kurucz model) C C If INTRPL > 0, there is an additional input from unit 8, namely C new depth scale DM, the one which will be used in the present run C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (MINPUT=MLEVEL+5, * MDEPTI=MDEPTH) common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) COMMON POPUL0(MLEVEL,MDEPTI),ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * TEMP0(MDEPTI),ELEC0(MDEPTI),DENS0(MDEPTI),PPL0(MDEPTI), * DEPTH(MDEPTI),PPL(MDEPTH),POPLTE(MLEVEL),X(MINPUT), * ZD0(MDEPTH) dimension a(mlevel,mlevel),b(mlevel),iifor0(mlevel) C LCHC0=LCHC LCHC=.TRUE. LTE0=LTE LTE=.TRUE. NUMLT=3 IF(IDISK.EQ.1) NUMLT=4 IF(IFMOL.GT.0) NUMLT=NUMLT+1 RRDIL=1. TEMPBD=0. IF(INTRPL.GE.0) THEN READ(8,*) NDPTH,NUMPAR ND=NDPTH IF(NDPTH.LE.0) CALL QUIT('NDPTH.LE.0 in Unit 8',ndpth,0) IF(NDPTH.GT.MDEPTI) * CALL QUIT('NDPTH.GT.MDEPTI in Unit 8',ndpth,mdepti) READ(8,*) (DM(ID),ID=1,ND) IDSTD=0 NUMP=ABS(NUMPAR) DO ID=1,NDPTH READ(8,*) (X(I),I=1,NUMP) do i=1,nump if(x(i).lt.0.) x(i)=0. end do TEMP(ID)=X(1) ELEC(ID)=X(2) DENS(ID)=X(3) TOTN(ID)=DENS(ID)/WMM(ID)+ELEC(ID) IP=3 IF(NUMPAR.LT.0) THEN IP=IP+1 TOTN(ID)=X(IP) END IF IF(IDISK.EQ.1) THEN IP=IP+1 ZD(ID)=X(IP) END IF IF(TEMP(ID).LT.TEFF) IDSTD=ID c IF(NUMP.GT.IP.AND..NOT.LTE0.AND.ICHANG.NE.-2) THEN 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,enrg,entt,wm,ipri) end if IF(NUMP.GT.IP) THEN NLEV0=NUMP-IP DO I=1,NLEV0 POPUL(I,ID)=X(NUMLT+I) END DO ELSE NLEV0=NLEVEL CALL WNSTOR(ID) CALL SABOLF(ID) DO I=1,NLEV0 IIFOR0(I)=I END DO CALL RATMAT(ID,IIFOR0,-1,A,B) CALL LEVSOL(A,B,POPLTE,IIFOR0,NLEV0,1) DO I=1,NLEV0 POPUL(I,ID)=POPLTE(I) END DO if(ifmol.le.0.or.t.ge.tmolim) then if(n0hn.gt.0) then anato(1,id)=popul(n0hn,id) else anato(1,id)=dens(id)/wmm(id)/ytot(id) end if if(iathe.gt.0) then anato(2,id)=popul(n0a(iathe),id) else anato(2,id)=dens(id)/wmm(id)/ytot(id)*abndd(2,id) end if end if c END IF END DO ELSTD=ELEC(IDSTD) READ(8,*,END=10,ERR=10) INTRPL ELSE IF(INTRPL.GT.-10) THEN CALL KURUCZ(NDPTH) NUMPAR=3 IF(ND.NE.NDPTH .AND. INTRPL.EQ.0) * CALL QUIT('ND.NE.NDPTH in KURUCZ',nd,ndpth) ELSE CALL INCLDY(NDPTH) NUMPAR=3 IF(ND.NE.NDPTH .AND. INTRPL.EQ.0) * CALL QUIT('ND.NE.NDPTH in INCLDY',nd,ndpth) END IF 10 LCHC=LCHC0 LTE=LTE0 C IF(IDISK.EQ.1) THEN ZND=ZD(ND) IF(ZND.GT.0.) IFZ0=-1 END IF c c !!!!! attention - temporary fix c if(idisk.eq.1) zd(nd)=0. C c if(ioptab.ge.0) return IF(IOPTAB.LT.0) RETURN do id=1,nd ptotal(id)=dm(id)*grav an=ptotal(id)/(bolk*temp(id)) elec(id)=1.e-16*an wmm(id)=dens(id)/an end do RETURN END C C C **************************************************************** C C SUBROUTINE KURUCZ(NDPTH) C ======================== C C Read an initial model atmosphere from unit 8 C in Kurucz ATLAS' format C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (MINPUT=7) CHARACTER KUR*15 DIMENSION KKFIX0(MLEVEL) COMMON POPUL0(MLEVEL,MDEPTH),ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),PPL0(MDEPTH), * DEPTH(MDEPTH),PPL(MDEPTH),POPLTE(MLEVEL),X(MINPUT) common/temlim/tfloor dimension a(mlevel,mlevel),b(mlevel),iifor0(mlevel) C do iat=1,natom kkfix0(iat)=iifix(iat) iifix(iat)=0 end do nlev0=nlevel LCHC0=LCHC LCHC=.TRUE. LTE0=LTE LTE=.TRUE. C if(ifixde.gt.0) then READ(8,551) TEF,GRAV WRITE(6,600) TEF,GRAV READ(8,552) ND ND=ND-1 c write(6,553) nd 551 FORMAT(4X,F8.0,9X,F8.5) 552 FORMAT(/////////////////////10X,I3/) c 553 format(' nd',i4) C 600 FORMAT(1H1,' INPUT KURUCZ MODEL FOR TEFF=',F7.0,' LOG G =', * F7.2//1H ,7X,'MASS',9X,'T',9X,'P',9X,'DENS',9X,'ELEC'//) DO ID=1,ND READ(8,*) DM(ID),TEMP(ID),P,ane0,a1,a2,a3,vel,rho if(temp(id).lt.tfloor) temp(id)=tfloor CALL RHONEN(ID,TEMP(ID),RHO,AN,ANE) c ELEC(ID)=ANE0 ELEC(ID)=ANE DENS(ID)=RHO TOTN(ID)=DENS(ID)/WMM(ID)+ELEC(ID) an=rho/wmm(id)+ane0 rho0=WMM(ID)*(AN-ELEC(ID)) WRITE(6,651) ID,DM(ID),TEMP(ID),P,DENS(ID),ELEC(ID),rho0,an CALL WNSTOR(ID) CALL SABOLF(ID) DO I=1,NLEV0 IIFOR0(I)=I END DO CALL RATMAT(ID,IIFOR0,-1,A,B) CALL LEVSOL(A,B,POPLTE,IIFOR0,NLEV0,1) DO I=1,NLEV0 POPUL(I,ID)=POPLTE(I) END DO end do c write(6,553) nd go to 100 end if 651 FORMAT(1H ,I5,1PE10.3,0PF10.1,1P5D12.3) c READ(8,801) KUR,GRAVK READ(KUR,802) TEFFK 801 FORMAT(A15,6X,F8.5) 802 FORMAT(4X,F8.0) C IF(KUR(1:4).NE.'TEFF') * CALL QUIT(' Unit 8 is NOT a Kurucz model as expected',0,0) IF(ABS(TEFFK-TEFF).GT.50.) then ieff=int(teff) ieffk=int(teffk) c CALL QUIT(' Teff not corresponding to Kurucz model',ieff,ieffk) END IF IF(ABS(GRAVK-LOG10(GRAV)).GT.0.02) then irav=int(log10(grav)+0.001) iravk=int(gravk) c CALL QUIT(' Gravity not corresponding to Kurucz model', c * irav,iravk) END IF C DO WHILE(KUR(1:9).NE.'READ DECK') READ(8,'(A15)') KUR END DO READ(KUR,803) NDPTH 803 FORMAT(10X,I3) NDPTH=NDPTH-1 NUMPAR=3 NLEV0=NLEVEL READ(8,*) TTT IF(NDPTH.gt.mdepth.and.intrpl.eq.0) * CALL QUIT('ndpth.gt.mdepth in KURUCZ',ndpth,mdepth) DO ID=1,NDPTH READ(8,*) (X(I),I=1,MINPUT) DEPTH(ID)=X(1) TEMP0(ID)=X(2) ELEC0(ID)=X(4) AN=X(3)/BOLK/TEMP0(ID) DENS0(ID)=WMM(ID)*(AN-ELEC0(ID)) TEMP(ID)=TEMP0(ID) ELEC(ID)=ELEC0(ID) DENS(ID)=DENS0(ID) ANMA(ID)=DENS(ID)/WMM(ID) ANTO(ID)=ANMA(ID)+ELEC(ID) TOTN(ID)=ANTO(ID) T=TEMP(ID) IF(IFMOL.GT.0.AND.T.LT.TMOLIM) THEN AN=TOTN(ID) AEIN=ELEC(ID) CALL MOLEQ(ID,T,AN,AEIN,ANE,ENR,ENT,WM,1) END IF CALL WNSTOR(ID) CALL SABOLF(ID) DO I=1,NLEV0 IIFOR0(I)=I END DO CALL RATMAT(ID,IIFOR0,-1,A,B) CALL LEVSOL(A,B,POPLTE,IIFOR0,NLEV0,1) DO I=1,NLEV0 POPUL0(I,ID)=POPLTE(I) END DO END DO C INTRPL=0 DO WHILE(KUR(1:5).NE.'BEGIN') READ(8,'(A15)',END=100,ERR=100) KUR END DO READ(8,*,END=100,ERR=100) INTRPL C 100 do iat=1,natom iifix(iat)=kkfix0(iat) end do LCHC=LCHC0 LTE=LTE0 C RETURN END C C C **************************************************************** C C SUBROUTINE INCLDY(NDPTH) C ======================== C C Read an initial model atmosphere from unit 8 C in Cloudy's format as provided by Katya Verner C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (MINPUT=6) DIMENSION RS(MDEPTH),KKFIX0(MLEVEL) COMMON POPUL0(MLEVEL,MDEPTH),ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),PPL0(MDEPTH), * DEPTH(MDEPTH),PPL(MDEPTH),POPLTE(MLEVEL),X(MINPUT) dimension a(mlevel,mlevel),b(mlevel),iifor0(mlevel) C do iat=1,natom kkfix0(iat)=iifix(iat) iifix(iat)=0 end do C READ(8,*) NDPTH NUMPAR=3 IF(NDPTH.gt.mdepth.and.intrpl.eq.0) * CALL QUIT('ndpth.gt.mdepth in INCLDY',ndpth,mdepth) NLEV0=NLEVEL READ(8,*) TSTARY,RSTARY IF(RSTARY.LT.1.E6) RSTARY=RSTARY*6.96E10 C DO ID=NDPTH,1,-1 READ(8,*) (X(I),I=1,MINPUT) RS(ID)=X(1) TEMP0(ID)=X(2) ELEC0(ID)=X(4) AN=X(3)/BOLK/TEMP0(ID) DENS0(ID)=WMM(ID)*X(3) TEMP(ID)=TEMP0(ID) ELEC(ID)=ELEC0(ID) DENS(ID)=DENS0(ID) ANMA(ID)=DENS(ID)/WMM(ID) ANTO(ID)=ANMA(ID)+ELEC(ID) END DO DM(1)=0. DEPTH(1)=0. DO ID=2,NDPTH DDDM=(DENS(ID-1)+DENS(ID))*(RS(ID-1)-RS(ID)) DM(ID)=DM(ID-1)+0.5*DDDM DEPTH(ID)=DM(ID) END DO C RRDIL=(RSTARY/RS(NDPTH))*(RSTARY/RS(NDPTH)) TEMPBD=TSTARY C DO ID=1,NDPTH CALL WNSTOR(ID) CALL SABOLF(ID) DO I=1,NLEV0 IIFOR0(I)=I END DO CALL RATMAT(ID,IIFOR0,-1,A,B) CALL LEVSOL(A,B,POPLTE,IIFOR0,NLEV0,1) DO I=1,NLEV0 POPUL0(I,ID)=POPLTE(I) END DO END DO C INTRPL=0 do iat=1,natom iifix(iat)=kkfix0(iat) end do C RETURN END C C C **************************************************************** C C SUBROUTINE CHANGE C ================= C C This procedure controls an evaluation of initial level C populations in case where the system of explicit levels C (ie. the choice of explicit level, their numbering, or their C total number) is not consistent with that for the input level C populations read by procedure INPMOD. C Obviously, this procedure need be used only for NLTE input models. C C ICHANG < 0 - general change of populations as described below C > 0 - a simplified change; original data for the input C model are required to assign the input NLTE populations C to the levels in the new models; all additional C levels are assumed having LTE populations. C ICHANG is the unit number for the data file of old model. C C Case ICHANG < 0: C C Input from unit 5: C For each explicit level, II=1,NLEVEL, the following parameters: C IOLD - NE.0 - means that population of this level is C contained in the set of input populations; C IOLD is then its index in the "old" (i.e. input) C numbering. C All the subsequent parameters have no meaning C in this case. C - EQ.0 - means that this level has no equivalent in the C set of "old" levels. Population of this level C has thus to be evaluated. C MODE - indicates how the population is evaluated: C = 0 - population is equal to the population of the "old" C level with index ISIOLD, multiplied by REL; C = 1 - population assumed to be LTE, with respect to the C first state of the next ionization degree whose C population must be contained in the set of "old" C (ie. input) populations, with index NXTOLD in the C "old" numbering. C The population determined of this way may further C be multiplied by REL. C = 2 - population determined assuming that the b-factor C (defined as the ratio between the NLTE and C LTE population) is the same as the b-factor of C the level ISINEW (in the present numbering). The C level ISINEW must have the equivalent in the "old" C set; its index in the "old" set is ISIOLD, and the C index of the first state of the next ionization C degree, in the "old" numbering, is NXTSIO. C The population determined of this way may further C be multiplied by REL. C = 3 - level corresponds to an ion or atom which was not C explicit in the old system; population is assumed C to be LTE. C NXTOLD - see above C ISINEW - see above C ISIOLD - see above C NXTSIO - see above C REL - population multiplier - see above C if REL=0, the program sets up REL=1 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' character*20 fnstd dimension n0old(30,30),n1old(30,30) dimension katold(2,30),vtbold(mdepth) COMMON POPUL0(MLEVEL,MDEPTH),POPULL(MLEVEL,MDEPTH), * ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL),POPL(MLEVEL) C PARAMETER (S = 2.0706D-16) IF(ICHANG.LT.0) THEN IFESE=0 DO 100 II=1,NLEVEL READ(IBUFF,*) IOLD,MODE,NXTOLD,ISINEW,ISIOLD,NXTSIO,REL IF(REL.EQ.0.) REL=1. IF(MODE.GE.3) IFESE=IFESE+1 DO 90 ID=1,ND IF(IOLD.EQ.0) GO TO 10 POPUL0(II,ID)=POPUL(IOLD,ID) GO TO 90 10 IF(MODE.NE.0) GO TO 20 POPUL0(II,ID)=POPUL(ISIOLD,ID)*REL GO TO 90 20 T=TEMP(ID) ANE=ELEC(ID) IF(MODE.GE.3) GO TO 40 NXTNEW=NNEXT(IEL(II)) SB=S/T/SQRT(T)*G(II)/G(NXTNEW)*EXP(ENION(II)/T/BOLK) IF(MODE.GT.1) GO TO 30 POPUL0(II,ID)=SB*ANE*POPUL(NXTOLD,ID)*REL GO TO 90 30 KK=ISINEW KNEXT=NNEXT(IEL(KK)) SBK=S/T/SQRT(T)*G(KK)/G(KNEXT)*EXP(ENION(KK)/T/BOLK) POPUL0(II,ID)=SB/SBK*POPUL(NXTOLD,ID)/POPUL(NXTSIO,ID)* * POPUL(ISIOLD,ID)*REL GO TO 90 40 IF(IFESE.EQ.1) THEN LTE0=LTE LTE=.TRUE. do iii=1,nlevel if(wop(iii,id).eq.0.) wop(iii,id)=1. end do CALL STEQEQ(ID,POPL,0) DO III=1,NLEVEL POPULL(III,ID)=POPL(III) END DO LTE=LTE0 END IF POPUL0(II,ID)=POPULL(II,ID) 90 CONTINUE 100 CONTINUE DO I=1,NLEVEL DO ID=1,ND POPUL(I,ID)=POPUL0(I,ID) END DO END DO C C simplified change - no additional input (the case ICHANG > 0) C ELSE LTE0=LTE LTE=.TRUE. DO ID=1,ND do ii=1,nlevel if(wop(ii,id).eq.0.) wop(ii,id)=1. end do CALL STEQEQ(ID,POPL,0) DO II=1,NLEVEL POPUL0(II,ID)=POPL(II) END DO END DO C IF(ICHANG.EQ.1) THEN DO II=NLEV0+1,NLEVEL DO ID=1,ND POPUL(II,ID)=POPUL0(II,ID) END DO END DO C ELSE modr=0 rewind 1 read(1,*,err=200,end=200) modr 200 continue call readbf(ichang) if(modr.eq.0) then read(95,*) tfold,grold read(95,*) ltd1,ltd2 read(95,*) fnstd read(95,*) nfrd if(nfrd.lt.0) then nfrd=-nfrd do ij=1,nfrd read(95,*) frold end do endif read(95,*) natold if(natold.lt.0) natold=-natold do ia=1,natold read(95,*) iao,abnold if(abnold.gt.1.e6) read(95,*) (vtbold(i),i=1,ndold) end do nlold=0 read(95,*) iato,izo,nlvo,ilasti,ilvi,instd if(instd.ne.0) read(95,*) idui do while (ilasti.ge.0) n0old(iato,izo+1)=nlold+1 n1old(iato,izo+1)=nlold+nlvo nlold=nlold+nlvo read(95,*) iato,izo,nlvo,ilasti,ilvi,instd if(instd.ne.0) read(95,*) idui end do else read(95,*) tfold,grold,hmold read(95,*) ltd1,ltd2,lcold,ispold,chmold if(ispold.lt.0) read(95,*,err=203) iol1,iol2,iol3,iol4, . iol5,iol6,iol7 if(iol6.ge.2) read(95,*) djmold 203 read(95,*,err=204) nitold,ndold,natold,niold,nlvold, . iol1,iol2,iarold,iol4 204 continue if(iol1.gt.10) then read(95,*,err=205) iol1,iol2,iol3,iol4,iol5 read(95,*,err=205) iol1,iol2 read(95,*,err=205) iol1,iol2 end if 205 continue if(niold.lt.0) then niold=-niold read(95,*,err=206) iol1,iol2,iol3 end if 206 continue if(iarold.le.-100 .and. iarold.gt.-200) then iarold=-iarold-100 read(95,*) iol1 endif read(95,*) nfrd if(nfrd.gt.0) then nfrd=-nfrd do ij=1,nfrd read(95,*) frold end do else nfrd=-nfrd read(95,*) frold end if read(95,*,err=211) iol1,iol2,iol3 if(iol3.lt.0) read(95,*) pzold 211 continue read(95,*) iol1,vtbol if(iol1.ne.0) read(95,*) (vtbold(i),i=1,ndold) read(95,*) natsold if(natsold.lt.0) natsold=-natsold iat=0 do ia=1,natsold read(95,*) iol1,iol2,iol3,iol4,iol5,abnold if(abnold.gt.1.e6) read(95,*) (vtbold(i),i=1,ndold) if(iol1.eq.2) then iat=iat+1 katold(1,iat)=iol2 katold(2,iat)=iol3 end if end do do ii=1,niold read(95,*) k0old,k1old,k2old,izo if(k0old.lt.0) then k0old=-k0old read(95,*) iol1 end if do ia=1,iat if(k0old.ge.katold(1,ia) .and. k1old.ge.katold(2,ia)) . iaol=ia end do n0old(iaol,izo)=k0old n1old(iaol,izo)=k1old n0old(iaol,izo+1)=k2old n1old(iaol,izo+1)=k2old end do end if C WRITE(6,600) 600 FORMAT(' Levels: OLD model -> NEW model',/ . ' ------------------------------') DO 300 II=1,NION N0NEW=NFIRST(II) N1NEW=NLAST(II) IANEW=NUMAT(IATM(N0NEW)) IZNEW=IZ(IEL(N0NEW)) IF(N1OLD(IANEW,IZNEW).EQ.0) GO TO 300 KOLD=N1OLD(IANEW,IZNEW)-N0OLD(IANEW,IZNEW) KNEW=NLAST(II)-NFIRST(II) IF(KOLD.LT.KNEW) KNEW=KOLD JL=N0OLD(IANEW,IZNEW)-1 DO IL=NFIRST(II),NFIRST(II)+KNEW JL=JL+1 WRITE(6,601) JL,IL 601 FORMAT(10X,I8,5X,I8) DO ID=1,ND POPUL0(IL,ID)=POPUL(JL,ID) END DO END DO 300 CONTINUE DO 310 II=1,NATOM N0NEW=NKA(II) IANEW=NUMAT(IATM(N0NEW)) IZNEW=IZ(IEL(N0NEW))+1 IF(N0OLD(IANEW,IZNEW).EQ.0) GO TO 310 WRITE(6,601) N0OLD(IANEW,IZNEW),N0NEW DO ID=1,ND POPUL0(N0NEW,ID)=POPUL(N0OLD(IANEW,IZNEW),ID) END DO 310 CONTINUE C DO II=1,NLEVEL DO ID=1,ND POPUL(II,ID)=POPUL0(II,ID) END DO END DO END IF LTE=LTE0 C END IF RETURN END C C C **************************************************************** C C SUBROUTINE RESOLV C ================= C C Control procedure for the formal solution, i.e. all calculations C between two consecutive iterations of complete linearization C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' common/icnrsp/iconrs DIMENSION PGR(MLVEXP) C C Initialization - procedure INILAM: C ilam=0 CALL INILAM if(ioptab.lt.0.or.ioptab.gt.0) call rayset call prd(0) NLAMBD=NITLAM(ITER) IF(NLAMBD.LE.0) GO TO 80 IF(LFIN.AND.NITER.GT.0) NLAMBD=1 LAC2P=.FALSE. IACC0P=IACPP-3 C C solution of the transfer equation with Compton scattering C if(icompt.ne.0.and.iter.eq.1) then CALL OPAINI(1) ilam=0 do ij=1,nfreq call opacf1(ij) call rtefr1(ij) end do CALL RTECOM end if C IF(ITER.LE.1.and.ioptab.eq.0) CALL LINSEL C C Set of NLAMBD procedures, called overall "lambda" iterations C (not to be confused with ordinary lambda iterations) C Each "lambda" iteration contains: C DO ILAM=1,NLAMBD CALL OPAINI(1) if(icompt.ne.0.and.ilam.gt.1) CALL RTECOM C C Radiative rates in all transitions, in all depths C IF(IFPREC.EQ.0) THEN CALL RATES1(0) ELSE CALL RATSP1 END IF c call prd(0) C C ****** evaluation of the new populations, C using all the previously calculated radiative rates C DO ID=1,ND c CALL STEQEQ(ID,POP,0) CALL STEQEQ(ID,POP,1) CALL NEWPOP(ID,POP) IF(.NOT.LCHC.and.iter.lt.ielcor) CALL ELCOR(ID) END DO C if(iprind.eq.2) call output C C ****** acceleration of convergence (if required) C IF(IACPP.GT.0) THEN CALL ACCELP END IF C call lucy END DO C 80 IF(ITER.EQ.1.OR.LFIN) CALL ROSSTD(0) C CALL OUTPUT C C in case of convection is considered: call pzeval to evaluate pressures C and the logarithmic gradient of the total pressure C if(iter.le.nitzer) call pzert C if((iheso6.ne.0.or.HMIX0.GT.0.).and.init.eq.1) CALL PZEVAL call radpre CALL TIMING(1,ITER) ipng=1 if(iacd.gt.0) ipng=mod((iter-iacc),iacd) if(ipng.eq.0 .and. iter.ge.iacc .and. lres2) goto 90 c c call prnt if(hmix0.eq.0.) then write(6,611) iter-1 611 format(/'** CONVECTIVE FLUX: RESOLV; GLOBAL ITERATION =',I3/) call conout(1,ipconf) else if(hmix0.gt.0.) then if(iconre.gt.0.and.iter.le.iconre.and.iter.ge.iconrs) * call conref IF(ipconf.gt.0.or.(ipconf.eq.0.and.lfin)) then WRITE(6,611) ITER-1 CALL CONOUT(1,1) END IF end if C C evaluate necessary ALI aprameters C c call prnt CALL OPAINI(0) c call prnt if(icompt.ne.0.and.ilam.gt.1) CALL RTECOM IF(KANT(ITER).EQ.1.OR.LFIN) THEN CALL ALISK2 ELSE IF(IRDER.EQ.0) THEN CALL ALIST1 ELSE CALL ALIST2 END IF END IF c C if IFPOPR=2 - evaluate new populations C if(ifpopr.eq.2) then DO ID=1,ND CALL STEQEQ(ID,POP,1) IF(.NOT.LCHC.and.iter.lt.ielcor) CALL ELCOR(ID) END DO END IF 90 CONTINUE id=1 do ij=1,nfreqe absoe1(ij)=absoex(ij,id) end do C if(ihecor.ge.-2.and.izscal.eq.0) then if(inzd.gt.0.or.(idisk.eq.1.and.ifryb.gt.0)) then if(iheso6.eq.0) then CALL PZEVLD else CALL HESOL6 end if end if end if if(izscal.eq.1) call dmeval c if(ifryb.gt.0) call rybheq C C Output of condensed model atmosphere to file 7 C This file can serve as input of initial model atmosphere for C another run of the program. C CALL OUTPUT c call prnt C C Output of computed model atmosphere - standard output file C IF(LFIN) THEN IF(.NOT.LTE) CALL PRINC CALL OUTPRI IF(ICOOLP.NE.0.OR.IPOPAC.NE.0) CALL COOLRT CALL RECHCK IF(ICHCKP.NE.0) CALL CHCKSE IF(INTENS.GT.0) CALL RTEINT if(icompt.gt.0) then call rtecmu call opaini(0) do ij=1,nfreq call opacf1(ij) call taufr1(ij) end do end if RETURN END IF C C The final part - to store previously calculated C mean intensities - RADEX(IJ,ID), C and other model parameters (total number density, temperature, C electron density, and populations) for C further use in procedure SOLVE (actual complete linearization) C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE DO ID=1,ND PSY0(IJ,ID)=RADEX(IJ,ID) END DO END DO END IF DO ID=1,ND DO II=1,NLVEXP PSY0(NFREQE+INSE+II-1,ID)=0. PGR(II)=0. END DO DO I=1,NLEVEL II=IABS(IIEXP(I)) IF(II.GT.0) PGR(II)=PGR(II)+POPUL(I,ID) END DO DO III=1,NLVEXZ PSY0(NFREQE+INSE+III-1,ID)=PGR(INDLGZ(III)) END DO TOTN(ID)=DENS(ID)/WMM(ID)+ELEC(ID) IF(INRE.NE.0) PSY0(NFREQE+INRE,ID)=TEMP(ID) IF(INPC.NE.0) PSY0(NFREQE+INPC,ID)=ELEC(ID) IF(INHE.NE.0) PSY0(NFREQE+INHE,ID)=TOTN(ID) IF(INZD.NE.0) PSY0(NFREQE+INZD,ID)=ZD(ID) IF(INMP.NE.0) PSY0(NFREQE+INMP,ID)=DENS(ID)/WMM(ID) IF(INDL.NE.0) PSY0(NFREQE+INDL,ID)=DELTA(ID) END DO C IF(INIT.EQ.1.AND.NATOM.GT.0) THEN WRITE(6,600) DO ID=1,ND WRITE(6,601) ID,(NREFS(I,ID),I=1,NATOM) END DO 600 FORMAT(//' REFERENCE LEVEL INDICES AS FUNCTIONS OF DEPTH'/, * 'ITER =',i4) 601 FORMAT(' ID=',I3,2X,15I4) END IF C RETURN END C C C **************************************************************** C C SUBROUTINE INILAM C ================= C C Auxiliary procedure for RESOLV C initialization of model parameters for further use in RESOLV C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION COL(MTRANS),DENS0(MDEPTH),SBW(MLEVEL),XE(MDEPTH), * CLOC(MTRANS),ANTC(MDEPTH) DIMENSION GRD(MDEPTH),pra(mdepth) C IF(INIT.EQ.1) THEN C C Before first iteration of complete linearization, ie. just after C initialization of basic parameters and reading the initial model C atmosphere - i.e. if INIT=1: C only evaluation of collisional rates for all transitions, at all C depths C anerel=0.5 if(teff.lt.8000.) anerel=0.01 CALL TDPINI IF(IDISK.EQ.1) THEN AMUV0=DMVISC**(ZETA0+UN) AMUV1=UN-AMUV0 DMTOT=DM(ND) EDISC=SIG4P*TEFF**4/DMTOT END IF DO ID=1,ND CALL WNSTOR(ID) FCOOL(ID)=0. FPRD(ID)=0. call sabolf(id) c c intialize b-factors c DO I=1,NLEVEL BFAC(I,ID)=UN SBW(I)=ELEC(ID)*SBF(I)*WOP(I,ID) END DO IF(.NOT.LTE.AND.IPSLTE.EQ.0 .and. id.lt.idlte) THEN DO ION=1,NION DO I=NFIRST(ION),NLAST(ION) IF(POPUL(NNEXT(ION),ID).GT.0..and.iltlev(i).eq.0) * BFAC(I,ID)=POPUL(I,ID)/ * (POPUL(NNEXT(ION),ID)*SBW(I)) END DO END DO END IF c c fully fixed part of the total charge c qfix(id)=0. do i=1,nlevel if(imodl(i).lt.0.or.iifix(iatm(i)).gt.0) then ch=iz(iel(i))-1 il=ilk(i) if(il.gt.0) ch=iz(il)+(iz(il)-1)*usum(il)*elec(id) qfix(id)=qfix(id)+ch*popul(i,id) end if end do c c collisional rates c IF(.NOT.LTE) THEN CALL COLIS(ID,TEMP(ID),COL,CLOC) DO I=1,NTRANS COLRAT(I,ID)=COL(I) COLTAR(I,ID)=CLOC(I) END DO END IF END DO CALL ODFMER C c initialize viscosity parameters for disks c IF(IDISK.EQ.1) CALL VISINI c c dielectronic recombination c if(ifdiel.gt.0) call dietot C C in case of ISPLIN>4 - (i.e. the DFE solver for transfer equation) C evaluate Planck function for the first estimate of RAD for C the electron scattering source function C IF(ISPLIN.GE.5) THEN DO ID=1,ND DO IJ=1,NFREQ RAD(IJ,ID)=BNUE(IJ)/(EXP(HKT1(ID)*FREQ(IJ))-UN) END DO END DO END IF RETURN END IF C C ================================================================== C Immediately after a completed iteration of complete linearization: C ================================================================== C PRAD=0. DO ID=1,ND C C save some old quantities C AOLD=DENS(ID)/WMM(ID)+ELEC(ID) XE(ID)=UN-ELEC(ID)/AOLD C C Depth by depth: C set up individual arrays of model parameters, namely: C temperature - TEMP (if temperature is one of variables, C ie. if radiative equilibrium equation is solved) C IF(INRE.NE.0) TEMP(ID)=PSY0(NFREQE+INRE,ID) C C electron density - ELEC (if ELEC is one of variables, ie. if C particle conservation equation is solved) C IF(INPC.NE.0) ELEC(ID)=PSY0(NFREQE+INPC,ID) C C density - DENS, calculated by means of total particle number C density and electron density (if total particle C number density is one of variables, ie. if hydrostatic C equilibrium equation is solved - INHE.GT.0) C IF(INHE.NE.0) TOTN(ID)=PSY0(NFREQE+INHE,ID) C IF(IFIXDE.EQ.0) THEN DENS0(ID)=DENS(ID) IF(INHE.NE.0) THEN DENS(ID)=WMM(ID)*(PSY0(NFREQE+INHE,ID)-ELEC(ID)) DPLP=DENS0(ID)*DPSILN DPLM=DENS0(ID)/DPSILN IF(DENS(ID).GT.DPLP) DENS(ID)=DPLP IF(DENS(ID).LT.DPLM) DENS(ID)=DPLM ELSE if(ioptab.lt.-1) then PGS(ID)=PTOTAL(ID) DENS(ID)=RHOEOS(TEMP(ID),PGS(ID)) end if END IF END IF C C or again density, but calculated by means of the C massive particle density, C if this is one of variables - INMP.GT.0) C IF(INMP.NE.0) DENS(ID)=WMM(ID)*PSY0(NFREQE+INMP,ID) C C geometrical distance C IF(INZD.GT.0) ZD(ID)=PSY0(NFREQE+INZD,ID) C C the temperature logarithmic gradient delta C IF(INDL.NE.0) DELTA(ID)=PSY0(NFREQE+INDL,ID) C ANMA(ID)=DENS(ID)/WMM(ID) ANTO(ID)=ANMA(ID)+ELEC(ID) END DO C c avoid oscillations in temperature c IF(IOSCOR.NE.0) CALL OSCCOR C C if needed, formal solution of the hydrostatic equilibrium to get C new total particle density, and possibly electron density C IF(IHECOR.GE.2) THEN ID=1 PTUR=HALF*VTURB(ID)*VTURB(ID)*DENS(ID) ANTC(ID)=(DM(ID)*GRAV-PRD0-PTUR)/BOLK/TEMP(ID) IF(ANTC(ID).LE.0) ANTC(ID)=DENS(ID)/WMM(ID)+ELEC(ID) DO ID=2,ND PTUR=HALF*VTURB(ID)*VTURB(ID)*DENS(ID) PTURM=HALF*VTURB(ID-1)*VTURB(ID-1)*DENS(ID-1) ANTC(ID)=(GRAV*(DM(ID)-DM(ID-1))+ * BOLK*TEMP(ID-1)*ANTC(ID-1)- * PRADT(ID)+PRADT(ID-1)-PTUR+PTURM)/ * BOLK/TEMP(ID) END DO DO ID=1,ND ELEC(ID)=(UN-XE(ID))*ANTC(ID) DENS(ID)=WMM(ID)*(ANTC(ID)-ELEC(ID)) ANMA(ID)=DENS(ID)/WMM(ID) ANTO(ID)=ANMA(ID)+ELEC(ID) END DO END IF C C other depth-dependent quantities C do id=1,nd PGS(ID)=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) end do c IF(IOPTAB.GE.0) THEN DO ID=1,ND C C occupation probabilities C CALL WNSTOR(ID) C C Evaluation of collision rates for the new temperature C IF(.NOT.LTE) THEN call sabolf(id) CALL COLIS(ID,TEMP(ID),COL,CLOC) DO I=1,NTRANS COLRAT(I,ID)=COL(I) COLTAR(I,ID)=CLOC(I) END DO END IF END DO END IF C CALL CONCOR CALL TDPINI C------------------------ C C new populations C C 1. first possibility (useful for pure CL) -- C new populations, ie. those calculated directly C by the complete linearization (as old population + corresponding C corrections) are not used. C Instead, new populations are calculated from the new radiation C field basically by lambda iteration, ie. C a) evaluation of new radiative rates for explicit transitions C (radiative rates in fixed-option transitions are not updated C at this step) C if(ifpopr.le.0.or.lte.OR.IFRYB.GT.0) then IMOR=0 IF(IFRYB.GT.2) IMOR=1 IF(.NOT.LTE) CALL RATES1(IMOR) C C b) depth by depth evaluation of new populations by solving C statistical equilibrium equation with previously evaluated C rates, together with constraints - precisely as in RESOLV C DO ID=1,ND CALL STEQEQ(ID,POP,1) IF(.NOT.LCHC.and.iter.lt.ielcor) CALL ELCOR(ID) END DO if(iprind.eq.2) call output c C 2. second possibility -- populations from linearization corrections C ELSE DO ID=1,ND DO I=1,NLEVEL if(iifix(iatm(i)).ne.1) then II=IIEXP(I) IF(II.GT.0) THEN III=IINONZ(II) IF(III.GT.0) THEN POPUL(I,ID)=PSY0(NFREQE+INSE+III-1,ID) ELSE POPUL(I,ID)=0. END IF ELSE IF(II.LT.0) THEN III=IINONZ(-II) IF(III.GT.0) THEN POPUL(I,ID)=PSY0(NFREQE+INSE+III-1,ID)* * SBPSI(I,ID) ELSE POPUL(I,ID)=0. END IF ELSE III=IINONZ(IIEXP(ILTREF(I,ID))) IF(III.GT.0) THEN POPUL(I,ID)=PSY0(NFREQE+INSE+III-1,ID)* * SBPSI(I,ID) ELSE POPUL(I,ID)=0. END IF END IF END IF END DO END DO END IF CALL ODFMER c c dielectronic recombination c if(ifdiel.gt.0) call dietot C if(ifryb.gt.0) call rybheq C C solution of the transfer equation with Compton scattering C if(icompt.gt.0) then call opaini(1) call comset call rtecom end if c IF(IDISK.EQ.1) call visini c c if(ifryb.eq.0) then CALL OPAINI(1) DO ID=1,ND GRD(ID)=0. pra(id)=0. pradt(id)=0. END DO prd0=0. DO IJ=1,NFREQ CALL OPACF1(IJ) CALL RTEFR1(IJ) GRD(1)=GRD(1)+W(IJ)*ABSO1(1)*FH(IJ)*RAD1(1) DO ID=2,ND GRD(ID)=GRD(ID)+(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))* * W(IJ) pra(id)=pra(id)+RAD1(ID)*FAK1(ID)*W(IJ) END DO pra(1)=pra(1)+RAD1(1)*FAK1(1)*W(IJ)-ABSO1(1)*W(IJ)* * (RAD1(1)*FH(IJ)-HEXTRD(IJ)) END DO GRD(1)=PCK*GRD(1)/DENS(1) c do id=1,nd pra(id)=pra(id)*pck pradt(id)=pradt(id)*pck c pradfc(id)=pra(id)/(2.5213e-15*temp(id)**4) end do C if(idisk.eq.0) then PGS(1)=DM(1)*(GRAV-GRD(1)) DO ID=2,ND PGS(ID)=PGS(ID-1)-PCK*GRD(ID)+GRAV*(DM(ID)-DM(ID-1)) END DO end if c RETURN END c c c ***************************************************************** c c subroutine osccor c ================= c c routine for finding and removing oscillations in the temperature c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' dimension delt(mdepth),dda(mdepth) c ndos=abs(ioscor)+1 do id=2,ndos delt(id)=temp(id)-temp(id-1) end do do id=2,ndos-1 dd=delt(id)*delt(id+1) dda(id)=1. if(dd.ne.0.) dda(id)=dd/abs(dd) end do c iobeg=0 ioend=0 do id=2,ndos-1 if(dda(id).lt.0.and.iobeg.eq.0) iobeg=id if(dda(id).gt.0.and.dda(id-1).lt.0) ioend=id end do iobeg=iobeg-1 if(iobeg.gt.0) then write(6,601) iter,iobeg,ioend,(temp(id),id=iobeg,ioend) 601 format(/' oscillation in T in iteration',i4, * ' between depths',i4,' and ',i4/(10f8.1)) c st=log(temp(ioend)/temp(iobeg))/log(dm(ioend)/dm(iobeg)) tl0=log(temp(iobeg)) do id=iobeg,ioend dml=log(dm(id)/dm(iobeg)) tl=tl0+dml*st temp(id)=exp(tl) end do write(6,603) (temp(id),id=iobeg,ioend) 603 format(/' removed and replaced by the values:'/(10f8.1)) c end if c c set surface temperature to the minimum one c if(ioscor.lt.0) then tmin=1.e9 do id=1,nd if(temp(id).lt.tmin) then tmin=temp(id) imin=id end if end do c do id=1,imin temp(id)=tmin end do c end if return end C C C **************************************************************** C C SUBROUTINE ROSSTD(IJ) C ===================== C C Rosseland mean opacity C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ALIPAR.FOR' c DIMENSION TAUR(MDEPTH) dimension pld(mdepth),abpld(mdepth) C C for IJ > 0 - contribution from the frequency IJ to the Rosseland C opacity integrals C IF(IJ.GT.0) THEN if(ij.eq.1) then do id=1,nd pld(id)=0. abpld(id)=0. end do end if IF(IJX(IJ).GE.0) THEN DO ID=1,ND PLAN=XKFB(ID)/XKF1(ID)*W(IJ) DPLAN=PLAN/XKF1(ID)*FREQ(IJ)*HKT21(ID) ABROSD(ID)=ABROSD(ID)+DPLAN/ABSO1(ID) SUMDPL(ID)=SUMDPL(ID)+DPLAN pld(id)=pld(id)+plan abpld(id)=abpld(id)+(abso1(id)-scat1(id))*pld(id) END DO END IF ELSE C C for IJ=0 - evaluation of the Rosseland optical depth and C the radiative equilibrium division point C ID=1 IDR=0 TAURS(ID)=HALF*DEDM1*ABROSD(ID)*DENS(ID) DO ID=2,ND DTAUR=DELDM(ID-1)*(ABROSD(ID)+ABROSD(ID-1)) TAURS(ID)=TAURS(ID-1)+DTAUR IF(TAURS(ID).LE.TAUDIV) IDR=ID END DO C C in the last iteration, output of The Rosseland opacity and C optical depth; skip the rest C IF(LFIN) THEN DO ID=1,ND TROSS(ID)=TAURS(ID) abpl=abpld(id)/pld(id)/dens(id) pll=sig4p*4.*temp(id)**4 WRITE(11,611) ID,DM(ID),TAURS(ID),ABROSD(ID), * TEMP(ID),ELEC(ID),DENS(ID), * pld(id),pll,abpl END DO 611 FORMAT(I4,2X,1P6E12.4,2x,3e12.4) RETURN END IF C C determination of the radiative equilibrium parameters C REINT and REDIF; C REINT=1 for all ID .le. ND-idlst C REDIF=1 for Rosseland optical depth > taudiv (taur.gt.taudiv) C typically 0.1 - 0.5; C - this value has been empirically shown to yield C the best convergence rate C IF(ITER.GT.ITNDRE) RETURN if(ndre.gt.1) then c write(6,600) do id=1,nd if(id.lt.ndre) then reint(id)=1. redif(id)=0. else reint(id)=0. redif(id)=1. end if end do idr=ndre else if(ndre.eq.-1) then write(6,600) do id=1,nd reint(id)=1. redif(id)=0. end do redif(1)=1. else c DO ID=1,ND REINT(ID)=UN REDIF(ID)=UN IF(ID.GT.ND-IDLST) REINT(ID)=0. IF(ID.LT.IDR) THEN REDIF(ID)=0. IF(MOD(NDRE,10).EQ.-1) THEN REDIF(ID)=TAURS(ID) ELSE IF(MOD(NDRE,10).EQ.-2) THEN REDIF(ID)=TAURS(ID)*TAURS(ID) END IF END IF IF(NDRE.LE.-10) THEN REDIF(ID)=REDIF(ID)/SIG4P/TEFF**4 REINT(ID)=REINT(ID)/ABPLAD(ID)*DENS(ID) END IF END DO ID=1 IF(MOD(NDRE,10).EQ.-5) REDIF(ID)=UN IF(NDRE.LE.-10) THEN REDIF(ID)=REDIF(ID)/SIG4P/TEFF**4 END IF NDRE=1 if(iter.eq.1) then WRITE(6,601) IDR,IDR+1,ND-idlst WRITE(10,601) IDR,IDR+1,ND-idlst endif endif WRITE(6,601) IDR,IDR+1,ND-idlst 600 FORMAT(/' id redif reint'/) 601 FORMAT(/' SCHEME OF RADIATIVE EQUIL. DETERMINED IN RESOLV'/ * ' ONLY INTEGRAL EQUATION FOR ID <= ',I3/ * ' BOTH FOR ',I5,' <= ID <= ',I3/) END IF RETURN END C C C **************************************************************** C C SUBROUTINE NEWPOP(ID,POP1) C ========================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' DIMENSION POP1(MLEVEL),DPOP(MLEVEL),DPMAX(MDEPTH), * SBW(MLEVEL) c if(ioptab.lt.0) return C DPMAX(ID)=0. DO I=1,NLEVEL IF(POPUL(I,ID).GT.0.) * DPOP(I)=(POP1(I)-POPUL(I,ID))/POPUL(I,ID) IF(ABS(DPOP(I)).GT.DPMAX(ID)) THEN DPMAX(ID)=ABS(DPOP(I)) IMAX=I END IF POPUL(I,ID)=POP1(I) END DO c WRITE(18,601) ITER,ILAM,ID,DPMAX(ID),IMAX c 601 FORMAT(3I5,1PE10.2,I6) C C array of b-factors C DO I=1,NLEVEL BFAC(I,ID)=UN SBW(I)=ELEC(ID)*SBF(I)*WOP(I,ID) END DO IF(.NOT.LTE.AND.IPSLTE.EQ.0) THEN DO ION=1,NION DO I=NFIRST(ION),NLAST(ION) IF(POPUL(NNEXT(ION),ID).GT.0.) * BFAC(I,ID)=POPUL(I,ID)/(POPUL(NNEXT(ION),ID)*SBW(I)) END DO END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE SWITCH(INITM) C ======================== C C Procedure for evaluating the collisional-radiative switching C parameter lambda(R), denoted here CRSW(ID); C Original procedure suggested by Hummer and Voels, C Astron. Astrophys. 192, 279, 1988, was modified here by a C possibility of considering depth dependent switching parameter CRSW C C Parameters SWPFAC, SWPLIM, SWPINC, and ICRSW are input C parameters, having the meaning: C C ICRSW = 0 - collisional-radiative switching not considered C > 0 - collisional-radiative switching is considered C SWPFAC - initial CRSW = SWPFAC * min(collis.rate/rad.rate) C SWPLIM - has the meaning: if CRSW > SWPLIM, then CRSW = 1 C SWPINC - CRSW(actual) = CRSW(previous) * SWPINC C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' DIMENSION SWTCH(MDEPTH) C IF(ICRSW.EQ.0) RETURN IF(INITM.EQ.0) GO TO 10 C C Before the first iteration of complete linearization C initialisation of the collisional-radiative switching C parameters, as described by Hummer and Voels, C Astron. Astrophys. 192, 279, 1988; C modified here by considering depth-dependent swiching C parameter lambda(R) - denoted here CRSW(ID) C SWMIN=UN DO ID=1,ND SWTCH(ID)=UN DO ITR=1,NTRANS C=COLRAT(ITR,ID) IF(RRU(ITR,ID).NE.0.) THEN C C upward rates C SWU=C/RRU(ITR,ID) C C downward rates C IF(LINE(ITR)) THEN SWD=C*EXP(HK*FR0(ITR)/TEMP(ID))/RRD(ITR,ID) ELSE SWD=C/RRD(ITR,ID) END IF C C minimum value C IF(SWU.LT.SWTCH(ID)) SWTCH(ID)=SWU IF(SWD.LT.SWTCH(ID)) SWTCH(ID)=SWD END IF END DO IF(SWTCH(ID).LT.SWMIN) SWMIN=SWTCH(ID) END DO C DO ID=1,ND IF(ICRSW.EQ.1) THEN CRSW(ID)=SWMIN*SWPFAC ELSE CRSW(ID)=SWTCH(ID)*SWPFAC END IF IF(CRSW(ID).GT.SWPLIM) CRSW(ID)=UN END DO WRITE(6,601) (CRSW(ID),ID=1,ND) RETURN C C After second and further iterations of complete linearization C evaluation of new collisional-radiative switching parameters C by multiplication of the previous ones by a prechosen factor C SWPINC C 10 CONTINUE DO ID=1,ND CRSW(ID)=CRSW(ID)*SWPINC IF(CRSW(ID).GT.SWPLIM) CRSW(ID)=UN END DO WRITE(6,601) (CRSW(ID),ID=1,ND) 601 FORMAT(1P8D10.3) RETURN END C C C **************************************************************** C C SUBROUTINE SABOLF(ID) C ===================== C C Saha-Boltzmann factors (SBF) C and "upper sums" - sum of Saha-Boltzmann factors for upper, LTE, C levels which are not included explicitly (USUM), and derivatives C wrt. temperature (T) and electron density (DUSUMN) C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (UH=1.5) PARAMETER (CMAX=2.154D4,CCON=2.0706D-16) C C DCHI - approximate lowering of ionization potential for neutrals C Actual lowering is DCHI*effective charge, and is considered only C if IUPSUM(ION).GT.0 C c if(ioptab.lt.0) return c T=TEMP(ID) SQT=SQRT(T) ANE=ELEC(ID) STANE=SQRT(T/ANE) XMAX=CMAX*SQRT(STANE) TK=BOLK*T CON=CCON/T/SQT C C Saha-Boltzmann factors C DO ION=1,NION QZ=IZ(ION) CFN=CON/G(NNEXT(ION)) DCH=0. IUPS=IUPSUM(ION) SSBF=0. DSSBFT=0. USUM(ION)=0. DUSUMT(ION)=0. DUSUMN(ION)=0. nlst=nlast(ion) if(ifwop(nlst).ge.0) then nl1up=nquant(nlst)+1 else nl1up=nquant(nlst) end if DO II=NFIRST(ION),NLAST(ION) if(ifwop(ii).lt.0) then E=EH*QZ*QZ/TK SUM=0. DO J=nl1up,NLMX XJ=J XI=J*J X=E/XI FI=XI*EXP(X)*WNHINT(J,ID) SUM=SUM+FI END DO g(ii)=sum*two gmer(imrg(ii),id)=g(ii) end if X=ENION(II)/TK if(x.gt.110.) x=110. SB=CFN*G(II)*EXP(X) SBF(II)=SB SSBF=SSBF+SB DSBF(II)=-(UH+ENION(II)/TK)/T DSSBFT=DSSBFT+SB*DSBF(II) END DO C C Upper sums C if(ifwop(nlst).ge.0) then IF(ION.EQ.IELHM) THEN USUM(ION)=0. DUSUMT(ION)=0. DUSUMN(ION)=0. GO TO 50 END IF IF(IUPS.EQ.0) THEN C C 1. More exact approach - using (exact) partition functions C IAT=NUMAT(IATM(NFIRST(ION))) XMX=XMAX*SQRT(QZ) CALL PARTF(IAT,IZ(ION),T,ANE,XMX,U,DUT,DUN) EE=ENION(NFIRST(ION))/TK IF(EE.GT.110.) EE=110. CFE=CFN*EXP(EE) USUM(ION)=CFE*U-SSBF DUSUMT(ION)=CFE*(DUT-U/T*(UH+EE))-DSSBFT DUSUMN(ION)=CFE*DUN xx=(ssbf-sbf(nfirst(ion)))/sbf(nfirst(ion)) IF(USUM(ION).LT.0.or.ee.ge.109.or.xx.lt.1.e-7) THEN USUM(ION)=0. DUSUMT(ION)=0. DUSUMN(ION)=0. END IF C C 2. Approximate approach - summation over fixed number of upper C levels, assumed hydrogenic (ie. their ionization energy and C statistical weight hydrogenic) C ELSE IF(IUPS.GT.0) THEN SUM=0. DSUM=0. E=EH*QZ*QZ/TK DO J=NQUANT(NLAST(ION))+1,IUPS XI=J*J X=E/XI FI=XI*EXP(X) SUM=SUM+FI DSUM=DSUM-FI*(UH+X)/T END DO USUM(ION)=SUM*CON*TWO DUSUMT(ION)=DSUM*CON*TWO DUSUMN(ION)=0. C c 3. occupation probability form c ELSE SUM=0. DSUM=0. E=EH*QZ*QZ/TK DO J=NQUANT(NLAST(ION))+1,NLMX XJ=J XI=J*J X=E/XI FI=XI*EXP(X)*WNHINT(J,ID) SUM=SUM+FI DSUM=DSUM-FI*(UH+X)/T END DO USUM(ION)=SUM*CON*TWO DUSUMT(ION)=DSUM*CON*TWO DUSUMN(ION)=0. END IF end if 50 CONTINUE END DO RETURN END C C C **************************************************************** C C C SUBROUTINE OPACF1(IJ) C ===================== C C Absorption, emission, and scattering coefficients C at frequency IJ and for all depths C C Input: IJ opacity and emissivity is calculated for the C frequency points with index IJ C Output: ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient (all scattering C mechanisms except electron scattering) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' common/hmolab/anh2(mdepth),anhm(mdepth) common/ipricr/iprcrs,nprcrs PARAMETER (C14=2.99793D14, c10=c14*1.d-4,CFF1=1.3727D-25) dimension pold(mlevel),abtrh(mtrans) c if(ioptab.lt.0) then do id=1,nd abso1(id)=0. scat1(id)=0. emis1(id)=0 absot(id)=0. end do call opact1(ij) return end if C C initialize c elscat(id)=elec(id)*sige IF(ICOMPT.GT.0) THEN DO ID=1,ND ELSCAT(ID)=ELEC(ID)*SIGEC(IJ) END DO END IF C DO ID=1,ND c ABSO1(ID)=ELSCAT(ID) ABSO1(ID)=0. EMIS1(ID)=0. SCAT1(ID)=ELSCAT(ID) END DO C C basic frequency- and depth-dependent quantities C FR=FREQ(IJ) FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV DO ID=1,ND XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) END DO if(ielh.gt.0) n0hn=nfirst(ielh) al=2.997925e18/fr lpri=al.gt.1579.0.and.al.lt.1579.5 c lfre=freq(ij).gt.frtabm if(iprcrs.gt.0) then abso1(iprcrs)=0. do ii=nfirst(ielh),nlast(ielh) if(ii.ne.nprcrs+nfirst(ielh)-1) then pold(ii)=popul(ii,iprcrs) popul(ii,iprcrs)=0. do jj=ii+1,nnext(ielh) itrh=itra(ii,jj) abtrh(itrh)=abtra(itrh,iprcrs) abtra(itrh,iprcrs)=0. end do end if end do end if C C ******** 1a. bound-free contribution - without dielectronic rec. C if(ifdiel.eq.0) then DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) iad=iadop(iatm(ii)) lcomop=iad.eq.0.or.(lfre.and.iad.gt.0) SG=CROSS(IBFT,IJ) IF(SG.GT.0..and.lcomop) THEN JJ=IUP(ITR) IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF c if(lpri.and.id.eq.40) c * write(65,621) id,ij,al,itr,ii,jj,typion(iel(ii)), c * ii-nfirst(iel(ii))+1,jj-nfirst(iel(ii))+1, c * popul(ii,id),sgd*abtra(itr,id),abso1(id),emisbf,emis1(id) c end if c 621 format('bf',i4,i6,f10.3,3i5,2x,a4,2x,2i4,1p5e14.7) END DO END IF END DO else C C ******** 1b. bound-free contribution - with dielectronic rec. C DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) iad=iadop(iatm(ii)) lcomop=iad.eq.0.or.(lfre.and.iadop(iatm(ii)).gt.0) SG=CROSS(IBFT,IJ) IF(SG.GT.0..and.lcomop) THEN JJ=IUP(ITR) IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SG=CROSSD(IBFT,IJ,ID) IF(SG.GT.0.) THEN SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF END IF END DO END IF END DO end if C C ******** 2. free-free contribution C DO 40 ION=1,NION IT=ITRA(NNEXT(ION),NNEXT(ION)) iad=iadop(iatm(nnext(ion))) if(iad.gt.0.and..not.lfre) go to 40 C C hydrogenic with Gaunt factor = 1 C IF(IT.EQ.1) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF c if(lpri.and.mod(id,20).eq.1) then c write(6,622) id,ij,ion,typion(ion),sf1,sf2,absoff,abso1(id) c end if c 622 format('ff',i4,i6,i4,2x,a4,2x,1p4e14.6) END DO C C hydrogenic with exact Gaunt factor C ELSE IF(IT.EQ.2) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) X=C14*CHARG2(ION)/FR SF2=SF2-UN+GFREE1(ID,X) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF c if(lpri.and.mod(id,20).eq.1) then c sgf=gfree1(id,x) c write(6,624) id,ij,ion,typion(ion),ff(ion),sgf,sf2,abso1(id) c end if c 624 format('ffh',i4,i6,i4,2x,a4,2x,1p4e14.6) END DO C C H minus free-free opacity C ELSE IF(IT.EQ.3) THEN DO ID=1,ND T=TEMP(ID) ANE=ELEC(ID) c ABSOFF=(CFF1+CFFT(ID)*FRINV)*CFFN(ID)*FRINV ABSOFF=SFFHMI(POPUL(N0HN,ID),FR,T)*ANE ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO C C special evaluation of the cross-section C ELSE IF(IT.LT.0) THEN DO ID=1,ND ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)* * POPUL(NNEXT(ION),ID)*ELEC(ID) ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO END IF 40 CONTINUE C C ******** 3. - additional continuum opacity (OPADD) C IF(IOPADD.NE.0) THEN ICALL=1 DO ID=1,ND CALL OPADD(0,ICALL,IJ,ID) ABSO1(ID)=ABSO1(ID)+ABAD EMIS1(ID)=EMIS1(ID)+EMAD SCAT1(ID)=SCAT1(ID)+SCAD c if(lpri.and.mod(id,20).eq.1) then c if(lpri.and.id.eq.50) then c write(6,623) id,ij,abad,abso1(id),emis1(id),scat1(id) c write(6,623) id,ij,abad,emad,scad c write(*,*) 'elec',elec(id),sigec(ij),elscat(id) c end if c 623 format('ad',i4,i6,1p4e14.6) END DO END IF C C ******** 4. - opacity and emissivity in lines C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) iad=iadop(iatm(ilow(itr))) if(iad.eq.0.or.(lfre.and.iad.gt.0)) then DO ID=1,ND SG=PRFLIN(ID,IJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO end if ENDIF IF(NLINES(IJ).GT.0) THEN C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) go to 100 iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 100 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 DO ID=1,ND SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO c if(lpri.and.mod(id,20).eq.1) write(6,648) ij,id,itr,abso1(id), c * emis1(id),sg,abtra(itr,id) c 648 format('lin1',i8,i4,i7,1p4e14.6) 100 CONTINUE END IF C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 400 DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 300 KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3.AND.INDXPA.NE.4) THEN DO ID=1,ND SG=PRFLIN(ID,KJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO ELSE DO ID=1,ND KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))* * SIGFE(KJD+1,KJ)) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO ENDIF c if(lpri.and.mod(id,20).eq.1) write(6,649) ij,id,itr,abso1(id), c * emis1(id),sg,abtra(itr,id) c 649 format('linodf',i8,i4,i7,1p4e14.6) 300 CONTINUE 400 CONTINUE ENDIF C c Lyman alpha and beta quasimolecular opacity c call quasim(ij) c C ---------------------------- C total opacity and emissivity C ---------------------------- C DO ID=1,ND ABSO1(ID)=ABSO1(ID)-EMIS1(ID)*XKF(ID)+SCAT1(ID) EMIS1(ID)=EMIS1(ID)*XKFB(ID) absot(id)=abso1(id) c if(lpri.and.mod(id,20).eq.1) write(6,641) ij,id,abso1(id), c * emis1(id),scat1(id) c 641 format('opac1',i8,i4,1p3e14.6) END DO c c --------------------------------- c hydrogen pacity from Gomez tables c --------------------------------- c call ghydop(ij) c c approximate opacity in Lyman lines C if(ioplym.gt.0) call lymlin(ij) C c -------------------------------------------------------- c contribution from precalculated background opacity table c --------------------------------------------------------` c if(ioptab.gt.0) then call opact1(ij) end if C C if needed, evaluate the opacity per gram C if(izscal.eq.0) then do id=1,nd absot(id)=abso1(id)*dens1(id) end do end if c if(ifprd.gt.0) call prd(ij) c if(iprcrs.gt.0) then ih=nfirst(ielh)+nprcrs-1 crs=abso1(iprcrs)/(popul(ih,iprcrs)*g(ih)* * 0.0265*4.1347e-15) do ii=nfirst(ielh),nlast(ielh) if(ii.ne.ih) then popul(ii,iprcrs)=pold(ii) do jj=ii+1,nnext(ielh) itrh=itra(ii,jj) abtra(itrh,iprcrs)=abtrh(itrh) end do end if end do end if RETURN END C C C **************************************************************** C C SUBROUTINE LEVSOL(A,B,POPP,IICAL,NLVCAL,IALL) C ============================================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' DIMENSION A(MLEVEL,MLEVEL),B(MLEVEL),POPP(MLEVEL), * AP(MLEVEL,MLEVEL),BP(MLEVEL),POPP1(MLEVEL), * IICAL(MLEVEL) C if(ioptab.lt.0) return c C new populations - solution of the rate equations C C a) either by inverting the global rate matrix (if IRSPLT=0) C IF(IRSPLT.EQ.0) THEN CALL LINEQS(A,B,POPP,NLVCAL,MLEVEL) C C b) or by inverting several partial rate matrices for the C individual chemical species C ELSE DO 20 IAT=1,NATOM IF(IIFIX(IAT).EQ.1.AND.IALL.EQ.0) GO TO 20 N1=N0A(IAT) NK=NKA(IAT) N1=IICAL(N1) NK=IICAL(NK) IF(N1.LE.0) THEN DO I=N0A(IAT),NKA(IAT) N1=IICAL(I) IF(IICAL(I).GT.0) GO TO 10 END DO 10 CONTINUE END IF IF(N1.LE.0) GO TO 20 NLP=NK-N1+1 DO I=N1,NK DO J=N1,NK AP(I-N1+1,J-N1+1)=A(I,J) END DO BP(I-N1+1)=B(I) END DO CALL LINEQS(AP,BP,POPP1,NLP,MLEVEL) DO I=N1,NK POPP(I)=POPP1(I-N1+1) END DO 20 CONTINUE END IF RETURN END C C C **************************************************************** C C SUBROUTINE STEQEQ(ID,POP1,MODE) C =============================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' COMMON/POPSTR/POPP(MLEVEL), * POPP1(MLEVEL),POPP2(MLEVEL),POPP3(MLEVEL) COMMON/PPAPAR/IPOPST(MATOM),NTERST,ITERST, * IACPPP,IACPP0,IACPPD,LACPPP DIMENSION A(MLEVEL,MLEVEL),B(MLEVEL),POP0(MLEVEL) DIMENSION POP1(MLEVEL),SBW(MLEVEL) C if(ioptab.lt.0) return c t=temp(id) aein=elec(id) an=dens(id)/wmm(id)+elec(id) if(ifmol.gt.0.and.t.lt.tmolim) then ipri=0 call moleq(id,t,an,aein,ane,enrg,entt,wm,ipri) C don't change the electron density when C charge conservation is not solved C elec(id)=ane if(INPC.ne.0) elec(id)=ane end if c C evaluation of the global rate matrix C CALL SABOLF(ID) CALL RATMAT(ID,IIFOR,1,A,B) C C new populations - solution of the rate equations C CALL LEVSOL(A,B,POP0,IIFOR,NLVFOR,0) c C array of new populations C DO I=1,NLEVEL SBW(I)=ELEC(ID)*SBF(I)*WOP(I,ID) II=IIFOR(I) IF(II.GT.0) THEN POP1(I)=POP0(II) ELSE IF(II.LT.0) THEN POP1(I)=POP0(-II)*SBPSI(I,ID) ELSE if(imodl(i).lt.0.or.iifix(iatm(i)).gt.0) then pop1(i)=popul(i,id) else III=IIFOR(ILTREF(I,ID)) POP1(I)=SBPSI(I,ID)*POP0(III) end if END IF if(iifix(iatm(i)).gt.0) pop1(i)=popul(i,id) if(ipzero(i,id).gt.0) pop1(i)=0. END DO C C set up the parameter IPZERO indicating that a population is "small" C and will subsequently be set to zero C IF(ITER.EQ.0) THEN LKIT=.TRUE. ELSE LKIT=KANT(ITER).EQ.0 .AND. ITER.LT.IACC ENDIF IF(LKIT) THEN DO IAT=1,NATOM POPM=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID) DO I=N0A(IAT),NKA(IAT) IF(POP1(I)/POPM.LT.POPZER) THEN POP1(I)=0. IPZERO(I,ID)=1 END IF END DO if(nrefs(iat,id).gt.n0a(iat)) then do i=nrefs(iat,id),n0a(iat),-1 if(ipzero(i,id).gt.0.and.ilk(i).gt.0) then do iii=nfirst(ilk(i)),nlast(ilk(i)) ipzero(iii,id)=1 pop1(iii)=0. end do end if end do end if END DO END IF C C if required (MODE=1), set up the global array POPUL C IF(MODE.NE.1) RETURN DO I=1,NLEVEL POPUL(I,ID)=POP1(I) END DO C C array of b-factors C DO I=1,NLEVEL BFAC(I,ID)=UN END DO IF(LTE.OR.IPSLTE.NE.0) RETURN DO ION=1,NION DO I=NFIRST(ION),NLAST(ION) IF(POPUL(NNEXT(ION),ID).GT.0..AND.IPZERO(I,ID).EQ.0) * BFAC(I,ID)=POPUL(I,ID)/(POPUL(NNEXT(ION),ID)*SBW(I)) END DO END DO C RETURN END C C C **************************************************************** C C SUBROUTINE PZERT C ================ C C driving routine for super-zeroing, i.e. detecting that C a given population is small throughout the whole C atmosphere, so it is removed completely from linearization C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' DIMENSION POPMA(MLEVEL),INDLEZ(MLEVEL),GZR(MLEVEL) c if(ioptab.lt.0) return C C super-zeroing of the individual levels C POPZRL=1.E5*POPZER NLNZX=0 DO IAT=1,NATOM N1=N0A(IAT) NK=NKA(IAT) DO II=N1,NK POPMA(II)=0. END DO c c set-up quantity POPMA(II), which is the maximum C (over depths) of the relative population of given C level II to the total population of the atom. C DO ID=1,ND POPM=0. DO II=N1,NK IF(POPUL(II,ID).GT.POPM) POPM=POPUL(II,ID) END DO DO II=N1,NK POPREL=POPUL(II,ID)/POPM IF(POPREL.GT.POPMA(II)) POPMA(II)=POPREL END DO END DO C C if POPMA(II) is small, level II is super-zeroed C DO II=N1,NK IPZERT(II)=0 IF(POPMA(II).LT.POPZRL) THEN IPZERT(II)=1 DO ID=1,ND IPZERO(II,ID)=1 POPUL(II,ID)=0. END DO ELSE IF(IIEXP(II).GT.0) THEN NLNZX=NLNZX+1 INDLEZ(NLNZX)=II END IF END IF END DO END DO c c now, check whether all populations within a group were C super-zeroed. If so, super-zero the whole group C DO II=1,NLVEXP GZR(II)=1. END DO DO I=1,NLEVEL II=IABS(IIEXP(I)) IF(II.NE.0) GZR(II)=GZR(II)*IPZERT(I) END DO NLVEXZ=0 DO II=1,NLVEXP IF(GZR(II).EQ.0) THEN IGZERT(II)=0 NLVEXZ=NLVEXZ+1 INDLGZ(NLVEXZ)=II IINONZ(II)=NLVEXZ ELSE IGZERT(II)=1 IINONZ(II)=0 END IF END DO NN=NN0-NLVEXP+NLVEXZ c RETURN END C C C **************************************************************** C C SUBROUTINE RATMAT(ID,IICAL,IMODE,A,B) C ===================================== C C Evaluation of the rate matrix C C More specifically, the set of statistical equilibrium + constraint C equations (see further) is represented as C C A * vector of populations = B C C (see Mihalas, 1978) pp.138-139 for details C C Constraint equations: C the rows corresponding to the last explicit level of each atom C (ie. a one-level ion representing the highest ionization degree C of the given atom) are the abundance definition equations C C Input: ID - depth index C Input transmitted by COMMON blocks: C RRU - array of upward radiative rates in all transitions C RRD - array of downward radiative rates in all transitions C COLRAT - array of collisional rates (only upward) in all C transitions C SBF - array of Saha-Boltzmann factors C USUM - array of upper sums C C Output: A - rate matrix C B - the right-hand-side vector C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' DIMENSION A(MLEVEL,MLEVEL),B(MLEVEL) DIMENSION AIJ(MTRANS),AJI(MTRANS) DIMENSION SBW(MLEVEL),IICAL(MLEVEL) DIMENSION LLTE(MLEVEL) c DATA ICOMP /0/ c if(ioptab.lt.0) return c if(ipslte.ne.0) then do itr=1,ntrans rru(itr,id)=0. rrd(itr,id)=0. drdt(itr,id)=0. end do end if c T=TEMP(ID) ANE=ELEC(ID) HKT=HK/T TK=HKT/H DO I=1,NLEVEL B(I)=0. SBW(I)=ANE*SBF(I)*WOP(I,ID) ILT=ILTION(IEL(I)) LLT=ILT.EQ.1.AND.IMODE.EQ.0 LLTE(I)=LLT.OR.LTE.OR.ILTLEV(I).GE.1.OR.ILT.GE.2 LLTE(I)=LLTE(I).OR.ID.GE.IDLTE DO J=1,NLEVEL A(J,I)=0. END DO END DO C C determine reference levels C CALL REFLEV(ID,IABS(IMODE)) C C ******* First part - the rows corresponding to true statistical C equilibrium equations C i.e. NLTE rate equations C C 1) simple expression in the case of LTE C DO IAT=1,NATOM IF(IIFIX(IAT).NE.1.OR.IMODE.LT.0) THEN NREFI=NREFS(IAT,ID) DO I=N0A(IAT),NKA(IAT) II=IABS(IICAL(I)) IF(I.NE.NREFI.AND.II.NE.0.AND.LLTE(I)) THEN A(II,II)=UN N=IABS(IICAL(ILTERF(I,ID))) A(II,N)=A(II,N)-SBLPSI(I,ID) END IF END DO END IF END DO C C 2) NLTE rate equation C IF(.NOT.LTE) THEN DO 40 ITR=1,NTRANS I=ILOW(ITR) IF(IIFIX(IATM(I)).EQ.1) GO TO 40 J=IUP(ITR) NKE=NNEXT(IEL(I)) C C upward total rate C AIJ(ITR)=(COLRAT(ITR,ID)+RRU(ITR,ID))*WOP(J,ID) C C downward total rate C IF(LINE(ITR)) THEN C C bound-bound C AJI(ITR)=(COLTAR(ITR,ID)+RRD(ITR,ID)* * G(I)/G(J)*EXP(HKT*FR0(ITR)))*WOP(I,ID) ELSE C C Bound-free C Quantity CORR is a factor which allows the bound-free C transition to end at an excited state C CORR=UN IF(NKE.NE.J) CORR=G(NKE)/G(J)* * EXP((ENION(NKE)-ENION(J))*TK) AJI(ITR)=COLTAR(ITR,ID)*WOP(I,ID)+ * RRD(ITR,ID)*SBW(I)*CORR END IF IF(IICAL(I).LT.0.AND.IICAL(J).LT.0) THEN AIJ(ITR)=AIJ(ITR)*SBPSI(I,ID) AJI(ITR)=AJI(ITR)*SBPSI(J,ID) END IF 40 CONTINUE C C Elements of the rate matrix C DO 41 ITR=1,NTRANS I=ILOW(ITR) IF(IIFIX(IATM(I)).EQ.1) GO TO 41 NREFI=NREFS(IATM(I),ID) J=IUP(ITR) II=IABS(IICAL(I)) JJ=IABS(IICAL(J)) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 41 IF(I.NE.NREFI.AND.II.GT.0.AND..NOT.LLTE(I)) THEN A(II,II)=A(II,II)+AIJ(ITR) IF(JJ.GT.0) THEN A(II,JJ)=A(II,JJ)-AJI(ITR) ELSE JJJ=IICAL(ILTREF(J,ID)) A(II,JJJ)=A(II,JJJ)-AJI(ITR)*SBPSI(J,ID) END IF END IF IF(J.NE.NREFI.AND.JJ.GT.0.AND..NOT.LLTE(J)) THEN A(JJ,JJ)=A(JJ,JJ)+AJI(ITR) IF(II.GT.0) THEN A(JJ,II)=A(JJ,II)-AIJ(ITR) ELSE III=IICAL(ILTREF(I,ID)) A(JJ,III)=A(JJ,III)-AIJ(ITR)*SBPSI(I,ID) END IF END IF 41 CONTINUE END IF C C reset the rate matrix elements for "small" populations C DO I=1,NLEVEL II=IICAL(I) IF(II.GT.0) THEN IF(IPZERO(I,ID).GT.0) THEN DO J=1,NLEVEL A(II,J)=0. END DO A(II,II)=1. END IF ELSE IF(II.LT.0) THEN IF(IGZERO(-II,ID).GT.0) THEN DO J=1,NLEVEL A(-II,J)=0. END DO A(-II,-II)=1. END IF END IF END DO C C ******** Second part - abundance definition equations C DO 100 IAT=1,NATOM IF(IIFIX(IAT).EQ.1.AND.IMODE.GE.0) GO TO 100 NREFII=IABS(IICAL(NREFS(IAT,ID))) DO I=N0A(IAT),NKA(IAT) IL=ILK(I) II=IICAL(I) IF(II.GT.0) THEN A(NREFII,II)=A(NREFII,II)+UN IF(IL.NE.0) A(NREFII,II)=A(NREFII,II)+ANE*USUM(IL) ELSE IF(II.LT.0) THEN A(NREFII,-II)=A(NREFII,-II)+SBPSI(I,ID) IF(IL.NE.0) A(NREFII,-II)=A(NREFII,-II)+ANE*USUM(IL)* * SBPSI(I,ID) ELSE III=IICAL(ILTREF(I,ID)) A(NREFII,III)=A(NREFII,III)+SBPSI(I,ID) END IF END DO B(NREFII)=B(NREFII)+ * DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID) 100 CONTINUE C RETURN END C C C ******************************************************************** C C SUBROUTINE RATMAL(ID,A,B) C C LTE RATE MATRIX (SAHA-BOLTZMANN EQS.) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' DIMENSION A(MLEVEL,MLEVEL),B(MLEVEL) C ANE=ELEC(ID) DO I=1,NLEVEL B(I)=0. DO J=1,NLEVEL A(J,I)=0. END DO END DO C DO IAT=1,NATOM N0I=N0A(IAT) NKI=NKA(IAT) N1I=NKI-1 NREFI=NKI DO I=N0I,N1I A(I,I)=1. N=NNEXT(IEL(I)) A(I,N)=-ANE*SBF(I)*WOP(I,ID) END DO DO I=N0I,NKI IL=ILK(I) A(NREFI,I)=UN IF(IL.NE.0) A(NREFI,I)=1.+ANE*USUM(IL) END DO B(NREFI)=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID) END DO C RETURN END C C C C **************************************************************** C C SUBROUTINE ELCOR(ID) C ==================== C C Procedure for a reevaluation of the electron number density C from the charge conservation equation in the formal solution C step (RESOLV) C This procedure is called only if LCHC=false, ie. if the charge C conservation equation is not part of the rate matrix C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' COMMON/ADCHAR/QADD(MDEPTH) c if(ioptab.lt.0.or.ioptab.gt.0) return C T=TEMP(ID) ANE=ELEC(ID) AN0=DENS(ID)/WMM(ID)+ANE C C basic iteration loop for solving simultaneously a non-linear set C of statistical equilibrium, charge conservation, and particle C conservation equations C KKK=0 1 KKK=KKK+1 IF(IFIXDE.GT.0) THEN AN=DENS(ID)/WMM(ID)+ANE ELSE AN=AN0 DENS(ID)=(AN-ANE)*WMM(ID) END IF C C determine QQ, the total charge due to non-explicit atoms C QQ=0. ANMNE1=WMM(ID)/DENS(ID) if(ifmol.eq.0.or.t.ge.tmolim) then CALL STATE(2,ID,T,ANE) QQ=Q*ABUND(IATREF,ID)/YTOT(ID)*DENS(ID)/WMM(ID) if(ioptab.gt.0) QQ=DENS(ID)/YTOT(ID)/WMM(ID) else aein=ane call moleq(id,t,an,aein,ane,enrg,entt,wm,0) qq=qadd(id) end if C RHS=QFIX(ID)+QQ DO IAT=1,NATOM IF(IIFIX(IAT).NE.1) THEN DO I=N0A(IAT),NKA(IAT) IL=ILK(I) CH=IZ(IEL(I))-1 IF(IL.GT.0) CH=IZ(IL)+(IZ(IL)-1)*USUM(IL)*ANE IF(IMODL(I).GE.0) RHS=RHS+CH*POPUL(I,ID) END DO END IF END DO C C new electron density C RHS=HALF*(ANE+RHS) ELEC(ID)=RHS IF(IFIXDE.EQ.0) DENS(ID)=WMM(ID)*(AN-ELEC(ID)) ANMA(ID)=DENS(ID)/WMM(ID) ANTO(ID)=ANMA(ID)+ELEC(ID) RELANE=(RHS-ANE)/ANE ANE=RHS C C second part of the iteration loop - recalculation of all C populations with new electron density C CALL STEQEQ(ID,POP,1) C C convergence criterion for electron density C IF(ABS(RELANE).LE.1.D-6) THEN CALL WNSTOR(ID) RETURN ENDIF C C if convergence is not achieved C IF(KKK.LT.10) GO TO 1 WRITE(6,601) ID,RELANE WRITE(10,601) ID,RELANE 601 FORMAT('0 SLOW CONVERGENCE OF ELCOR ID =',I4,' REL =',1PD10.3/) CALL WNSTOR(ID) RETURN END C C C **************************************************************** C C SUBROUTINE REFLEV(ID,IMODE) C =========================== C C determination of the global reference level, and C determination of the LTE reference levels and corresponding C quantities C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' DIMENSION XSBF(MLEVEL) if(ioptab.lt.0) return C C determination of the reference level (if required) C LREFP=.TRUE. LREFP=.false. IF(MODREF.GE.1) THEN IF(IMODE.EQ.1.AND.(ITER.LE.1.OR.KANT(ITER).EQ.0)) THEN DO IAT=1,NATOM PMAX=0. IREF=0 DO I=N0A(IAT),NKA(IAT) IF(POPUL(I,ID).GE.PMAX) THEN PMAX=POPUL(I,ID) IREF=I END IF END DO IF(IREF.NE.NKA(IAT).AND.IREF.NE.NFIRST(IEL(IREF))) * IREF=NFIRST(IEL(IREF)) IF(MODREF.EQ.2.AND.IREF.LT.NFIRST(IEL(NKA(IAT)))) * IREF=NFIRST(IEL(NKA(IAT))) NREF(IAT)=IREF LREFP=LREFP .AND. NREFS(IAT,ID).EQ.NREF(IAT) NREFS(IAT,ID)=NREF(IAT) END DO ELSE DO IAT=1,NATOM NREF(IAT)=NREFS(IAT,ID) END DO END IF ELSE DO IAT=1,NATOM LREFP=LREFP .AND. NREFS(IAT,ID).EQ.NREF(IAT) NREFS(IAT,ID)=NREF(IAT) END DO END IF C C set to the zeroing mode levels with SBF*ANE large; C check whether reference level is not zerod, and is so, re-establish C the reference level. C IF(ITER.LE.NITZER) THEN DO IAT=1,NATOM N1=N0A(IAT) NK=NKA(IAT) ISBMX=0 XSBMX=0. IREF=NREFS(IAT,ID) DO II=N1,NK IF(ITER.LE.NITZER) IPZERO(II,ID)=0 XSBF(II)=SBF(II)*ELEC(ID) IF(.NOT.LTE) THEN ITR=ITRA(II,NNEXT(IEL(II))) IF(ITR.GT.0) THEN IF(RRU(ITR,ID).GT.1.E-30) * XSBF(II)=SBF(II)*ELEC(ID)*RRD(ITR,ID)/RRU(ITR,ID) END IF END IF END DO IF(LTE) THEN IREF=N1 DO II=N1+1,NK IF(ILK(II).GT.0) THEN IREF=II IF(XSBF(II).GT.1.) GO TO 10 END IF END DO 10 CONTINUE NREFS(IAT,ID)=IREF NREF(IAT)=IREF END IF IF(IREF.GT.N0A(IAT)) THEN X=1. DO II=IREF-1,N1,-1 IF(ILK(II).GT.0.OR.II.EQ.N0A(IAT)) THEN X=X*XSBF(II) IF(X.LT.POPZR2) THEN DO III=N1,NLAST(IEL(II)) IPZERO(III,ID)=1 END DO GO TO 20 END IF END IF END DO END IF 20 CONTINUE IF(IREF.LT.NK) THEN X=1. DO II=IREF+1,NK IF(ILK(II).GT.0) THEN X=X*XSBF(NFIRST(ILK(II))) IF(X.GT.1./POPZR2) THEN NFIR=NFIRST(IEL(II)) IF(II.EQ.NK) NFIR=NK DO III=NFIR,NK IPZERO(III,ID)=1 END DO GO TO 30 END IF END IF END DO END IF 30 CONTINUE END DO END IF C C determination of the LTE reference levels and corresponding C quantities C ELEC1(ID)=UN/ELEC(ID) DO IAT=1,NATOM IFSUP=0 IREF=NREF(IAT) DO I=N0A(IAT),NKA(IAT) C C generalized LTE reference level formalism C IF(IABS(IMODL(I)).EQ.1.OR.IABS(IMODL(I)).EQ.2) THEN IN=NNEXT(IEL(I)) IF(I.LT.IREF.OR.POPUL(I,ID).LT.POPUL(IN,ID)) THEN ILTREF(I,ID)=IN SBPSI(I,ID)=SBF(I)*ELEC(ID)*WOP(I,ID)*BFAC(I,ID) DSBPST(I,ID)=DSBF(I) DSBPSN(I,ID)=ELEC1(ID) ELSE IF(I.GT.IREF) THEN I1=NFIRST(IEL(I)) ILTREF(I,ID)=I1 SBPSI(I,ID)=SBF(I)*WOP(I,ID)*BFAC(I,ID)/ * (SBF(I1)*WOP(I1,ID)*BFAC(I1,ID)) DSBPST(I,ID)=DSBF(I)-DSBF(I1) DSBPSN(I,ID)=0. END IF C C original scheme C ELSE IF(IABS(IMODL(I)).EQ.3.OR.IMODL(I).EQ.0) THEN ILTREF(I,ID)=NNEXT(IEL(I)) SBPSI(I,ID)=SBF(I)*ELEC(ID)*WOP(I,ID)*BFAC(I,ID) DSBPST(I,ID)=DSBF(I) DSBPSN(I,ID)=ELEC1(ID) ELSE IF(IABS(IMODL(I)).EQ.5) THEN IFSUP=1 END IF END DO C C super-reference level formalism C LRF=LTE.AND.IREF.NE.NKA(IAT) IF(IFSUP.EQ.1.OR.LRF) THEN XA=UN XT=0. XN=0. ILTREF(IREF,ID)=IREF IF(IREF.GT.N0A(IAT)) THEN DO I=IREF-1,N0A(IAT),-1 ILTREF(I,ID)=IREF SBPSI(I,ID)=XA*SBF(I)*ELEC(ID)*BFAC(I,ID)*WOP(I,ID) if(sbpsi(i,id).lt.popzr2) then sbpsi(i,id)=0. else DSBPST(I,ID)=XT+DSBF(I) DSBPSN(I,ID)=XN+ELEC1(ID) end if IF(I.EQ.NFIRST(IEL(I))) THEN XA=SBPSI(I,ID) XT=DSBPST(I,ID) XN=DSBPSN(I,ID) if(xn.eq.0.) ilk(i)=0 END IF END DO END IF C XA=UN XT=0. XN=0. IF(IREF.LT.NKA(IAT)) THEN IF(IREF.EQ.NLAST(IEL(IREF))) THEN XA=UN/(SBF(IREF)*BFAC(IREF,ID)*WOP(IREF,ID)*ELEC(ID)) XT=-DSBF(IREF) XN=-ELEC1(ID) END IF DO I=IREF+1,NKA(IAT)-1 ILTREF(I,ID)=IREF I1=NFIRST(IEL(I)) SBB1=UN/(SBF(I1)*BFAC(I1,ID)*WOP(I1,ID)) SBPSI(I,ID)=XA*SBF(I)*BFAC(I,ID)*WOP(I,ID)*SBB1 if(sbpsi(i,id).lt.popzr2) then sbpsi(i,id)=0. else DSBPST(I,ID)=XT+DSBF(I)-DSBF(I1) DSBPSN(I,ID)=XN end if IF(I.EQ.NLAST(IEL(I))) THEN XA=XA*SBB1*ELEC1(ID) XT=XT-DSBF(I1) XN=XN-ELEC1(ID) END IF END DO I=NKA(IAT) ILTREF(I,ID)=IREF SBPSI(I,ID)=XA DSBPST(I,ID)=XT DSBPSN(I,ID)=XN END IF END IF C C different meaning of SBPSI for IMODL=2, i.e. for levels C with fixed ratio of population to that of reference level C DO I=N0A(IAT),NKA(IAT) IF(IABS(IMODL(I)).EQ.2) THEN IF(POPUL(I,ID).EQ.0..OR.POPUL(ILTREF(I,ID),ID).EQ.0.) * THEN IN=NNEXT(IEL(I)) IF(I.LT.IREF.OR.POPUL(I,ID).LT.POPUL(IN,ID)) THEN ILTREF(I,ID)=IN SBPSI(I,ID)=SBF(I)*ELEC(ID)*WOP(I,ID)*BFAC(I,ID) ELSE IF(I.GT.IREF) THEN I1=NFIRST(IEL(I)) ILTREF(I,ID)=I1 SBPSI(I,ID)=SBF(I)*WOP(I,ID)*BFAC(I,ID)/ * (SBF(I1)*WOP(I1,ID)*BFAC(I1,ID)) END IF ELSE SBPSI(I,ID)=POPUL(I,ID)/POPUL(ILTREF(I,ID),ID) END IF DSBPST(I,ID)=0. DSBPSN(I,ID)=0. END IF END DO C C different meaning of SBPSI for IMODL=6 or 7, i.e. for levels C with fixed ratio of population to that of a "guiding" level C if(imode.eq.1) then DO I=N0A(IAT),NKA(IAT) IF(IABS(IMODL(I)).EQ.6) THEN ILTREF(I,ID)=IGUIDE(I) if(POPUL(ILTREF(I,ID),ID).gt.0.) then SBPSI(I,ID)=POPUL(I,ID)/POPUL(ILTREF(I,ID),ID) end if DSBPST(I,ID)=0. DSBPSN(I,ID)=0. END IF END DO end if END DO C C true LTE reference level C DO IAT=1,NATOM DO I=N0A(IAT),NKA(IAT) IF(IABS(IMODL(I)).LT.6) THEN ILTERF(I,ID)=ILTREF(I,ID) SBLPSI(I,ID)=SBPSI(I,ID) ELSE ILTERF(I,ID)=NNEXT(IEL(I)) SBLPSI(I,ID)=SBF(I)*ELEC(ID)*WOP(I,ID)*BFAC(I,ID) END IF END DO END DO RETURN END C C C **************************************************************** C C SUBROUTINE LEVGRP(ID,IICAL,IMODE,POPP) C ====================================== C C determination of the total population of a the level groups; C and of relative populations of the group consituents C C Input: ID - depth index C IICAL - array of level grouping parameters (IIEXP of IIFOR) C IMODE - a mode of input populations: C = 0 - input populations are POPUL(I,ID) C = 1 - input populations are given by the last C formal parameter POP C POP - array of input populations (for IMODE=1 only) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' DIMENSION POPP(MLEVEL),IICAL(MLEVEL) if(ioptab.lt.0) return C DO I=1,NLVEXP POPGRP(I)=0. igzero(i,id)=0 END DO IF(IMODE.EQ.0) THEN DO I=1,NLEVEL POPP(I)=POPUL(I,ID) END DO END IF C C total population of the group C DO I=1,NLEVEL II=IABS(IICAL(I)) IF(II.NE.0) POPGRP(II)=POPGRP(II)+POPP(I) END DO C C ratios of the popultions of the individual group C components w.r.t the total group populations C this quantity remains fixed during linearization C DO I=1,NLEVEL II=IICAL(I) IF(II.LT.0) THEN IF(POPGRP(-II).GT.0.) THEN SBPSI(I,ID)=POPP(I)/POPGRP(-II) ELSE SBPSI(I,ID)=0. IGZERO(-II,ID)=1 END IF END IF END DO C C zeroing of the whole group - if the total group population C is smaller than POPZER times the total atomic population C IF(ITER.EQ.0) THEN LKIT=.TRUE. ELSE LKIT=KANT(ITER).EQ.0 .AND. ITER.LT.IACC ENDIF IF(LKIT) THEN DO I=1,NLEVEL IAT=IATM(I) POPM=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID) II=IICAL(I) IF(II.LT.0) THEN IF(POPGRP(-II)/POPM.LT.POPZER) THEN POPGRP(-II)=0. IGZERO(-II,ID)=1 END IF rpop0(-ii,id)=popgrp(-ii)/popm else if(ii.gt.0) then rpop0(ii,id)=popgrp(ii)/popm END IF END DO END IF C RETURN END C C C **************************************************************** C C SUBROUTINE RATES1(IMOR) C ====================== C C Evaluation of radiative rates C C Output (transferred by COMMON blocks): C RRU(IT,ID) - upward radiative rate in transition IT and C depth ID C RRD(IT,ID) - analogously the downward rate; more precisely C the exact downward rate is given by: C lines : RRD * stat.weight(lower)/stat.weight(upper) C continua: RRD * n(elec) * Saha-Boltzmann factor C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' DIMENSION RBNE(MDEPTH) C DIMENSION EHKL(MFREQL) C C zero the rates C DO ID=1,ND PRADT(ID)=0. PRADA(ID)=0. FLRD(ID)=0. DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. END DO DO ITRP=1,NTRPRD PJBAR(ITRP,ID)=0. END DO END DO PRD0=0. C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 100 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GOTO 100 FR=FREQ(IJ) W0=W0E(IJ) WW=W(IJ) CALL OPACF1(IJ) IF(IMOR.EQ.0) THEN CALL RTEFR1(IJ) ELSE RAD1(ID)=RAD(IJ,ID) END IF IF(LROSS) CALL ROSSTD(IJ) FLRD(1)=FLRD(1)+WW*FH(IJ)*RAD1(1)-WW*HEXTRD(IJ) DO ID=2,ND DT=UN/(ABSOT(ID)+ABSOT(ID-1))/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLRD(ID)=FLRD(ID)+WW*FL END DO if(ioptab.lt.0) go to 100 C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND RBNE(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR) DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) IF(IFWOP(II).GE.0) THEN ICDW=MCDW(ITR) IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE IMER=IMRG(II) SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNE(ID) 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) DO 50 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50 SGW=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW*RBNE(ID) 50 CONTINUE c itrprd=iprd(itr) if(itrprd.gt.0) then s=un/(0.02654*osc0(itr)) do id=1,nd sg=prflin(id,ij)*s pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id) end do end if c ENDIF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 90 IJ0=IFR0(ITR) II=ILOW(ITR) JJ=IUP(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO 80 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80 SGW=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW*RBNE(ID) 80 CONTINUE c itrprd=iprd(itr) if(itrprd.gt.0) then s=un/(0.02654*osc0(itr)) do id=1,nd SG=(A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0))*s pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id) end do end if c 90 CONTINUE 100 CONTINUE C DO ID=1,ND IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) END DO END IF END DO C C radiation pressure C DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO END IF c RETURN END C C C C **************************************************************** C SUBROUTINE RATSP1 C ================= C C Evaluation of "preconditioned" radiative rates C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' PARAMETER(PGRD=4.1916825D-10) DIMENSION EHK(MDEPTH) C DIMENSION EHKL(MFREQL) C C zero the rates C DO ID=1,ND PRADT(ID)=0. PRADA(ID)=0. FLRD(ID)=0. DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. END DO DO ITRP=1,NTRPRD PJBAR(ITRP,ID)=0. END DO END DO PRD0=0. C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 500 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 500 FR=FREQ(IJ) W0=W0E(IJ) WW=W(IJ) CALL OPACF1(IJ) CALL RTEFR1(IJ) IF(LROSS) CALL ROSSTD(IJ) FLUXW=W(IJ)*RAD1(1)*FH(IJ) GRADF(1,IJ)=FLUXW*ABSO1(1)/DENS(1)*PGRD FLRD(1)=FLRD(1)+WW*FH(IJ)*RAD1(1)-WW*HEXTRD(IJ) DO ID=2,ND DT=UN/(ABSOT(ID)+ABSOT(ID-1))/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLRD(ID)=FLRD(ID)+WW*FL END DO if(ioptab.lt.0) go to 500 C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND EHK(ID)=EXP(-HKT1(ID)*FR) if(ilpsct.eq.0) then ALAB(ID)=ALI1(ID)/(ABSO1(ID)-ELSCAT(ID)) else ALAB(ID)=ALI1(ID)/ABSO1(ID) end if DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) IF(IFWOP(II).GE.0) THEN ICDW=MCDW(ITR) IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE IMER=IMRG(II) SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RLAM=SG*ALAB(ID) ELIN=EMTRA(ITR,ID)*EHK(ID) RADRES=RAD1(ID)-RLAM*BNUE(IJ)*ELIN BNURES=BNUE(IJ)*(UN-RLAM*(ABTRA(ITR,ID)-ELIN)) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RADRES RRD(ITR,ID)=RRD(ITR,ID)+SGW0*(RADRES+BNURES)*EHK(ID) 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) DO 50 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50 SG=PRFLIN(ID,IJ) SGW0=SG*W0 RLAM=SG*ALAB(ID) ELIN=EMTRA(ITR,ID)*EHK(ID) RADRES=RAD1(ID)-RLAM*BNUE(IJ)*ELIN BNURES=BNUE(IJ)*(UN-RLAM*(ABTRA(ITR,ID)-ELIN)) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RADRES RRD(ITR,ID)=RRD(ITR,ID)+SGW0*(RADRES+BNURES)*EHK(ID) 50 CONTINUE c itrprd=iprd(itr) if(itrprd.gt.0) then s=un/(0.02654*osc0(itr)) do id=1,nd sg=prflin(id,ij)*s pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id) end do end if c ENDIF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) go to 90 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 II=ILOW(ITR) JJ=IUP(ITR) DO 80 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80 SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) SGW0=SG*W0 RLAM=SG*ALAB(ID) ELIN=EMTRA(ITR,ID)*EHK(ID) RADRES=RAD1(ID)-RLAM*BNUE(IJ)*ELIN BNURES=BNUE(IJ)*(UN-RLAM*(ABTRA(ITR,ID)-ELIN)) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RADRES RRD(ITR,ID)=RRD(ITR,ID)+SGW0*(RADRES+BNURES)*EHK(ID) 80 CONTINUE c itrprd=iprd(itr) if(itrprd.gt.0) then s=un/(0.02654*osc0(itr)) do id=1,nd SG=(A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0))*s pjbar(itrprd,id)=pjbar(itrprd,id)+sg*w(ij)*rad1(id) end do end if c 90 CONTINUE 100 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 200 DO 190 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) II=ILOW(ITR) JJ=IUP(ITR) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 150 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150 SG=PRFLIN(ID,KJ) SGW0=SG*W0 RLAM=SG*ALAB(ID) ELIN=EMTRA(ITR,ID)*EHK(ID) RADRES=RAD1(ID)-RLAM*BNUE(IJ)*ELIN BNURES=BNUE(IJ)*(UN-RLAM*(ABTRA(ITR,ID)-ELIN)) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RADRES RRD(ITR,ID)=RRD(ITR,ID)+SGW0*(RADRES+BNURES)*EHK(ID) 150 CONTINUE ELSE DO 160 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 160 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) SGW0=SG*W0 RLAM=SG*ALAB(ID) ELIN=EMTRA(ITR,ID)*EHK(ID) RADRES=RAD1(ID)-RLAM*BNUE(IJ)*ELIN BNURES=BNUE(IJ)*(UN-RLAM*(ABTRA(ITR,ID)-ELIN)) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RADRES RRD(ITR,ID)=RRD(ITR,ID)+SGW0*(RADRES+BNURES)*EHK(ID) 160 CONTINUE END IF 190 CONTINUE 200 CONTINUE END IF 500 CONTINUE C DO ID=1,ND IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) END DO END IF END DO C C radiation pressure C PRDX=1. DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID) IF(PRDR.LT.PRDX) PRDX=PRDR END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK IF(LFIN) WRITE(10,1100) PRDX,ITER 1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4) C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO END IF RETURN END C C C C **************************************************************** C C SUBROUTINE ALIST1 C ================= C C Evaluation of all nexcessary ALI parameters + radiative rates C (the routine is analogous to RATES1) C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' DIMENSION EXX(MDEPTH),RBNU(MDEPTH),RBNUF(MDEPTH) C DIMENSION EHKL(MFREQL),EHKLF(MFREQL) C C zero the rates and other quantities C DO ID=1,ND REIT(ID)=0. REIN(ID)=0. REIX(ID)=0. AREIT(ID)=0. AREIN(ID)=0. CREIT(ID)=0. CREIN(ID)=0. CREIX(ID)=0. REDT(ID)=0. REDTM(ID)=0. REDTP(ID)=0. REDN(ID)=0. REDNM(ID)=0. REDNP(ID)=0. REDX(ID)=0. REDXM(ID)=0. REDXP(ID)=0. HEIT(ID)=0. HEITM(ID)=0. HEITP(ID)=0. HEIN(ID)=0. HEINM(ID)=0. HEINP(ID)=0. EHET(ID)=0. EHEN(ID)=0. ERET(ID)=0. EREN(ID)=0. FCOOLI(ID)=0. FLFIX(ID)=0. FLEXP(ID)=0. FLRD(ID)=0. FPRD(ID)=0. PRADT(ID)=0. PRADA(ID)=0. DO II=1,NLVEXP HEIP(II,ID)=0. REIP(II,ID)=0. AREIP(II,ID)=0. CREIP(II,ID)=0. REDP(II,ID)=0. REDPM(II,ID)=0. HEIPM(II,ID)=0. REDPP(II,ID)=0. HEIPP(II,ID)=0. EHEP(II,ID)=0. EREP(II,ID)=0. END DO DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. DRDT(ITR,ID)=0. END DO END DO PRD0=0. C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 100 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 100 FR=FREQ(IJ) W0=W0E(IJ) CALL OPACFD(IJ) CALL RTEFR1(IJ) CALL ALIFR1(IJ) IF(LROSS) CALL ROSSTD(IJ) if(ioptab.lt.0) go to 100 C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND EXX(ID)=EXP(-HKT1(ID)*FR) RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID) RBNUF(ID)=RBNU(ID)*FR*HKT21(ID) DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) IF(IFWOP(II).GE.0) THEN ICDW=MCDW(ITR) IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE IMER=IMRG(II) SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) DO 50 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50 SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) 50 CONTINUE ENDIF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 90 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 II=ILOW(ITR) JJ=IUP(ITR) DO 80 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80 SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) 80 CONTINUE 90 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 100 DO 95 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 210 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 210 SGW0=PRFLIN(ID,KJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) 210 CONTINUE ELSE DO 220 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 220 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) 220 CONTINUE END IF 95 CONTINUE END IF 100 CONTINUE C C multiply some quantities by frequency-independent constants C DO ID=1,ND REDX(ID)=REDX(ID)*WMM(ID)*DENS1(ID)*DENS1(ID) IF(ID.GT.1) REDXM(ID)=REDXM(ID)*WMM(ID)* * DENS1(ID-1)*DENS1(ID-1) FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID) IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) DRDT(ITR,ID)=DRDT(ITR,ID)*CRSW(ID) END DO END IF END DO C C radiation pressure C PRDX=1. DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID) IF(PRDR.LT.PRDX) PRDX=PRDR END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK IF(LFIN) WRITE(10,1100) PRDX,ITER 1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4) C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO if(ioptab.lt.0.and.ifryb.gt.0) then do id=1,nd abrosd(id)=abrosd(id)*dens(id) end do end if call rosstd(0) END IF c RETURN END C C C **************************************************************** C C C SUBROUTINE ALIST2 C ================= C C Evaluation of all nexcessary ALI parameters + radiative rates C (the routine is analogous to RATES1) C a variant for derivatives of the rate matrix w.r.t. populations C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' DIMENSION EXX(MDEPTH),RBNU(MDEPTH),RBNUF(MDEPTH) C DIMENSION EHKL(MFREQL),EHKLF(MFREQL) C C zero the rates and other quantities C DO ID=1,ND REIT(ID)=0. REIN(ID)=0. REIX(ID)=0. AREIT(ID)=0. AREIN(ID)=0. CREIT(ID)=0. CREIN(ID)=0. CREIX(ID)=0. REDT(ID)=0. REDTM(ID)=0. REDTP(ID)=0. REDN(ID)=0. REDNM(ID)=0. REDNP(ID)=0. REDX(ID)=0. REDXM(ID)=0. REDXP(ID)=0. HEIT(ID)=0. HEITM(ID)=0. HEITP(ID)=0. HEIN(ID)=0. HEINM(ID)=0. HEINP(ID)=0. EHET(ID)=0. EHEN(ID)=0. ERET(ID)=0. EREN(ID)=0. FCOOLI(ID)=0. FLFIX(ID)=0. FLEXP(ID)=0. FLRD(ID)=0. FPRD(ID)=0. PRADT(ID)=0. PRADA(ID)=0. DO II=1,NLVEXP HEIP(II,ID)=0. REIP(II,ID)=0. AREIP(II,ID)=0. CREIP(II,ID)=0. REDP(II,ID)=0. REDPM(II,ID)=0. HEIPM(II,ID)=0. REDPP(II,ID)=0. HEIPP(II,ID)=0. APT(II,ID)=0. APN(II,ID)=0. DO JJ=1,NLVEXP APP(JJ,II,ID)=0. END DO END DO DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. DRDT(ITR,ID)=0. END DO END DO PRD0=0. C dedm1=dm(1)/dens(1) IF (IRDER.EQ.3) THEN C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 100 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 100 FR=FREQ(IJ) W0=W0E(IJ) LRDER=IJALI(IJ).GT.0 CALL OPACFD(IJ) CALL RTEFR1(IJ) CALL ALIFR1(IJ) IF(LROSS) CALL ROSSTD(IJ) if(ioptab.lt.0) go to 100 C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND EXX(ID)=EXP(-HKT1(ID)*FR) RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID) RBNUF(ID)=RBNU(ID)*FR*HKT21(ID) DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) IF(IFWOP(II).GE.0) THEN ICDW=MCDW(ITR) IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE IMER=IMRG(II) SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 IE=IABS(IIEXP(II)) JJ=IUP(ITR) JE=IABS(IIEXP(JJ)) NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) DO 50 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50 SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 50 CONTINUE c 55 CONTINUE ENDIF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 90 II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO 80 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80 SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 80 CONTINUE 90 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 100 DO 95 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 510 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 510 SGW0=PRFLIN(ID,KJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 510 CONTINUE ELSE DO 520 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 520 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 520 CONTINUE END IF 95 CONTINUE END IF 100 CONTINUE C ELSE IF (IRDER.EQ.1) THEN C DO 200 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 200 FR=FREQ(IJ) W0=W0E(IJ) LRDER=IJALI(IJ).GT.0 CALL OPACFD(IJ) CALL RTEFR1(IJ) CALL ALIFR1(IJ) C C --------------------- C Continuum transitions C --------------------- C DO 120 ID=1,ND EXX(ID)=EXP(-HKT1(ID)*FR) RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID) RBNUF(ID)=RBNU(ID)*FR*HKT21(ID) DO 110 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 110 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 110 JC=ITRA(JJ,II) ICDW=MCDW(ITR) IMER=IMRG(II) IF(IFWOP(II).GE.0) THEN IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 IE=IABS(IIEXP(II)) JJ=IUP(ITR) JE=IABS(IIEXP(JJ)) NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) END IF END IF 110 CONTINUE 120 CONTINUE C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) DO 150 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150 SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) END IF END IF 150 CONTINUE c 155 CONTINUE ENDIF IF(NLINES(IJ).LE.0) GO TO 200 C C the "overlapping" lines at the given frequency C DO 190 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 190 II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) IJ0=IFR0(ITR) DO 160 IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 170 END IF 160 CONTINUE 170 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO 180 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 180 SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) END IF END IF 180 CONTINUE 190 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 200 DO 195 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 610 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 610 SGW0=PRFLIN(ID,KJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) END IF END IF 610 CONTINUE ELSE DO 620 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 620 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN APT(IE,ID)=APT(IE,ID)+APFR*DSFDT(ID) APN(IE,ID)=APN(IE,ID)+APFR*DSFDN(ID) END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN APT(JE,ID)=APT(JE,ID)-APFR*DSFDT(ID) APN(JE,ID)=APN(JE,ID)-APFR*DSFDN(ID) END IF END IF 620 CONTINUE END IF 195 CONTINUE END IF 200 CONTINUE C ELSE IF (IRDER.EQ.2) THEN C DO 300 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 300 FR=FREQ(IJ) W0=W0E(IJ) LRDER=IJALI(IJ).GT.0 CALL OPACFD(IJ) CALL RTEFR1(IJ) CALL ALIFR1(IJ) C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND EXX(ID)=EXP(-HKT1(ID)*FR) RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXX(ID) RBNUF(ID)=RBNU(ID)*FR*HKT21(ID) DO 210 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 210 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 210 JC=ITRA(JJ,II) ICDW=MCDW(ITR) IMER=IMRG(II) IF(IFWOP(II).GE.0) THEN IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 IE=IABS(IIEXP(II)) JJ=IUP(ITR) JE=IABS(IIEXP(JJ)) NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 210 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) DO 250 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 250 SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 250 CONTINUE ENDIF IF(NLINES(IJ).LE.0) GO TO 300 C C the "overlapping" lines at the given frequency C DO 290 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 290 II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 270 END IF END DO 270 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO 280 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 280 SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0. * AND.IABS(IMODL(II)).NE.4) THEN DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 280 CONTINUE 290 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 300 DO 295 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) II=ILOW(ITR) JJ=IUP(ITR) IE=IABS(IIEXP(II)) JE=IABS(IIEXP(JJ)) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 710 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 710 SGW0=PRFLIN(ID,KJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 710 CONTINUE ELSE DO 720 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 720 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) DRDT(ITR,ID)=DRDT(ITR,ID)+SGW0*RBNUF(ID) IF(LRDER) THEN APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EXX(ID))*SGW0 NREFI=NREFS(IATM(II),ID) IF(IE.GT.0.AND.II.NE.NREFI.AND.ILTLEV(II).LE.0) THEN DO KK=1,NLVEXP APP(KK,IE,ID)=APP(KK,IE,ID)+APFR*DSFDP(KK,ID) END DO END IF IF(JE.GT.0.AND.JJ.NE.NREFI.AND.ILTLEV(JJ).LE.0 * .AND.IABS(IMODL(II)).NE.4) THEN DO KK=1,NLVEXP APP(KK,JE,ID)=APP(KK,JE,ID)-APFR*DSFDP(KK,ID) END DO END IF END IF 720 CONTINUE END IF 295 CONTINUE END IF 300 CONTINUE C ELSE CALL QUIT(' Invalid IRDER - ALIST2',irder,irder) END IF C C multiply some quantities by frequency-independent constants C DO ID=1,ND REDX(ID)=REDX(ID)*WMM(ID)*DENS1(ID)*DENS1(ID) IF(ID.GT.1) REDXM(ID)=REDXM(ID)*WMM(ID)* * DENS1(ID-1)*DENS1(ID-1) FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID) IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) DRDT(ITR,ID)=DRDT(ITR,ID)*CRSW(ID) END DO C IF(LRDER) THEN IF(IRDER.GT.0) THEN DO II=1,NLVEXP APT(II,ID)=APT(II,ID)*CRSW(ID) APN(II,ID)=APN(II,ID)*CRSW(ID) DO JJ=1,NLVEXP APP(JJ,II,ID)=APP(JJ,II,ID)*CRSW(ID) END DO END DO END IF END IF END DO C C radiation pressure C PRDX=1. DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID) IF(PRDR.LT.PRDX) PRDX=PRDR END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK IF(LFIN) WRITE(10,1100) PRDX,ITER 1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4) C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO if(ioptab.lt.0.and.ifryb.gt.0) then do id=1,nd abrosd(id)=abrosd(id)*dens(id) end do end if call rosstd(0) END IF c RETURN END C C C **************************************************************** C C SUBROUTINE ALISK1 C ================= C C Simplified routine ALIST1 for Kantorovich iteration C C Evaluation of all nexcessary ALI parameters + radiative rates C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' DIMENSION RBNU(MDEPTH) C DIMENSION EHKL(MFREQL) C C zero the rates and other quantities (subr. NULL) C DO ID=1,ND FCOOLI(ID)=0. FLFIX(ID)=0. FPRD(ID)=0. FLRD(ID)=0. PRADT(ID)=0. PRADA(ID)=0. DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. END DO END DO PRD0=0. C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 100 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 100 FR=FREQ(IJ) W0=W0E(IJ) CALL OPACF1(IJ) IF(IJEX(IJ).GT.0) THEN IJE=IJEX(IJ) DO ID=1,ND ABSOEX(IJE,ID)=ABSO1(ID) EMISEX(IJE,ID)=EMIS1(ID) SCATEX(IJE,ID)=SCAT1(ID) END DO END IF CALL RTEFR1(IJ) CALL ALIFRK(IJ) IF(LROSS) CALL ROSSTD(IJ) if(ioptab.lt.0) go to 100 C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR) DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) ICDW=MCDW(ITR) IMER=IMRG(II) IF(IFWOP(II).GE.0) THEN IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) DO ID=1,ND SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) END DO END IF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 90 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO ID=1,ND SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) END DO 90 CONTINUE 100 CONTINUE C C multiply some quantities by frequency-independent constants C DO ID=1,ND FCOOL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID) IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) END DO END IF END DO C C radiation pressure C PRDX=1. DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID) IF(PRDR.LT.PRDX) PRDX=PRDR END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK IF(LFIN) WRITE(10,1100) PRDX,ITER 1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4) C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE ALISK2 C ================= C C Simplified routine ALISET for Kantorovich iteration C C Evaluation of all nexcessary ALI parameters + radiative rates C (the routine is analogous to RATES) C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' DIMENSION RBNU(MDEPTH) C DIMENSION EHKL(MFREQL) C C zero the rates and other quantities C DO ID=1,ND FCOOLI(ID)=0. FLFIX(ID)=0. FLEXP(ID)=0. FPRD(ID)=0. FLRD(ID)=0. PRADT(ID)=0. PRADA(ID)=0. DO ITR=1,NTRANS RRU(ITR,ID)=0. RRD(ITR,ID)=0. END DO END DO PRD0=0. C LROSS=NDRE.LE.0.AND.ITER.EQ.1.OR.LFIN IF(HMIX0.GT.0.) LROSS=.TRUE. IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. END DO END IF C DO 100 IJ=1,NFREQ IF(IJX(IJ).EQ.-1) GO TO 100 FR=FREQ(IJ) W0=W0E(IJ) CALL OPACF1(IJ) CALL RTEFR1(IJ) CALL ALIFRK(IJ) IF(LROSS) CALL ROSSTD(IJ) if(ioptab.lt.0) go to 100 IF(IJEX(IJ).GT.0) THEN IJE=IJEX(IJ) DO ID=1,ND ABSOEX(IJE,ID)=ABSO1(ID) EMISEX(IJE,ID)=EMIS1(ID) SCATEX(IJE,ID)=SCAT1(ID) END DO END IF C C --------------------- C Continuum transitions C --------------------- C DO ID=1,ND RBNU(ID)=(RAD1(ID)+BNUE(IJ))*EXP(-HKT1(ID)*FR) DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 II=ILOW(ITR) JJ=IUP(ITR) IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 10 JC=ITRA(JJ,II) IF(IFWOP(II).GE.0) THEN ICDW=MCDW(ITR) IF(ICDW.GE.1) SG=SG*DWF1(ICDW,ID) ELSE IMER=IMRG(II) SG=SGMG(IMER,ID) ENDIF SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 10 CONTINUE END DO C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) DO 50 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 50 SGW0=PRFLIN(ID,IJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 50 CONTINUE END IF IF(NLINES(IJ).LE.0) GO TO 100 C C the "overlapping" lines at the given frequency C DO 90 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) go to 90 II=ILOW(ITR) JJ=IUP(ITR) IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0))*W0 A2=W0-A1 DO 80 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 80 SGW0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 80 CONTINUE 90 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 100 DO 190 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) II=ILOW(ITR) JJ=IUP(ITR) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 150 ID=1,ND IF(IPZERO(II,ID).NE.0.OR.IPZERO(JJ,ID).NE.0) GO TO 150 SGW0=PRFLIN(ID,KJ)*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 150 CONTINUE ELSE DO 160 ID=1,ND IF(IPZERO(II,ID).NE.0.OR. * IPZERO(JJ,ID).NE.0) GO TO 160 KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))* * SIGFE(KJD+1,KJ)) SGW0=SG*W0 RRU(ITR,ID)=RRU(ITR,ID)+SGW0*RAD1(ID) RRD(ITR,ID)=RRD(ITR,ID)+SGW0*RBNU(ID) 160 CONTINUE END IF 190 CONTINUE END IF 100 CONTINUE C C multiply some quantities by frequency-independent constants C DO ID=1,ND FCO OL(ID)=REINT(ID)*FCOOLI(ID)-REDIF(ID)*FLFIX(ID) IF(CRSW(ID).NE.UN) THEN DO ITR=1,NTRANS RRU(ITR,ID)=RRU(ITR,ID)*CRSW(ID) RRD(ITR,ID)=RRD(ITR,ID)*CRSW(ID) END DO END IF END DO C C radiation pressure C PRDX=1. DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK PRADA(ID)=PRADA(ID)*PCK if(prada(id).gt.0.) PRDR=PRADT(ID)/PRADA(ID) IF(PRDR.LT.PRDX) PRDX=PRDR END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK IF(LFIN) WRITE(10,1100) PRDX,ITER 1100 FORMAT(' PRAD MIN RATIO ',F10.6,I4) C C Rosseland mean opacity C IF(LROSS) THEN DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/(ABROSD(ID)*DENS(ID)) END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE DOPGAM(ITR,ID,T,DOP,AGAM) C ==================================== C C Doppler width and the Voigt damping parameter for the line ITR C C Input: C ITR - index of transition C ID - depth index C T - temperature C Output: C DOP - Doppler width C AGAM - total damping parameter (in units of Doppler widths; C ie. = gam/4pi/DOP, where gam is the "physical" damping C parameter expresed in circular frequencies) C C Damping parameter is calculated only for transitions with C |IPROF(ITR)| = 1 (ie. those for which either Voigt or some non- C standard profile is assumed) C Determination of AGAM: C is controlled by input parameters transmitted by COMMON/VOIPAR: C C GAMAR(IP) - for > 0 - has the meaning of natural damping C parameter (=Einstein coefficient for C spontaneous emission) C = 0 - classical natural damping assumed C < 0 - damping is given by a non-standard, C user supplied procedure GAMSP C STARK1(IP) - = 0 - Stark broadening neglected C < 0 - scaled classical expression C (ie gam = -STARK1 * classical Stark) C > 0 - Stark broadening given by C n(el)*[STARK1*T**STARK2 + STARK3] C STRAK2, STARK3 - see above C VDWH(IP) - .le.0 - Van der Waals broadening neglected C > 0 - scaled classical expression C C the corresponding index IP is given by ITRA(IUP(ITR),ILOW(ITR)) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (BOL2=2.76108D-16, CIN=UN/2.997925D10) PARAMETER (R02=2.5,R12=45.,OP4=0.4,VW0=4.5E-9) C J=IUP(ITR) IAT=IATM(J) FR=FR0(ITR) IE=IEL(J) AM=BOL2/AMASS(IAT)*T AGAM=0. C C Doppler width C DOP=FR*CIN*SQRT(AM+VTURBS(ID)*VTURBS(ID)) C C ----------------- C damping parameter - only for IPROF = 1 C IF(IABS(IPROF(ITR)).NE.1) RETURN IP=ITRA(J,ILOW(ITR)) ANE=ELEC(ID) C C Natural (radiation) broadening C If(GAMAR(IP).GT.0.) THEN AGAM=GAMAR(IP) ELSE IF (GAMAR(IP).EQ.0.) THEN AGAM=2.47342D-22*FR*FR ELSE C C Non-standard expression - for the total damping parameter, C not only for radiation damping C CALL GAMSP(ITR,T,ANE,AGAM) END IF C C Stark broadening C Z=FLOAT(IZ(IE)) ANFF=Z*Z*EH/ENION(J) IF(STARK1(IP).EQ.0.) THEN AGAM=AGAM+1.D-8*ANFF**2.5*ANE ELSE IF (STARK1(IP).GT.0.) THEN AGAM=AGAM+ANE*(STARK1(IP)*T**STARK2(IP)+STARK3(IP)) END IF C C Van der Waals broadening C IF(IELH.GT.0) THEN AH=POPUL(NFIRST(IELH),ID) ELSE AH=DENS(ID)/WMM(ID)/YTOT(ID) END IF IF(IELHE1.NE.0) THEN AHE=AH*ABUND(IATHE,ID) ELSE AHE=AH*ABNDD(2,ID) END IF VDWC=(T*1.E-4)**0.3*(AH+0.42*AHE) IF(VDWH(IP).GE.0.) THEN IF(IAT.LT.21) THEN R2=R02*(ANFF/Z)**2 ELSE IF(IAT.LT.45) then R2=(R12-FLOAT(IAT))/Z ELSE R2=0.5 END IF GW0=VDWC*VW0*R2**OP4 AGAM=AGAM+GW0 ELSE IF (VDWH(IP).LT.0.) THEN GW0=VDWC*EXP(2.3025851*VDWH(IP)) AGAM=AGAM+GW0 END IF c C Total damping parameter in units of Doppler widths C AGAM=AGAM/DOP/12.566370614 RETURN END C C C **************************************************************** C C SUBROUTINE GAMSP(ITR,T,ANE,AGAM) C ================================ C C Non-standard expression for the damping parameter - C a user-supplied procedure C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' AGAM=0. if(itr.le.0) return t1=t ane1=ane RETURN END C C C **************************************************************** C C FUNCTION PROFIL(FR,A,DOP,ITR,IP,ID) C =================================== C C Standard absorption profile - normalized to unity C C Input: C FR - frequency C A - Voigt damping parameter C DOP - Doppler width C ITR - transition index C ID - depth index C C Profile is evaluated differently for different IP=IPROF(ITR): C IP = 0 - Doppler profile C IP = 1 - Voigt profile C IP = 2 - approximate Stark (+ Doppler) profile for hydrogen lines; C however, the routine is called with IP=2 only from C START, i.e. for the initialization C IP > 9 - non-standard profile, given by a user-supplied C procedure PROFSP C IP = 12 - approximate Stark profile for hydrogen lines C (Klaus Wener's routines) C C V - frequency displacement from the line center in units of C Doppler width C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal PARAMETER (PISQ=1.77245385090551D0,PISQ1=UN/PISQ) C PROFIL=0. V=(FR-FR0(ITR))/DOP IPA=IABS(IP) IF(IPA.EQ.0) THEN IF(V.LE.13.) PROFIL=EXP(-V*V)*PISQ1 ELSE IF(IPA.EQ.1) THEN PROFIL=VOIGT(V,A)*PISQ1 ELSE IF(IPA.EQ.2) THEN IF(ID.GT.0) THEN ANE=ELEC(ID) ELSE ANE=1.e9*grav END IF if(ane.le.0.) ane=1.e14 F000=EXP(0.666666667*LOG(ANE)) II=NQUANT(ILOW(ITR)) JJ=NQUANT(IUP(ITR)) IZZ=IZ(IEL(ILOW(ITR))) FAC=TWO if(iquasi.gt.0.and.ii.eq.1) then if(jj.eq.2) fac=un if(jj.eq.3.and.iquasi.gt.1) fac=un end if F00=1.25D-9*F000 IF(IZZ.EQ.2) THEN FAC=UN F00=3.906D-11*F000 END IF CALL STARK0(II,JJ,IZZ,XKIJ,WL0,FIJ) FXK=F00*XKIJ DBETA=WL0*WL0/2.997925D18/FXK BETAD=DOP*DBETA CALL DIVSTR(IZZ) BETA=DBETA*ABS(FR-FR0(ITR)) SG=STARKA(BETA,fac)*BETAD PROFIL=SG ELSE IF(IPA.GT.10) THEN PROFIL=PROFSP(FR,DOP,ITR,ID) END IF RETURN END C C C **************************************************************** C C FUNCTION VOIGT(V,AGAM) C ====================== C C Voigt function C Procedure after Matta and Reichel, 1971, Math.Comp. 25, 339. C INCLUDE 'IMPLIC.FOR' DIMENSION HN(12),EN(12) PARAMETER (PI=3.141592653589793D0, M=12, HH=0.5D0, UN=1.D0) PARAMETER (PISQ=1.77245385090551D0,PISQ1=UN/PISQ) DATA ICOMP /0/ SAVE EN,HN,PH,HP,ICOMP C C Initialization of auxiliary quantities C IF(ICOMP.EQ.0) THEN HP=HH*PISQ1 PH=PI/HH DO I=1,M XI=I U=XI*XI*HH*HH EN(I)=EXP(-U) HN(I)=4.D0*U END DO ICOMP=1 END IF C C Main term C AGAM1=UN/AGAM X=V*AGAM1 T=0.25D0*AGAM1*AGAM1 X2=X*X X4=4.D0*X2 S1=UN+X2 S2=UN-X2 U0=0. DO I=1,M S0=HN(I)*T U=EN(I)/((S2+S0)*(S2+S0)+X4) U0=U0+U*(S1+S0) END DO S2=UN/S1 U0=HP*(S2+2.D0*U0) C C Correction term C IF(T.GE.0.25/(PH*PH)) THEN U=X/2.D0/T A=COS(U) B=SIN(U) TSQ1=UN/SQRT(T) S1=PH*TSQ1 S2=S1*X C=EXP(-S1)-COS(S2) D=SIN(S2) T4=0.25D0/T U=EXP(-X2*T4-S1+T4)*PISQ*TSQ1/(C*C+D*D) U0=U0+U*(A*C-B*D) END IF C VOIGT=U0*AGAM1*PISQ1 RETURN END C C C **************************************************************** C C function voigte(vs,a) c ===================== c c computes a voigt function h = h(a,v) c a=gamma/(4*pi*dnud) and v=(nu-nu0)/dnud. this is done after c traving (landolt-b\rnstein, p. 449). c INCLUDE 'IMPLIC.FOR' real*4 vs,a PARAMETER (UN=1., TWO=2.) dimension ak(19),a1(5) data ak /-1.12470432, -0.15516677, 3.28867591, -2.34357915, * 0.42139162, -4.48480194, 9.39456063, -6.61487486, 1.98919585, * -0.22041650, 0.554153432, 0.278711796,-0.188325687, 0.042991293, *-0.003278278, 0.979895023,-0.962846325, 0.532770573,-0.122727278/ data sqp/1.772453851/,sq2/1.414213562/ c v = abs(vs) u = a + v v2 = v*v if (a.eq.0.0) go to 140 if (a.gt.0.2) go to 120 if (v.ge.5.0) go to 121 c ex=0. if(v2.lt.100.) ex = exp(-v2) k = 1 c 100 quo = un if (v.lt.2.4) go to 101 quo = un/(v2 - 1.5) m = 11 go to 102 c 101 m = 6 if (v.lt.1.3) m = 1 102 do 103 i=1,5 a1(i) = ak(m) m = m + 1 103 continue h1 = quo*(a1(1) + v*(a1(2) + v*(a1(3) + v*(a1(4) + v*a1(5))))) if (k.gt.1) go to 110 c c a le 0.2 and v lt 5. c h = h1*a + ex*(un + a*a*(un - two*v2)) voigte=h return c 110 pqs = two/sqp h1p = h1 + pqs*ex h2p = pqs*h1p - two*v2*ex h3p = (pqs*(un - ex*(un - two*v2)) - two*v2*h1p)/3. + pqs*h2p h4p = (two*v2*v2*ex - pqs*h1p)/3. + pqs*h3p psi = ak(16) + a*(ak(17) + a*(ak(18) + a*ak(19))) c c 0.2 lt a le 1.4 and a + v le 3.2 c h = psi*(ex + a*(h1p + a*(h2p + a*(h3p + a*h4p)))) voigte=h return c 120 if (a.gt.1.4.or.u.gt.3.2) go to 130 ex=0. if(v2.lt.100.)ex = exp(-v2) k = 2 go to 100 c c a le 0.2 and v ge 5. c 121 h = a*(15. + 6.*v2 + 4.*v2*v2)/(4.*v2*v2*v2*sqp) voigte=h return c 130 a2 = a*a u = sq2*(a2 + v2) u2 = un/(u*u) c c a gt 1.4 or a + v gt 3.2 c h = sq2/sqp*a/u*(1. + u2*(3.*v2 - a2) + , u2*u2*(15.*v2*v2 - 30.*v2*a2 + 3.*a2*a2)) voigte=h return c c a eq 0. c 140 h=0. if(v2.lt.100.) h=exp(-v2) voigte=h return end C C C **************************************************************** C C FUNCTION PROFSP(FR,DOP,ITR,ID) C ================================ C C Non-standard absorption profile - normalized to unity; C a user supplied procedure C C Input: C FR - frequency C A - Voigt damping parameter C DOP - Doppler width C ITR - transition index C ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C PROFSP=0. IP=IPROF(ITR) C C Klaus Werner's Voigt+Stark wing profile (formula A.3.4) C IF(ABS(IP).NE.12) RETURN C 1- Stark wings II=NQUANT(ILOW(ITR)) JJ=NQUANT(IUP(ITR)) SIJ=JJ*(JJ-1)+II*(II-1) C C Micro-field C ZMIKRO=0. DO IAT=1,NATOM N0I=N0A(IAT) NKI=NKA(IAT) DO I=N0I,NKI-1 IE=IEL(I) CH=IZ(IE)-1 CH32=CH*SQRT(CH) ZMIKRO=ZMIKRO+CH32*POPUL(I,ID) END DO CH=CH+UN CH32=CH*SQRT(CH) ZMIKRO=ZMIKRO+CH32*POPUL(NKI,ID) END DO CALL SABOLF(ID) DO ION=1,NION CH=IZ(ION)-1 CH32=CH*SQRT(CH) ZMIKRO=ZMIKRO+CH32*USUM(ION) END DO ZMIKRO=ZMIKRO**0.6666667 C IAT=IATM(ILOW(ITR)) IE=IEL(ILOW(ITR)) CH=IZ(IE) DBETA=1.385*CH/SIJ/ZMIKRO C C empirical correction in PRO2 C CORRE=UN IF(IE.EQ.IELHE2 .AND.ILOW(ITR).GT.(NFIRST(IE)+1)) * CORRE=HALF IF(IAT.NE.IATH .AND. IAT.NE.IATHE) THEN CORRE=UN/(CH-UN) END IF DBETA=DBETA/CORRE C BETAD=DOP*DBETA BETA=DBETA*ABS(FR-FR0(ITR)) SIGST=UBETA(BETA)*BETAD C 2- Voigt profile AGAMS=5.E-5*ELEC(ID)/SQRT(TEMP(ID))*JJ*JJ/CH/CH AGAM=2.47342D-22*FR*FR+AGAMS AA=AGAM/12.56637/DOP V=(FR-FR0(ITR))/DOP SIGVT=VOIGT(V,AA)/1.77245385090551D0 SGA=SIGVT IF(SIGST.GT.SIGVT) SGA=SIGST PROFSP=SGA RETURN END C C C **************************************************************** C C FUNCTION UBETA(BETA) C ===================== C C ********************************************************************** C *** C *** CALLED BY: SUBROUTINE PROFSP C *** CALLS: SUBROUTINE LAGRAN C *** C *** Interpolation of function U(beta) in table from Dien (ApJ 109,452) C *** C ********************************************************************** INCLUDE 'IMPLIC.FOR' C DIMENSION B0(46),U0(46) C DATA (B0(I),U0(I),I= 1,46) / 1 0.0,.287,0.1,.286,0.2,.283,0.3,.278,0.4,.271,0.5,.262,0.6,.252, 1 0.7,.240,0.8,.228,0.9,.215,1.0,.202,1.1,.188,1.2,.174,1.3,.161, 1 1.4,.148,1.5,.135,1.6,.124,1.7,.113,1.8,.1024,1.9,.0928, 1 2.0,.0839,2.1,.0758,2.2,.0684,2.3,.0617,2.4,.0557,2.5,.0502, 1 2.6,.0454,2.7,.0411,2.8,.0373,2.9,.0338,3.0,.0310,3.2,.0260, 1 3.4,.0220,3.6,.0187,3.8,.0160,4.0,.0238,4.2,.0120,4.4,.0104, 1 4.6,.0091,4.8,.0080,5.0,.0071,6.0,.0041,7.0,.0027,8.0,.0018, 1 9.0,.0014,10.0,.0011/ C C *** asymptotic value C IF(BETA.GT.10.) THEN UBETA=0.2992*BETA**(-2.5) ELSE C *** Interpolation C DO I=3,46 IF (BETA.LT.B0(I)) GO TO 2 END DO 2 CALL LAGRAN (B0(I-2),B0(I-1),B0(I),U0(I-2),U0(I-1), * U0(I), BETA,UBETA) END IF RETURN END C C C **************************************************************** C C SUBROUTINE LAGRAN(X0,X1,X2,Y0,Y1,Y2,X,Y) C ========================================= C C *** C *** Lagrange interpolation for three points C *** INCLUDE 'IMPLIC.FOR' C XL0=(X-X1)*(X-X2)/(X0-X1)/(X0-X2) XL1=(X-X0)*(X-X2)/(X1-X0)/(X1-X2) XL2=(X-X0)*(X-X1)/(X2-X0)/(X2-X1) Y=Y0*XL0+Y1*XL1+Y2*XL2 RETURN END C C C **************************************************************** C C SUBROUTINE LINSET(ITR,IUNIT,IFRQ0,IFRQ1,XMAX,DOP,AGAM) C ====================================================== C C Set up frequency points and weights for a line C Auxiliary procedure for START C C Input: C ITR - index of the transition C INMOD - mode of evaluating frequency points in the line C = 0 - means that frequency points and weights have C already been read; C ne 0 - frequency points and weights will be evaluated: C the meaning of the individual values: C = 1 - equidistant frequencies, trapezoidal integration C = 2 - equidistant frequencies, Simpson integration C = 3 - modified Simpson integration, i.e. a series of C 3-point Simpson integrations with each subsequent C integration interval doubled, until the whole C integartion area is covered C = 4 - frequencies (in units of standard x) and weights C (for integration over x) are read; C C XMAX > 0 - means that the line is assumed symmetric around the C center, frequency points are set up between x=0 and C x=XMAX, where x is frequency difference from the C line center in units of the standard Doppler width C < 0 - frequency points are set between x=XMAX and x=-XMAX C DOP - Doppler width C AGAM - damping parameter (for lines with Voigt or non-standard C profile only) C C Output (to COMMON/FRQEXP) C FREQ - array of frequencies C Note that LINSET calculates values of frequencies only C for frequency points between IFR0(ITR) and IFR1(ITR). C W - corresponding integration weights C PROF - corresponding values of absorption profile C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (BOL2=2.76108D-16, CIN=UN/2.997925D10, OS0=0.02654, * F0C1=1.25D-9, TTW=2./3., PISQ1=UN/1.77245385090551D0, * C18IN=UN/CAS,F0C2=3.906D-11) DIMENSION X(MFREQL),W0(MFREQL) C IF(ITR.EQ.0) GO TO 200 INMOD=INTMOD(ITR) INMOD0=MOD(IABS(INMOD),10) IJ0=IFR0(ITR) IJ1=IFR1(ITR) N=IJ1-IJ0+1 IF(INMOD.EQ.0) THEN S=OSC0(ITR)*0.02654D0 IP0=IPROF(ITR) IP=IABS(IP0) DO I=1,N PROF(I+IJ0-1)=PROFIL(FREQ(I+IJ0-1),AGAM,DOP,ITR,IP,0)* * S/DOP IJLIN(I+IJ0-1)=ITR END DO IF(IP0.GE.0) THEN IF(XMAX.LT.0.) THEN PROF(IJ0)=0. PROF(IJ1)=0. ELSE PROF(IJ1)=0. END IF END IF IF(IPROF(ITR).GE.0) THEN IF(XMAX.LT.0.) THEN INTMOD(ITR)=-2 ELSE INTMOD(ITR)=-1 END IF ELSE IF(XMAX.LT.0.) THEN INTMOD(ITR)=2 ELSE INTMOD(ITR)=1 END IF END IF RETURN END IF X0=0. IF(XMAX.LT.0) X0=XMAX M=(N-1)/2 X(1)=0. W0(1)=UN IF(N.LE.1) GO TO 100 C IF(INMOD0.LE.2) THEN C C Trapezoidal integration C HH=ABS(X0+XMAX)/(N-1) DO I=1,N X(I)=X0+(I-1)*HH END DO IF(INMOD0.EQ.2) GO TO 40 DO I=1,N W0(I)=HH END DO W0(1)=HALF *HH W0(N)=HALF *HH GO TO 100 C C Ordinary Simpson integration C 40 HH=HH/3.D0 IF(MOD(N,2).NE.1) * CALL QUIT('even number of points in Simpson - LINSET',n,n) DO I=1,M W0(2*I)=4.D0*HH W0(2*I+1)=2.D0*HH END DO W0(1)=HH W0(N)=HH ELSE IF(INMOD0.EQ.3) THEN C C Modified Simpson integration - a set of 3-point Simpson C integrations with continuosly increasing distance between the C integration points (schematically, distances between points are C h,h,2h,2h,4h,4h, etc.) C TWI=UN MM=M IF(MOD(N,2).NE.1) * CALL QUIT('even number of points in MSimpson - LINSET',n,n) IF(XMAX.LT.0) MM=M/2 DO I=1,MM TWI=TWI*2.D0 X(2*I+1)= TWI-UN X(2*I)=TWI-UN-TWI/4.D0 W0(2*I)=2.D0*TWI W0(2*I+1)=1.5D0*TWI END DO TWN=TWI-UN TWA=ABS(XMAX)/TWN HH=TWA/6.D0 DO I=1,MM X(2*I+1)=X(2*I+1)*TWA X(2*I)=X(2*I)*TWA W0(2*I)=W0(2*I)*HH W0(2*I+1)=W0(2*I+1)*HH END DO W0(1)=HH W0(N)=TWI*HH/2.D0 X(1)=0. IF(M.EQ.MM) GO TO 100 IF(MOD(N,4).NE.1) * CALL QUIT('conflict in MSimpson - LINSET',n,n) DO I=1,M X(M+1+I)=X(I+1) W0(M+1+I)=W0(I+1) END DO M2=2*(M+1) DO I=1,M X(I)=-X(M2-I) W0(I)=W0(M2-I) END DO X(M+1)=0. W0(M+1)=2.D0*HH C C frequencies (in units of standard x) and weights C (for integration over x) are read; C ELSE IF(INMOD0.EQ.4) THEN READ(IUNIT,*) (X(I),I=1,N),(W0(I),I=1,N) END IF C C For all types of integration: C set up arrays FR,WW,PRF C 100 S=OSC0(ITR)*0.02654D0 IP0=IPROF(ITR) IP=IABS(IP0) DO I=1,N FREQ(I+IJ0-1)=FR0(ITR)-DOP*X(I) W(I+IJ0-1)=DOP*W0(I) PROF(I+IJ0-1)=PROFIL(FREQ(I+IJ0-1),AGAM,DOP,ITR,IP,0)*S/DOP END DO C C for IPROF(ITR) ge 0 - endpoint(s) of the line profile are forced to C have zero cross-section C IF(IP0.GE.0) THEN IF(XMAX.LT.0.) THEN PROF(IJ0)=0. PROF(IJ1)=0. ELSE PROF(IJ1)=0. END IF END IF C C Recalculation of quadrature weights in order to enforce exact C normalization of the integral (absorption profile * weights) C SUM=0. DO I=1,N SUM=SUM+PROF(I+IJ0-1)*W(I+IJ0-1) END DO SUM=S/SUM DO I=1,N W(I+IJ0-1)=W(I+IJ0-1)*SUM END DO C C reset the switch INTMOD C IF(IPROF(ITR).GE.0) THEN IF(XMAX.LT.0.) THEN INTMOD(ITR)=-2 ELSE INTMOD(ITR)=-1 END IF ELSE IF(XMAX.LT.0.) THEN INTMOD(ITR)=2 ELSE INTMOD(ITR)=1 END IF END IF IF(ABS(INMOD).GE.10) INTMOD(ITR)=0 C IF(INDEXP(ITR).NE.0) THEN CALL IJALIS(ITR,IFRQ0,IFRQ1) END IF RETURN C 200 CONTINUE IF(ISPODF.GT.0) RETURN DO 220 IT=1,NTRANS IF(.NOT.LINE(IT)) GO TO 220 IP=IABS(IPROF(IT)) IF(IP.NE.2) GO TO 220 IAT=IATM(ILOW(IT)) AM=BOL2/AMASS(IAT)*TEFF DOPP=FR0(IT)*CIN*SQRT(AM+VTB*VTB) DOP1=UN/DOPP ANE=ELSTD IF(ANE.LE.0.) ANE=1.E14 F000=EXP(TTW*LOG(ANE)) II=NQUANT(ILOW(IT)) JJ=NQUANT(IUP(IT)) IZZ=IZ(IEL(ILOW(IT))) FAC=TWO F00=F0C1*F000 IF(IZZ.EQ.2) THEN FAC=UN F00=F0C2*F000 END IF CALL STARK0(II,JJ,IZZ,XKIJ,WL0,FIJ) FXK=F00*XKIJ DBETA=WL0*WL0*C18IN/FXK BETAD=DOPP*DBETA FID=OS0*FIJ*DBETA FID0=OS0*(OSC0(IT)-FIJ)*DOP1*PISQ1 CALL DIVSTR(IZZ) DO IJ=IFR0(IT),IFR1(IT) BETA=DBETA*ABS(FREQ(IJ)-FR0(IT)) SG=STARKA(BETA,fac)*FID SG0=0. V=(FREQ(IJ)-FR0(IT))*DOP1 IF(ABS(V).LE.13.) SG0=EXP(-V*V)*FID0 PROF(IJ)=SG+SG0 END DO 220 CONTINUE RETURN END C C C **************************************************************** C C SUBROUTINE LINSPL(ITR,DOP,AGAM) C =============================== C C Set up depth-independent profile for a line C Analog to LINSET used in sampling mode C C Input: C ITR - index of the transition C DOP - Doppler width C AGAM - damping parameter (for lines with Voigt or non-standard C profile only) C C Output (to COMMON/FRQEXP) C PROF - values of absorption profile C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (OS0=0.02654) C IJ0=IFR0(ITR) IJ1=IFR1(ITR) N=IJ1-IJ0+1 KJ0=KFR0(ITR) KJ1=KFR1(ITR) C C For all types of integration: C S=OSC0(ITR)*OS0 IP0=IPROF(ITR) IP=IABS(IP0) DO I=1,N PROF(KJ0+I-1)=PROFIL(FREQ(IJ0+I-1),AGAM,DOP,ITR,IP,0)*S/DOP END DO C C for IPROF(ITR) ge 0 - endpoint(s) of the line profile are forced to C have zero cross-section C IF(IP0.GE.0) THEN PROF(KJ0)=0. PROF(KJ1)=0. END IF RETURN END C C C **************************************************************** C C SUBROUTINE LINPRO(ITR,ID,PRF) C ============================= C C Line profile coefficient for the line ITR; C for "classical" lines (i.e. those which are not represented by ODF's). C It is either calculated for each depth (if LCOMP=true), or is C just taken as constant, depth-independent quantity, already C calculated in START and stored in array PROF C C Input: ITR - index of transition C ID - depth index C Output: PRF - array of absorption profile C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal PARAMETER (BOL2=2.76108D-16, CIN=UN/2.997925D10, OS0=0.02654, * F0C1=1.25D-9, TTW=2./3., PISQ1=UN/1.77245385090551D0, * C18IN=UN/CAS,F0C2=3.906D-11,cca=2.997925e18, * CINV=UN/cca,AL10=2.3025851) DIMENSION PRF(MFREQL),PRF0(MHWL),prfb(mfreql),prfr(mfreql) C MODE=IABS(INDEXP(ITR)) IJ0=IFR0(ITR) IJ1=IFR1(ITR) INTM0=INTMOD(ITR) INTM=IABS(INTM0) IP=IABS(IPROF(ITR)) C C Doppler width C IF(LCOMP(ITR).OR.IP.EQ.2) THEN IAT=IATM(ILOW(ITR)) AM=BOL2/AMASS(IAT)*TEMP(ID) DOP=FR0(ITR)*CIN*SQRT(AM+VTURBS(ID)*VTURBS(ID)) DOP1=UN/DOP END IF IF(LCOMP(ITR).AND.IP.EQ.1.OR.IP.LT.0) THEN CALL DOPGAM(ITR,ID,TEMP(ID),DOP,AGAM) DOP1=UN/DOP END IF S=OSC0(ITR)*OS0 XNORM=PISQ1*S*DOP1 C C Depth-independent profile C IF(ISPODF.EQ.0) THEN DO IJ=IJ0,IJ1 PRF(IJ-IJ0+1)=PROF(IJ) END DO ELSE DO IJ=KFR0(ITR),KFR1(ITR) PRF(IJ-KFR0(ITR)+1)=PROF(IJ) END DO END IF IF(.NOT.LCOMP(ITR)) RETURN c c evaluation of the depth-dependent profile C IF(IP.EQ.0) THEN DO IJ=IJ0,IJ1 V=(FREQ(IJ)-FR0(ITR))*DOP1 IF(ABS(V).LE.13.) PRF(IJ-IJ0+1)=EXP(-V*V)*XNORM END DO ELSE IF(IP.EQ.1) THEN DO IJ=IJ0,IJ1 V=(FREQ(IJ)-FR0(ITR))*DOP1 PRF(IJ-IJ0+1)=VOIGT(V,AGAM)*XNORM END DO ELSE IF(IP.EQ.2) THEN C C for IP=2 - approximate Stark profile for hydrogen lines, C evaluate necessary frequency-independent quantities C ANE=ELEC(ID) F000=EXP(TTW*LOG(ANE)) II=NQUANT(ILOW(ITR)) JJ=NQUANT(IUP(ITR)) IZZ=IZ(IEL(ILOW(ITR))) FAC=TWO F00=F000*F0C1 if(iquasi.gt.0.and.ii.eq.1) then if(jj.eq.2) fac=un if(jj.eq.3.and.iquasi.gt.1) fac=un end if IF(IZZ.EQ.2) THEN FAC=UN F00=F000*F0C2 END IF CALL STARK0(II,JJ,IZZ,XKIJ0,WL00,FIJ0) FXK=F00*XKIJ0 DBETA=WL00*WL00*C18IN/FXK BETAD=DOP*DBETA FID=OS0*FIJ0*DBETA FID0=OS0*(OSC0(ITR)-FIJ0)*DOP1*PISQ1 CALL DIVSTR(IZZ) C C loop over frequencies C DO IJ=IJ0,IJ1 BETA=DBETA*ABS(FREQ(IJ)-FR0(ITR)) SG=STARKA(BETA,fac)*FID SG0=0. V=(FREQ(IJ)-FR0(ITR))*DOP1 IF(ABS(V).LE.13.) SG0=EXP(-V*V)*FID0 PRF(IJ-IJ0+1)=SG+SG0 sgmax=max(sgmax,sg+sg0) END DO ELSE IF(IP.EQ.3.or.ip.eq.4) THEN C C for IP=3 - exact Stark profile for hydrogen lines (Lemke tables) C II=NQUANT(ILOW(ITR)) JJ=NQUANT(IUP(ITR)) ANE=ELEC(ID) F00=F0C1*EXP(TTW*LOG(ANE)) FID=OS0*OSC0(ITR) anel=log10(ane) tl=log10(temp(id)) c c switch to either original Lemke/Tremblay of Xenomorph c if(ilxen(ii,jj).eq.0.or.anel.lt.xnemin) then c c original Lemke/Tremblay c WLI0=cca/fr0(itr) fac=un if(iquasi.gt.0.and.ii.eq.1) then if(jj.eq.2) fac=half if(jj.eq.3.and.iquasi.gt.1) fac=half end if iline=0 if(ip.eq.3) then IF(II.LE.4.AND.JJ.LE.22) iline=ilinh(ii,jj) else IF(II.LE.2.AND.JJ.LE.10) iline=ilinh(ii,jj) end if c if(iline.gt.0) then CALL INTLEM(PRF0,WLI0,ILINE,ID) NWL=NWLHYD(ILINE) DO IJ=IJ0,IJ1 al=abs(wli0-cca/freq(ij)) IF(AL.LT.1.E-4) AL=1.E-4 AL=AL/F00 AL=LOG10(AL) DO IWL=1,NWL-1 IW0=IWL IF(AL.LE.WLHYD(ILINE,IWL+1)) GO TO 40 END DO 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 SG=SG*WLI0**2*CINV/F00 PRF(IJ-IJ0+1)=SG*fac END DO end if c c XENOMORPH data for selected lines c else ixn=ilxen(ii,jj) nwl=nwlxen(ixn) do iwl=1,nwl call intxen(prfb0,prfr0,tl,anel,iwl,ixn,id) prfb(iwl)=prfb0 prfr(iwl)=prfb0 end do do ij=ij0,ij1 al=(freq(ij)-fr0(itr))/f00 if(abs(al).lt.1.e-4) al=1.e-4 all=log10(abs(al)) do iwl=1,nwl-1 iw0=iwl if(all.le.alxen(ixn,iwl+1)) go to 50 end do 50 iw1=iw0+1 if(al.gt.0.) then prff=(prfb(iw0)*(alxen(ixn,iw1)-all)+ * prfb(iw1)*(all-alxen(ixn,iw0)))/ * (alxen(ixn,iw1)-alxen(ixn,iw0)) else prff=(prfr(iw0)*(alxen(ixn,iw1)-all)+ * prfr(iw1)*(all-alxen(ixn,iw0)))/ * (alxen(ixn,iw1)-alxen(ixn,iw0)) end if sg=exp(prff*al10)*fid/f00 prf(ij-ij0+1)=sg end do END IF c c for IP ge 10 - special line profile c ELSE IF(IP.GE.10) THEN DO IJ=IJ0,IJ1 PRF(IJ-IJ0+1)=PROFSP(FREQ(IJ),DOP,ITR,ID) END DO END IF C C if required, force the profile at the endpoints to zero C IF(INTM0.EQ.-1) THEN PRF(IJ1-IJ0+1)=0. ELSE IF(INTM0.EQ.-2) THEN PRF(1)=0. PRF(IJ1-IJ0+1)=0. END IF RETURN END C C C C **************************************************************** C C FUNCTION SIGK(FR,ITR,MODE) C ========================== C C Photoionization cross-sections C C Input: FR - frequency C ITR - index of the transition C MODE- =0 - cross-section equal to zero longward of edge C >0 - cross-section non-zero (extrapolated) longward C of edge C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' PARAMETER (SIH0=2.815D29, E10=2.3025851) DIMENSION XFIT(MFIT) , ! local array containing x for OP data + SFIT(MFIT) ! local array containing sigma for OP data C PEACH(X,S,A,B) =A*X**S*(B+X*(1.-B))*1.D-18 HENRY(X,S,A,B,C)=A*X**S*(C+X*(B-2.*C+X*(1.+C-B)))*1.D-18 C SIGK=0. IF(INDEXP(ITR).EQ.0) RETURN IF(MODE.EQ.0.AND.FR.LT.FR0(ITR)) RETURN C C IC is the index of the given transition in the special numbering C of continua (given by ITRCON(ITR) C IBF(IC) is the switch controlling the mode of evaluation of the C cross-section: C = 0 hydrogenic cross-section, with Gaunt factor set to 1 C = 1 hydrogenic cross-section with exact Gaunt factor C = 2 Peach-type expression (see function PEACH) C = 3 Henry-type expression (see function HENRY) C = 4 Butler fit formula (polynomial fits to the OP results); C = 5 Verner fit formula (OP results & HDS calculations at high C energies); ONLY for GROUND states; C = 6 DETAIL's fit formula from Klaus Werner C (similar to Butler's fit but up to 5th order) C = 7 hydrogenic cross-section with Gaunt factor after Werner C = 9 Opacity project fits (routine TOPBAS - interpolations) C > 100 - cross-sections extracted form TOPBASE, for several points C In this case, IBF-100 is the number of points C < 0 non-standard, user supplied expression (user should update C subroutine SPSIGK) C C for H- : for any IBF > 0 - standard expression C C for He I: C for IBF = 11 or = 13 - Opacity Project cross section C Seaton-Ferney's cubic fits, Hummer's procedure (HEPHOT) C IBF = 11 means that the multiplicity S=1 (singlet) C IBF = 13 means that the multiplicity S=3 (triplet) C for IBF = 10 - cross section, based on Opacity Project, but C appropriately averaged for an averaged level C (see explanation in SBFHE1) C C for IBF = 21 or 23 Koester's fit (A&A 149, 423) C C IBF = 21 means that the multiplicity S=1 (singlet) C IBF = 23 means that the multiplicity S=3 (triplet) C IC=ITRCON(ITR) IB=IBF(IC) II=ILOW(ITR) IQ=NQUANT(II) IE=IEL(ILOW(ITR)) IF(IB.LT.0) GO TO 60 IF(IE.EQ.IELHM) GO TO 40 IF(IE.EQ.IELHE1.AND.IB.GE.10.AND.IB.LE.23) GO TO 50 CH=IZ(IE)*IZ(IE) IQ5=IQ*IQ*IQ*IQ*IQ C IF(IB.EQ.0) THEN C C hydrogenic expression (for IBF = 0) C SIGK=SIH0/FR/FR/FR*CH*CH/IQ5 C C exact hydrogenic - with Gaunt factor (for IBF=1) C ELSE IF(IB.EQ.1) THEN SIGK=SIH0/FR/FR/FR*CH*CH/IQ5 frd=fr0(itr) fr0l=0.95*frd if(fr.ge.frd) then gau0=gaunt(iq,fr/ch) sigk=sigk*gaunt(iq,fr/ch) else if(fr.ge.fr0l) then gau0=gaunt(iq,frd/ch) corg=(fr-fr0l)/(frd-fr0l)*(gau0-1.)+1. sigk=sigk*corg end if ELSE IF(IB.EQ.2) THEN C C Peach-type formula (for IBF=2) C FREL=FR0(ITR)/FR IF(GAMCS(IC).GT.0) THEN IF(GAMCS(IC).LT.1.E6) THEN FR00=2.997925E18/GAMCS(IC) ELSE FR00=GAMCS(IC) END IF IF(FR.LT.FR00) RETURN FREL=FR00/FR END IF if(frel.gt.0.) * SIGK=PEACH (FREL,S0CS(IC),ALFCS(IC),BETCS(IC)) ELSE IF(IB.EQ.3) THEN C C Henry-type formula (for IBF=3) C FREL=FR0(ITR)/FR if(frel.gt.0.) * SIGK=HENRY(FREL,S0CS(IC),ALFCS(IC),BETCS(IC),GAMCS(IC)) C C Butler expression C ELSE IF(IB.EQ.4) THEN FREL=FR0(ITR)/FR XL=LOG(FREL) SL=S0CS(IC)+XL*(ALFCS(IC)+XL*BETCS(IC)) SIGK=EXP(SL) C C Verner expression C ELSE IF(IB.EQ.5) THEN SIGK=VERNER(FR,ITR) C C DETAIL expression C ELSE IF(IB.EQ.6) THEN FREL=FR0(ITR)/FR XL=LOG(FREL) XL2=XL*XL XL3=XL2*XL SL=CTOP(1,IC)+XL*CTOP(2,IC)+XL2*CTOP(3,IC)+XL3*CTOP(4,IC) SL=SL+XL2*XL2*CTOP(5,IC)+XL3*XL2*CTOP(6,IC) SIGK=EXP(SL) C C exact hydrogenic - with Gaunt factor from K Werner (for IBF=7) C ELSE IF(IB.EQ.7) THEN IQ5=IQ*IQ*IQ*IQ*IQ SIGK=SIH0/(FR*FR*FR)*CH*CH/IQ5*GNTK(IQ,FR/CH) C C selected Opacity Project data (for IBF=9) C (c.-s. evaluated by routine TOPBAS which needs an input file RBF.DAT) C ELSE IF(IB.EQ.9) THEN SIGK=TOPBAS(FR,FR0(ITR),TYPLEV(II)) C C other Opacity Project data (for IBF>100) C (c.-s. evaluated by interpolating from direct input data) C ELSE IF(IB.GT.100) THEN NFIT=IB-100 X = LOG10(FR/FR0(ITR)) SIGM=0. IF(X.GE.XTOP(1,IC)) THEN DO IFIT = 1,NFIT XFIT(IFIT) = XTOP(IFIT,IC) SFIT(IFIT) = CTOP(IFIT,IC) END DO SIGM = YLINTP (X,XFIT,SFIT,NFIT,MFIT) SIGM = 1.D-18*EXP(E10*SIGM) ENDIF SIGK=SIGM END IF if(iatm(ii).eq.iath.and.ii.gt.n0hn+2. * and.ib.le.1.and.fr.lt.fr0(itr)) then fr1=fr0pc(ii) frdec=min(fr1*1.25,fr0(itr)) if(fr.gt.fr1.and.fr.lt.frdec) * sigk=sigk*(fr-fr1)/(frdec-fr1) end if c RETURN C C special expression for H- C 40 SIGK=SBFHMI(FR) RETURN C C He I cross-sections C 50 SIGK=SBFHE1(II,IB,FR,G(II)) RETURN C C non-standard, user supplied form of cross-section (for IBF < 0) C 60 CALL SPSIGK(IB,FR,SIGSP) SIGK=SIGSP RETURN END C C C **************************************************************** C C FUNCTION VERNER(FR,ITR) C ======================= C C Photoionization cross-sections for ground states C of atoms and ions. Analytical fits from: C Verner D.A. et al. 1996, ApJ 465 C Verner & Yakovlev 1995, A&AS 109, 125 C C 10-July-1996: Version for H to Si, S, Ar, Ca and Fe. C No test on threshold energy as given by Verner et al. C to avoid inconsistencies with limits FR0 as read by Tlusty C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' C PARAMETER (HHEV=H/1.6022D-12,T18=1.D-18,MVER=105) DIMENSION S0(MVER),E0(MVER),EMX(MVER) DIMENSION Y0(MVER),Y1(MVER),YW(MVER),YA(MVER),PV(MVER) DIMENSION S95(MVER),E95(MVER),Y95(MVER),YW95(MVER),P95(MVER) DIMENSION IV0(14) C DATA IV0/0,1,3,6,10,15,21,28,36,45,55,66,78,91/ DATA S0/5.475D4,9.492D2,1.369D4,6.245D1,3.201D2,6.083D3,2.932D5, + 2.678D2,5.458D2,3.422D3,5.466D0,1.859D4,5.393D1,2.846D2, + 2.190D3,5.027D2,8.709D0,1.539D4,1.068D2,2.344D2,1.521D3, + 8.235D2,1.944D0,9.375D-1,1.690D4,8.376D1,1.519D2,1.117D3, + 1.745D3,5.967D1,6.753D2,8.659D-1,1.642D4,6.864D1,1.329D2, + 8.554D2,3.803D3,8.013D1,1.541D2,3.165D0,4.690D-1,1.157D4, + 6.930D1,1.039D2,6.759D2,4.287D3,1.583D3,5.708D0,1.685D3, + 2.430D0,9.854D-1,1.198D4,5.631D1,6.695D1,5.475D2,1.601D0, + 1.04D3,1.885D3,2.33D0,2.346D1,7.101D1,1.609D0,7.215D3, + 4.729D1,3.995D1,4.525D2,1.372D8,3.278D0,5.377D2,1.394D3, + 1.728D0,2.185D0,3.104D0,6.344D-2,9.008D2,4.427D1,6.14D1, + 3.802D2,7.195D0,6.948D-2,4.915D0,1.513D1,2.925D2,1.962D-2, + 1.889D2,2.35D-1,4.982D-1,1.774D4,3.388D1,4.036D1,3.239D2, + 2.506D1,4.14D0,5.79D-4,6.083D0,8.863D-1,7.293D1,6.68D-2, + 3.477D-1,1.465D-1,1.95D-1,1.992D4,2.539D1,4.754D1,2.793D2/ DATA E0/0.4298,13.61,1.72,3.107,20.06,3.871,9.539,1.181,17.6, + 6.879,0.5213,2.869,1.041,33.36,10.75,2.144,0.4058,4.614, + 3.506,46.24,15.48,4.034,0.06128,0.242,5.494,4.471,69.43, + 21.08,1.24,1.386,0.1723,0.2044,2.854,7.824,87.09,27.54, + 12.97,1.763,2.542,0.7744,0.7286,4.008,2.563,113.1,34.85, + 4.87,12.47,0.7753,5.566,1.248,1.499,4.888,10.03,158.6, + 43.04,6.139,8.203,10.69,0.669,5.408,48.46,2.096,153.5, + 13.91,226.8,52.11,11.97,8.139,10.86,29.12,0.9762,1.711, + 3.57,0.4884,34.82,14.52,204.2,62.03,13.81,0.2048,10.27, + 3.13,24.14,0.3483,2.636,0.4866,1.842,8.044,23.55,273.8, + 72.81,23.17,2.556,0.1659,1.288,0.7761,63.05,0.3277,0.7655, + 0.3343,0.8787,12.05,35.6,275.2,84.47/ DATA EMX/5.D4,5.D4,5.D4,64.39,5.D4,5.D4,11.93,12.99,5.D4,5.D4, + 194.0,209.8,227.4,5.D4,5.D4,291.0,307.6,328.9,352.2, + 5.D4,5.D4,404.8,423.6,447.3,475.3,504.3,5.D4,5.D4, + 538.0,558.1,584.0,614.4,649.1,683.7,5.D4,5.D4,694.0, + 712.2,739.2,770.9,809.1,850.2,890.5,5.D4,5.D4,870.1, + 883.1,913.1,948.0,987.3,1031.,1078.,1125.,5.D4,5.D4, + 38.14,1074.,1110.,1143.,1185.,1230.,1281.,1335.,1386., + 5.D4,5.D4,54.9,65.69,1317.,1356.,1400.,1449.,1501., + 1558.,1618.,1675.,5.D4,5.D4,80.4,89.97,102.6,1588., + 1634.,1688.,1739.,1799.,1862.,1929.,1992.,5.D4,5.D4, + 106.,118.6,131.1,146.6,1887.,1946.,2001.,2058.,2125., + 2194.,2268.,2336.,5.D4,5.D4/ DATA Y0/0.,0.4434,0.,0.,0.,0.,8.278D-4,0.,0.,0.,1.319D1,4.96D-3, + 0.,0.,0.,1.133,4.929D1,4.378D-3,0.,0.,0.,8.598D-1,4.28D2, + 1.877D2,6.415D-3,0.,0.,0.,8.698,2.131D1,3.839D-3,3.328D2, + 3.036D-2,0.,0.,0.,1.701D-4,1.715D1,1.641D1,9.531D1, + 1.506D2,2.071D-2,0.,0.,0.,4.236D-2,1.52,7.654D1,5.149, + 9.169D1,1.042D2,2.536D-2,0.,0.,0.,0.,3.375,3.725,1.383D2, + 2.204D1,9.603D-4,9.94D1,0.1667,0.,0.,0.,0.,0.,4.86, + 9.402D-1,1.276D2,1.007D2,5.452D1,5.348D2,5.444,0.,0.,0., + 2.041D-1,9.149D1,0.,3.994D1,3.495,5.675D-2,3.552D1, + 5.704D2,1.719D2,2.538D-2,0.,0.,0.,1.672D-5,6.634,9.613D1, + 0.,2.009D2,1.115,1.149D-2,3.85D2,1.036D3,4.528D2,1.99D-2, + 0.,0.,0./ DATA Y1/0.,2.136,0.,0.,0.,0.,1.269D-2,0.,0.,0.,4.556,3.4D-2,0., + 0.,0.,1.607,3.234,2.528D-2,0.,0.,0.,2.325,2.03D1,3.999, + 1.937D-2,0.,0.,0.,1.271D-1,1.503D-2,4.569D-1,4.285D1, + 5.554D-2,0.,0.,0.,1.345D-2,7.724D-1,5.124,9.781,2.574D-1, + 3.998D-2,0.,0.,0.,5.873,1.084D-1,2.023,6.687,3.702D-1, + 1.435,4.417D-2,0.,0.,0.,0.,4.01,0.2279,4.26,0.7577, + 6.378D-3,3.278,1.766D-2,0.,0.,0.,0.,0.,3.722,0.1135, + 3.979,1.729,2.078,3.997D-3,7.918D-2,0.,0.,0.,0.4753, + 0.6565,0.,4.803,0.2701,0.2768,8.223D-3,0.158,6.595, + 1.203D-2,0.,0.,0.,0.4207,0.1272,0.6442,0.,4.537,8.051D-2, + 0.6396,8.999D-2,0.2936,1.015,1.007D-2,0.,0.,0./ DATA YW/0.,2.039,0.,0.,0.,0.,3.655D-1,0.,0.,0.,1.887D1,3.503,0., + 0.,0.,9.157D-2,2.093,5.922,0.,0.,0.,9.097D-2,1.043D1, + 1.85,7.904,0.,0.,0.,7.589D-2,1.934D-2,1.191D-1,3.143, + 2.836D1,0.,0.,0.,2.17D-3,5.103D-1,1.115,6.812,2.57D-1, + 2.411D1,0.,0.,0.,2.434D-1,6.558D-2,4.633D-1,8.29D-3, + 6.855D-1,1.656,2.811D1,0.,0.,0.,0.,2.328,8.579D-2,0.7365, + 0.9275,1.285D-2,1.895,0.9121,0.,0.,0.,0.2805,0.,2.604, + 4.326D-2,0.809,0.6325,1.422,0.6666,2.751,0.,0.,0.,0.3166, + 0.4615,0.,5.342,0.1,8.839,1.836,0.2773,0.6945,29.53,0., + 0.,0.,0.2837,1.57,0.8626,0.,1.303,2.989D-3,3.28,1.476D-3, + 1.646,0.4489,2.392D1,0.,0.,0./ DATA YA/3.288D1,1.469D0,3.288D1,1.501D1,7.391D0,3.288D1,4.301D-1, + 5.645D0,1.719D1,3.288D1,8.618D0,1.783D0,1.767D1,2.163D1, + 3.288D1,6.216D1,1.261D2,1.737D0,1.436D1,2.183D1,3.288D1, + 8.033D1,8.163D2,2.788D2,1.714D0,3.297D1,2.627D1,3.288D1, + 3.784D0,3.175D1,3.852D2,4.931D2,1.792D0,3.210D1,2.535D1, + 3.288D1,2.587D0,1.667D1,5.742D1,1.099D2,1.400D2,1.848D0, + 7.547D1,2.657D1,3.288D1,5.798D0,3.935D0,6.725D1,6.409D2, + 1.066D2,1.350D2,1.788D0,3.628D1,3.352D1,3.288D1,6.148D3, + 8.259D0,3.613D0,1.205D2,2.913D1,3.945D1,2.473D2,3.886D-1, + 3.889D1,5.315D1,3.288D1,2.228D-1,4.341D7,9.779D0,2.895D0, + 9.184D1,9.350D1,6.060D1,5.085D2,1.823D0,3.826D1,2.778D1, + 3.288D1,1.621D3,5.675D2,1.990D6,1.674D1,6.973D0,1.856D1, + 1.338D2,7.216D2,2.568D2,1.653D0,3.432D1,3.567D1,3.288D1, + 2.057D1,1.337D1,1.474D2,1.356D6,1.541D2,1.558D2,4.132D1, + 3.733D2,1.404D3,7.461D2,1.582D0,3.307D1,2.848D1,3.288D1/ DATA PV/2.963,31.88,2.963,4.895,2.916,2.963,10.52,11.7,3.157, + 2.963,17.28,16.18,9.54,2.624,2.963,5.101,8.578,15.93, + 7.457,2.581,2.963,3.928,8.773,9.156,17.06,6.003,2.315, + 2.963,17.64,8.943,6.822,8.785,26.47,5.495,2.336,2.963, + 7.275,10.5,6.614,9.203,9.718,24.46,6.448,2.255,2.963, + 8.355,7.81,10.05,3.056,8.999,8.836,25.5,5.585,2.002, + 2.963,3.839,7.362,9.803,9.714,8.26,2.832,7.681,8.476, + 5.265,1.678,2.963,15.74,3.61,7.117,6.487,10.06,9.202, + 8.857,9.385,14.44,5.46,2.161,2.963,3.642,9.049,3.477, + 11.8,6.724,20.84,6.204,8.659,8.406,26.55,5.085,1.915, + 2.963,3.546,11.91,13.36,3.353,9.98,2.4,16.06,8.986, + 8.503,8.302,24.25,4.728,2.135,2.963/ DATA S95/5.475D4,4.47D3,1.369D4,1.564D2,3.201D2,6.083D3,1.306D2, + 9.796D1,5.458D2,3.422D3,9.698D1,1.037D2,8.605D1,2.846D2, + 2.19D3,7.421D1,6.649D1,8.067D1,8.111D1,2.344D2,1.521D3, + 4.748D1,5.002D1,5.235D1,7.046D1,7.304D1,1.519D2,1.117D3, + 3.237D1,3.584D1,3.939D1,4.123D1,5.735D1,6.029D1,1.329D2, + 8.554D2,2.295D1,4.798D1,3.144D1,5.302D1,3.680D1,4.668D1, + 4.890D1,1.039D2,6.759D2,1.664D1,2.783D1,2.943D1,3.027D1, + 3.097D1,3.232D1,5.011D1,3.719D1,6.695D1,5.475D2,2.486D2, + 1.889D1,3.466D1,2.551D1,3.753D1,2.654D1,2.745D1,3.613D1, + 3.850D1,3.995D1,4.525D2,2.023D2,2.049D2,1.877D1,2.212D1, + 2.350D1,3.278D1,3.407D1,2.721D1,3.699D1,3.290D1,6.140D1, + 3.802D2,1.735D2,1.842D2,1.990D2,2.494D1,2.572D1,2.786D1, + 2.653D1,2.989D1,2.857D1,3.223D1,3.272D1,4.036D1,3.239D2, + 1.532D2,1.832D2,2.197D2,2.326D2,3.100D1,2.398D1,2.474D1, + 3.135D1,2.641D1,3.343D1,2.832D1,3.880D1,4.754D1,2.793D2/ DATA E95/0.4298,5.996,1.72,27.4,20.06,3.871,40.93,47.59,17.6, + 6.879,61.55,59.84,65.92,33.36,10.75,86.55,91.13,83.7, + 84.12,46.24,15.48,127.,124.2,122.,107.,106.,69.43,21.08, + 177.4,169.,162.,159.3,137.7,135.4,87.09,27.54,239.,166., + 205.5,160.3,192.5,173.7,171.1,113.1,34.85,314.4,245.2, + 238.7,236.,234.3,230.8,188.6,219.3,158.6,43.04,36.55, + 326.6,242.6,284.1,236.,280.6,277.7,246.4,240.6,226.8, + 52.11,49.37,49.4,360.7,334.5,325.9,277.7,274.2,308.2, + 267.1,285.8,204.2,62.03,64.45,61.54,60.16,348.2,343.2, + 326.8,339.6,319.3,330.5,311.7,313.7,273.8,72.81,78.08, + 71.54,66.52,64.82,346.,379.9,375.9,344.2,367.9,335.6, + 359.9,315.,275.2,84.47/ DATA Y95/3.288D1,2.199D0,3.288D1,3.382D1,7.391D0,3.288D1,1.212D2, + 1.166D3,1.719D1,3.288D1,7.354D1,7.915D1,1.906D2,2.163D1, + 3.288D1,5.498D1,9.609D1,7.471D1,7.459D1,2.183D1,3.288D1, + 1.380D2,9.100D1,9.428D1,5.342D1,5.547D1,2.627D1,3.288D1, + 3.812D2,1.894D2,1.104D2,1.141D2,5.486D1,5.682D1,2.535D1, + 3.288D1,1.257D3,5.000D1,1.230D2,5.000D1,7.933D1,5.876D1, + 6.137D1,2.657D1,3.288D1,2.042D5,6.075D1,6.525D1,6.734D1, + 6.907D1,7.167D1,5.000D1,8.181D1,3.352D1,3.288D1,3.222D2, + 2.527D2,5.000D1,6.977D1,5.000D1,7.237D1,7.512D1,4.968D1, + 5.198D1,5.315D1,3.288D1,1.079D4,4.112D4,1.401D2,7.147D1, + 6.173D1,5.000D1,5.000D1,5.108D1,5.000D1,5.384D1,2.778D1, + 3.288D1,1.131D4,2.404D3,5.082D2,3.260D1,3.376D1,5.000D1, + 3.478D1,5.000D1,3.660D1,5.000D1,4.295D1,3.567D1,3.288D1, + 5.765D6,3.537D2,1.169D2,1.188D2,1.979D1,5.000D1,5.000D1, + 2.260D1,5.000D1,2.487D1,5.000D1,3.034D1,2.848D1,3.288D1/ DATA YW95/55*0.,0.1465,10*0.,1.463D-2,2.223D-5,10*0.,2.337D-2, + 7.839D-3,2.016D-2,10*0.,2.774D-4,2.87D-4,8.658D-4, + 8.417D-4,10*0./ DATA P95/2.963,6.098,2.963,1.49,2.916,2.963,1.348,1.022,3.157, + 2.963,1.438,1.436,1.21,2.624,2.963,1.503,1.338,1.442, + 1.428,2.581,2.963,1.252,1.335,1.335,1.552,1.538,2.315, + 2.963,1.083,1.185,1.289,1.287,1.540,1.533,2.336,2.963, + 0.9638,1.65,1.263,1.65,1.377,1.511,1.501,2.255,2.963, + 0.845,1.42,1.424,1.422,1.416,1.411,1.65,1.396,2.002, + 2.963,3.57,1.12,1.65,1.414,1.65,1.405,1.397,1.579, + 1.575,1.678,2.963,2.96,2.995,1.238,1.413,1.464,1.65, + 1.65,1.539,1.65,1.56,2.161,2.963,2.762,2.92,3.11,1.732, + 1.73,1.65,1.721,1.65,1.712,1.65,1.676,1.915,2.963,2.639, + 3.133,3.529,3.547,2.094,1.65,1.65,2.02,1.65,1.982,1.65, + 1.925,2.135,2.963/ C VERNER=0. E=HHEV*FR C II=ILOW(ITR) N1=NFIRST(IEL(II)) IF(II.NE.N1) + CALL QUIT('Verner fits only for ground states',ii,n1) IAT=NUMAT(IATM(II)) IZZ=IZ(IEL(II)) IF(IAT.GT.14) GO TO 10 IVER=IV0(IAT)+IZZ C C 1996 Expression C IF(E.LT.EMX(IVER)) THEN XX=E/E0(IVER)-Y0(IVER) YY=SQRT(XX*XX+Y1(IVER)*Y1(IVER)) AA=(XX-UN)*(XX-UN)+YW(IVER)*YW(IVER) BB=YY**(HALF*PV(IVER)-5.5) CC=(UN+SQRT(YY/YA(IVER)))**PV(IVER) FY=AA*BB/CC VERNER=S0(IVER)*T18*FY ELSE C C 1995 Expression for high energies C (ionization of inner shell electron) C YY=E/E95(IVER) XL=0. IF((IAT-IZZ).GE.10) XL=UN Q=HALF*P95(IVER)-5.5-XL AA=(YY-UN)*(YY-UN)+YW95(IVER)*YW95(IVER) BB=YY**Q CC=(UN+SQRT(YY/Y95(IVER)))**P95(IVER) FY=AA*BB/CC VERNER=S95(IVER)*T18*FY END IF RETURN C C Heavier elements C 10 IF(IAT.EQ.26) THEN VERNER=VERN26(E,IZZ) ELSE IF(IAT.EQ.16) THEN VERNER=VERN16(E,IZZ) ELSE IF(IAT.EQ.18) THEN VERNER=VERN18(E,IZZ) ELSE IF(IAT.EQ.20) THEN VERNER=VERN20(E,IZZ) ELSE CALL QUIT('VERNER - No data for this element',iat,izz) ENDIF C RETURN END C C C **************************************************************** C C FUNCTION VERN26(E,IZZ) C ====================== C C Photoionization cross-sections for ground states C of all Fe ions. C Verner D.A. et al. 1996, ApJ 465 C Verner & Yakovlev 1995, A&AS 109, 125 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' PARAMETER (T18=1.D-18,MVER=26) DIMENSION S0(MVER),E0(MVER),EMX(MVER) DIMENSION Y0(MVER),Y1(MVER),YW(MVER),YA(MVER),PV(MVER) DIMENSION S95(MVER),E95(MVER),Y95(MVER),YW95(MVER),P95(MVER) C DATA S0/3.062D-1,4.365D3,6.107D0,3.653D2,1.523D-3,5.259D-1,2.42D4, + 1.979D1,2.687D1,6.470D1,3.281D0,1.738D0,2.791D-3,1.454D-1, + 2.108D2,1.207D1,1.452D0,2.388D0,6.066D-5,4.455D-1,1.098D1, + 7.204D-2,2.580D4,1.276D1,1.195D1,8.099D1/ DATA E0/0.05461,0.1761,0.1698,25.44,0.7256,2.656,5.059,0.07098, + 6.741,68.86,8.284,6.295,0.1317,0.8509,0.05555,28.73, + 0.3444,31.9,7.519D-4,20.11,9.243,9.713,45.75,73.26, + 1057.,293.2/ DATA EMX/66.,76.17,87.05,106.7,128.8,152.7,178.3,205.5,921.1, + 959.,998.3,1039.,1081.,1125.,1181.,1216.,7651.,7769., + 7918.,8041.,8184.,8350.,8484.,8638.,5.D4,5.D4/ DATA Y0/1.382D2,9.272D1,1.76D2,0.,8.871D1,3.361D1,0.4546,2.542D3, + 2.494D1,1.19D-5,2.971D1,4.671D1,2.17D3,4.505D2,2.706D-4, + 0.,2.891D1,3.805D1,1.915D6,6.847D1,4.446D1,1.702D2, + 3.582D-2,0.,0.,0./ DATA Y1/0.2481,1.075D2,1.847D1,0.,5.28D-2,3.743D-3,2.683D1, + 4.672D2,8.251,6.57D-3,0.522,0.1425,6.852D-3,2.504, + 1.628,0.,3.404,0.4805,3.14D1,3.989,3.512,4.263,8.712D-3, + 0.,0.,0./ DATA YW/2.069D1,1.141D1,8.698,0.5602,5.064D1,1.558D1,2.516D-3, + 2.158D2,2.387D-4,2.778D-4,0.3279,0.3096,0.6938,0.4937, + 1.885D-3,0.,1.264,2.902D-2,4.398,2.757,1.748,9.551D-3, + 2.723D1,0.,0.,0./ DATA YA/2.671D7,6.298D3,1.555D3,8.913D0,3.736D1,1.450D1,4.850D4, + 1.745D4,1.807D2,2.062D1,5.360D1,1.130D2,2.487D3,1.239D3, + 2.045D4,5.150D2,3.960D2,2.186D1,1.606D6,4.236D1,7.637D1, + 1.853D2,1.358D0,4.914D1,5.769D1,3.288D1/ DATA PV/7.923,5.204,8.055,6.538,17.67,16.32,2.374,6.75,6.29, + 4.111,8.571,8.037,9.791,8.066,6.033,3.846,10.13,9.589, + 8.813,9.724,7.962,8.843,26.04,4.941,1.718,2.963/ DATA S95/6.298D1,4.624D1,4.422D1,4.81D1,5.143D1,5.246D1,5.21D1, + 5.336D1,2.205D2,2.392D2,2.449D2,3.325D2,3.316D2,3.367D2, + 1.496D2,3.383D2,1.15D1,8.327D0,1.155D1,8.619D0,8.773D0, + 1.181D1,9.098D1,1.157D1,1.195D1,8.099D1/ DATA E95/76.3,77.5,77.77,76.25,72.73,72.6,74.33,75.56,171.5, + 164.7,163.2,138.3,139.2,138.7,213.6,139.6,1067.,1249., + 1068.,1235.,1228.,1066.,1215.,1087.,1057.,293.2/ DATA Y95/1.479D1,2.155D1,2.336D1,2.286D1,2.428D1,2.751D1,3.306D1, + 3.855D1,5.298D1,5.276D1,5.452D1,5.09D1,5.237D1,5.279D1, + 7.000D1,5.459D1,3.412D1,5.000D1,3.578D1,5.000D1,5.000D1, + 4.116D1,5.000D1,5.086D1,5.769D1,3.288D1/ DATA YW95/0.2646,0.2599,0.2557,0.2449,0.1365,0.02105,0.02404, + 0.02667,1.508D-5,1.574D-5,1.594D-4,1.114D-5,1.107D-5, + 1.111D-5,0.1,1.179D-5,10*0./ DATA P95/7.672,7.138,7.017,7.043,7.028,6.823,6.509,6.265,4.154, + 4.204,4.187,4.446,4.41,4.407,3.7,4.366,1.922,1.65,1.895, + 1.65,1.65,1.827,1.65,1.722,1.718,2.963/ C VERN26=0. IVER=IZZ C C 1996 Expression C IF(E.LT.EMX(IVER)) THEN XX=E/E0(IVER)-Y0(IVER) YY=SQRT(XX*XX+Y1(IVER)*Y1(IVER)) AA=(XX-UN)*(XX-UN)+YW(IVER)*YW(IVER) BB=YY**(HALF*PV(IVER)-5.5) CC=(UN+SQRT(YY/YA(IVER)))**PV(IVER) FY=AA*BB/CC VERN26=S0(IVER)*T18*FY ELSE C C 1995 Expression for high energies C (ionization of inner shell electron) C YY=E/E95(IVER) XL=0. IF(IZZ.LE.16) XL=UN Q=HALF*P95(IVER)-5.5-XL AA=(YY-UN)*(YY-UN)+YW95(IVER)*YW95(IVER) BB=YY**Q CC=(UN+SQRT(YY/Y95(IVER)))**P95(IVER) FY=AA*BB/CC VERN26=S95(IVER)*T18*FY END IF C RETURN END C C C **************************************************************** C C FUNCTION VERN16(E,IZZ) C ====================== C C Photoionization cross-sections for ground states C of all Sulfur ions. C Verner D.A. et al. 1996, ApJ 465 C Verner & Yakovlev 1995, A&AS 109, 125 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' PARAMETER (T18=1.D-18,MVER=16) DIMENSION S0(MVER),E0(MVER),EMX(MVER) DIMENSION Y0(MVER),Y1(MVER),YW(MVER),YA(MVER),PV(MVER) DIMENSION S95(MVER),E95(MVER),Y95(MVER),YW95(MVER),P95(MVER) C DATA S0/4.564D4,3.136D2,6.666D0,2.606D0,5.072D-4,9.139D0,5.703D-1, + 3.161D1,9.646D3,5.364D1,1.275D1,3.49D-1,2.294D4,2.555D1, + 2.453D1,2.139D2/ DATA E0/18.08,8.787,2.027,2.173,0.1713,14.13,0.3757,14.62,0.1526, + 10.4,6.485,2.443,14.74,33.1,439.,110.4/ DATA EMX/170.,184.6,199.5,216.4,235.,255.7,2569.,2641.,2705., + 2782.,2859.,2941.,3029.,3107.,5.D4,5.D4/ DATA Y0/0.9935,2.782,15.68,19.75,94.24,0.,222.2,18.69,1.615D-3, + 17.75,34.26,227.9,2.203D-2,0.,0.,0./ DATA Y1/0.2486,0.1788,9.421,3.361,0.6265,0.,4.606,0.3037,0.4049, + 1.663,0.137,1.172,1.073D-2,0.,0.,0./ DATA YW/0.6385,0.7354,4.109,1.863,0.788,0.,1.503,1.153D-3,1.492, + 2.31,1.678,0.7033,27.38,0.,0.,0./ DATA YA/1.,3.442,54.54,66.41,198.6,1656.,146.,16.11,1438.,36.41, + 65.83,541.1,1.529,38.21,44.05,32.88/ DATA PV/13.61,12.81,8.611,8.655,13.07,3.626,11.35,8.642,5.977, + 7.09,7.692,7.769,25.68,5.037,1.765,2.963/ DATA S95/1.883D2,1.896D2,1.780D2,2.037D2,2.919D2,4.712D2,1.916D1, + 1.931D1,1.946D1,2.041D1,2.101D1,2.087D1,2.233D1,2.293D1, + 2.453D1,2.139D2/ DATA E95/91.52,90.58,92.46,87.44,74.11,57.47,495.2,489.1,493.7, + 480.2,475.8,482.8,466.9,466.7,439.,110.4/ DATA Y95/71.93,75.38,149.8,93.1,48.64,36.1,35.55,50.,35.68,50., + 50.,37.42,50.,44.59,44.05,32.88/ DATA YW95/0.2485,0.2934,0.02142,9.497D-3,0.02785,0.0248,10*0./ DATA P95/3.633,3.635,3.319,3.565,4.142,4.742,1.742,1.65,1.737, + 1.65,1.65,1.72,1.65,1.668,1.765,2.963/ C VERN16=0. IVER=IZZ C C 1996 Expression C IF(E.LT.EMX(IVER)) THEN XX=E/E0(IVER)-Y0(IVER) YY=SQRT(XX*XX+Y1(IVER)*Y1(IVER)) AA=(XX-UN)*(XX-UN)+YW(IVER)*YW(IVER) BB=YY**(HALF*PV(IVER)-5.5) CC=(UN+SQRT(YY/YA(IVER)))**PV(IVER) FY=AA*BB/CC VERN16=S0(IVER)*T18*FY ELSE C C 1995 Expression for high energies C (ionization of inner shell electron) C YY=E/E95(IVER) XL=0. IF(IZZ.LE.6) XL=UN Q=HALF*P95(IVER)-5.5-XL AA=(YY-UN)*(YY-UN)+YW95(IVER)*YW95(IVER) BB=YY**Q CC=(UN+SQRT(YY/Y95(IVER)))**P95(IVER) FY=AA*BB/CC VERN16=S95(IVER)*T18*FY END IF C RETURN END C C C **************************************************************** C C FUNCTION VERN18(E,IZZ) C ====================== C C Photoionization cross-sections for ground states C of all Argon ions. C Verner D.A. et al. 1996, ApJ 465 C Verner & Yakovlev 1995, A&AS 109, 125 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' PARAMETER (T18=1.D-18,MVER=18) DIMENSION S0(MVER),E0(MVER),EMX(MVER) DIMENSION Y0(MVER),Y1(MVER),YW(MVER),YA(MVER),PV(MVER) DIMENSION S95(MVER),E95(MVER),Y95(MVER),YW95(MVER),P95(MVER) C DATA S0/2.106D1,2.503D1,3.58D1,2.035D1,9.946D0,1.080D0,3.693D0, + 3.295D1,8.279D-1,8.204D0,1.76D3,7.018D-1,2.459D-2, + 4.997D-2,2.571D4,2.135D1,3.108D1,1.69D2/ DATA E0/17.09,24.94,14.17,6.953,10.31,0.544,0.02966,3.844, + 0.1926,10.4,0.1257,5.31,0.3209,1.557,18.88,41.54, + 446.8,139.9/ DATA EMX/249.2,266.2,280.1,298.7,320.,342.6,366.7,392.5,3361., + 3446.,3523.,3613.,3702.,3798.,3898.,3988.,5.D4,5.D4/ DATA Y0/1.688,0.9299,2.384,7.501,6.406,1.7D2,4.383D-4,0.,38.14, + 38.04,3.286D-3,1.099D2,2.068D3,4.552D2,2.445D-2,0.,0.,0./ DATA Y1/0.8943,0.7195,1.794,0.1806,3.659D-3,15.87,2.513,0.,4.649, + 0.639,0.3226,0.2202,21.13,6.459,1.054D-2,0.,0.,0./ DATA YW/0.4185,0.5108,0.6316,0.8842,0.4885,11.07,1.363D-2,0., + 1.434,9.203D-4,1.975,0.4987,0.6692,0.2938,29.09,0.,0.,0./ DATA YA/2.645D2,1.272D2,3.776D1,1.4D1,7.444D1,9.419D2,9.951D3, + 7.082D2,2.392D2,1.495D1,1.579D3,1.001D2,2.285D3,5.031D2, + 1.475D0,4.118D1,3.039D1,3.288D1/ DATA PV/4.796,4.288,5.742,9.595,6.261,7.582,7.313,4.645,11.21, + 11.15,6.714,8.939,8.81,8.966,26.34,4.945,2.092,2.963/ DATA S95/8.372D1,1.937D2,2.281D2,2.007D2,2.474D2,2.786D2,3.204D2, + 4.198D2,2.931D1,1.585D1,2.796D1,1.666D1,2.888D1,2.874D1, + 2.883D1,3.003D1,3.108D1,1.69D2/ DATA E95/164.7,108.5,102.5,107.3,98.35,92.33,85.63,73.68,467.9, + 612.6,478.9,602.8,473.1,474.9,475.6,468.,466.8,139.9/ DATA Y95/54.52,70.,43.8,70.,42.84,42.2,42.3,44.19,17.44,50., + 19.17,50.,20.42,22.35,26.15,28.54,30.39,32.88/ DATA YW95/0.627,0.1,7.167D-3,0.1,7.283D-3,7.408D-3,7.258D-3, + 7.712D-3,10*0./ DATA P95/3.328,3.7,4.046,3.7,4.125,4.227,4.329,4.492,2.362, + 1.65,2.271,1.65,2.234,2.171,2.074,2.037,2.092,2.963/ C VERN18=0. IVER=IZZ C C 1996 Expression C IF(E.LT.EMX(IVER)) THEN XX=E/E0(IVER)-Y0(IVER) YY=SQRT(XX*XX+Y1(IVER)*Y1(IVER)) AA=(XX-UN)*(XX-UN)+YW(IVER)*YW(IVER) BB=YY**(HALF*PV(IVER)-5.5) CC=(UN+SQRT(YY/YA(IVER)))**PV(IVER) FY=AA*BB/CC VERN18=S0(IVER)*T18*FY ELSE C C 1995 Expression for high energies C (ionization of inner shell electron) C YY=E/E95(IVER) XL=0. IF(IZZ.LE.8) XL=UN Q=HALF*P95(IVER)-5.5-XL AA=(YY-UN)*(YY-UN)+YW95(IVER)*YW95(IVER) BB=YY**Q CC=(UN+SQRT(YY/Y95(IVER)))**P95(IVER) FY=AA*BB/CC VERN18=S95(IVER)*T18*FY END IF C RETURN END C C C **************************************************************** C C FUNCTION VERN20(E,IZZ) C ====================== C C Photoionization cross-sections for ground states C of all Calcium ions. C Verner D.A. et al. 1996, ApJ 465 C Verner & Yakovlev 1995, A&AS 109, 125 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' PARAMETER (T18=1.D-18,MVER=20) DIMENSION S0(MVER),E0(MVER),EMX(MVER) DIMENSION Y0(MVER),Y1(MVER),YW(MVER),YA(MVER),PV(MVER) DIMENSION S95(MVER),E95(MVER),Y95(MVER),YW95(MVER),P95(MVER) C DATA S0/5.37D5,1.064D7,3.815D1,7.736D0,1.523D-1,7.642D1,4.76D-1, + 6.641D-1,2.076D2,1.437D1,9.384D-1,1.227D1,1.849D3, + 1.116D0,5.513D1,1.293D0,2.028D4,1.105D1,1.936D1,1.369D2/ DATA E0/12.78,15.53,24.36,4.255,0.6882,9.515,0.808,1.366,0.0552, + 16.05,0.2288,23.45,10.08,9.98,130.9,4.293,26.18,94.72, + 629.7,172.9/ DATA EMX/34.43,40.9,373.1,394.4,417.5,442.3,468.7,496.7,527., + 556.9,4265.,4362.,4453.,4555.,4659.,4767.,4880.,4982., + 5.D4,5.D4/ DATA Y0/1.012D-3,2.161D-3,1.802,14.67,121.,4.829,148.7,103.9, + 2.826D-4,0.,24.78,24.17,6.138D-3,71.04,1.833D-2,0.9363, + 2.402D-2,0.,0.,0./ DATA Y1/1.851D-2,6.706D-2,1.233,3.298D-2,3.876,5.824,1.283,3.329, + 1.657,0.,3.1,0.5469,69.31,5.311,0.9359,4.589D-2,9.323D-3, + 0.,0.,0./ DATA YW/0.4477,0.6453,0.3126,1.369,8.277,2.471,0.572,0.2806, + 1.843D-3,0.,1.39,6.842D-4,241.,3.879,9.084D-2,3.461D-5, + 28.03,0.,0.,0./ DATA YA/0.3162,0.779,293.1,13.55,150.2,89.73,368.2,318.8,1.79D4, + 698.9,254.9,13.12,1.792D4,59.18,382.8,16.91,1.456,38.18, + 39.21,32.88/ DATA PV/12.42,21.3,3.944,12.36,10.61,5.141,8.634,8.138,5.893, + 3.857,11.03,9.771,2.868,9.005,2.023,14.38,25.6,4.192, + 1.862,2.963/ DATA S95/9.017D1,7.314D1,1.945D2,1.542D2,1.622D2,1.855D2,2.181D2, + 2.788D2,1.934D2,6.616D2,1.547D1,1.324D1,1.57D1,1.384D1, + 1.417D1,1.665D1,1.486D1,1.82D1,1.936D1,1.369D2/ DATA E95/44.87,44.98,126.,141.3,138.4,130.3,120.8,107.,129.3, + 65.11,701.,750.3,698.9,739.6,734.2,686.2,723.5,664., + 629.7,172.9/ DATA Y95/14.65,18.98,68.19,99.06,88.11,69.93,58.16,47.68,70., + 43.71,31.97,50.,32.18,50.,50.,34.43,50.,39.79,39.21, + 32.88/ DATA YW95/0.2754,0.2735,4.791D-4,1.107D-3,4.384D-4,1.4D-5, + 4.346D-6,4.591D-6,0.1,7.881D-6,10*0./ DATA P95/7.498,7.152,3.77,3.446,3.521,3.707,3.907,4.2,3.7,4.937, + 1.858,1.65,1.851,1.65,1.65,1.823,1.65,1.777,1.862, + 2.963/ C VERN20=0. IVER=IZZ C C 1996 Expression C IF(E.LT.EMX(IVER)) THEN XX=E/E0(IVER)-Y0(IVER) YY=SQRT(XX*XX+Y1(IVER)*Y1(IVER)) AA=(XX-UN)*(XX-UN)+YW(IVER)*YW(IVER) BB=YY**(HALF*PV(IVER)-5.5) CC=(UN+SQRT(YY/YA(IVER)))**PV(IVER) FY=AA*BB/CC VERN20=S0(IVER)*T18*FY ELSE C C 1995 Expression for high energies C (ionization of inner shell electron) C YY=E/E95(IVER) XL=0. IF(IZZ.LE.10) XL=UN Q=HALF*P95(IVER)-5.5-XL AA=(YY-UN)*(YY-UN)+YW95(IVER)*YW95(IVER) BB=YY**Q CC=(UN+SQRT(YY/Y95(IVER)))**P95(IVER) FY=AA*BB/CC VERN20=S95(IVER)*T18*FY END IF C RETURN END C C C **************************************************************** C C FUNCTION GAUNT(I,FR) C ==================== C C Hydrogenic bound-free Gaunt factor for the principal quantum C number I and frequency FR C INCLUDE 'IMPLIC.FOR' PARAMETER (UN=1.) DIMENSION CGT(7,10),X(7),FRKW(10) DATA CGT/0.,12.803223,-5.5759888,1.2302628,-2.9094219D-3, * 7.3993579D-6,-8.7356966D-9,-2.0244141,2.1325684,-1.2709045, * 1.1595421,-2.0735860D-3,2.7033384D-6,0.,-0.23387146, * 0.52471924,-0.55936432,1.1450949,-1.9366592D-3,2.3572356D-6, * 0.,-5.4418565D-2,0.19683564,-0.31190730,1.1306695, * -1.3482273D-3,-4.6949424D-6,2.3548636D-8,-8.9182854D-3, * 5.5545091D-2,-0.16051018,1.1190904,-1.0401085D-3, * -6.9943488D-6,2.8496742D-8,-5.5303574D-3,4.1921183D-2, * -0.13075417,1.1168376,-8.9466573D-4,-8.8393133D-6, * 3.4696768D-8,-2.2752881D-3,2.3350812D-2,-9.5441161D-2, * 1.1128632,-7.4833260D-4,-1.0244504D-5,3.8595771D-8, * -9.7200274D-4,1.3298411D-2,-7.1010560D-2,1.1093137, * -6.2619148D-4,-1.1342068D-5,4.1477731D-8,-4.9576163D-4, * 8.5139736D-3,-5.6046560D-2,1.1078717,-5.4837392D-4, * -1.2157943D-5,4.3796716D-8,-2.9467046D-4,6.1516856D-3, * -4.7326370D-2,1.1052734,-4.4341570D-4,-1.3235905D-5, * 4.7003140D-8/ DATA FRKW/6.6D15,9*3.3D15/ IF(I.LE.10) THEN X(5)=FR/2.99793D14 X(6)=X(5)*X(5) X(7)=X(6)*X(5) X(4)=UN X(3)=UN/X(5) X(2)=X(3)*X(3) X(1)=X(2)*X(3) GAUNT=0. DO 10 J=1,7 GAUNT=GAUNT+CGT(J,I)*X(J) 10 CONTINUE ELSE GAUNT=UN ENDIF RETURN END C C C **************************************************************** C C 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 'IMPLIC.FOR' GNTK=1. Y=1./FR IF(I.EQ.1) THEN GNTK=0.9916+Y*(2.71852D13-Y*2.26846D30) ELSE IF(I.EQ.2) THEN GNTK=1.1050-Y*(2.37490D14-Y*4.07677D28) ELSE IF(I.EQ.3) THEN GNTK=1.1010-Y*(0.98632D14-Y*1.03540D28) END IF END C C C **************************************************************** C C SUBROUTINE SPSIGK(IB,FR,SIGSP) C ============================== C C Non-standard evaluation of the photoionization cross-sections C Basically user-suppled procedure; here are some examples C INCLUDE 'IMPLIC.FOR' SIGSP=0. C C Special formula for the He I ground state C IF(IB.EQ.-201) SIGSP=7.3D-18*EXP(1.373-2.311E-16*FR) C C Special formula for the averaged level of He I C IF(IB.EQ.-202) SIGSP=SGHE12(FR) C C Carbon ground configuration levels 2p2 1D and 1S C IF(IB.EQ.-602.OR.IB.EQ.-603) THEN CALL CARBON(IB,FR,SG) SIGSP=SG END IF C C Hidalgo (Ap.J. 153, 981, 1968) photoionization data C IF(IB.LE.-101.AND.IB.GE.-137) SIGSP=HIDALG(IB,FR) C C Reilman and Manson (Ap.J. Suppl. 40, 815, 1979) photoionization data C IF(IB.LE.-301.AND.IB.GE.-337) SIGSP=REIMAN(IB,FR) RETURN END C C C ********************************************************************* C C 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 C (At the moment, only a few transitions are considered) C INCLUDE 'IMPLIC.FOR' DIMENSION WL1(20),WL2(20),WL(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., * 20*0., * 20*0., *.0220,.0390,.0800,.1500,.3500,.4000,.4900,.6200,.7200,.7800, *.8500,.9300,1.020, * 7*0./ SAVE WL1,WL2,SIG0 C INDEX=-IB-100 NUM=20 IF(INDEX.GE.13.AND.INDEX.LE.27) NUM=15 DO I=1,NUM IF(INDEX.LT.13) WL(I)=WL1(I) IF(INDEX.GE.13) WL(I)=WL2(I) SIGS(I)=SIG0(I,INDEX) END DO C WLAM=2.997925D18/FR IL=1 IR=NUM DO I=1,NUM-1 IF(WLAM.GE.WL(I).AND.WLAM.LE.WL(I+1)) THEN IL=I IR=I+1 GO TO 60 END IF END DO C C LINEAR INTERPOLATION: C 60 SIGM=(SIGS(IR)-SIGS(IL))*(WLAM-WL(IL))/(WL(IR)-WL(IL)) * + SIGS(IL) C C IF OUTSIDE WAVELENGTH RANGE SET TO FIRST(LAST) VALUE: C IF(WLAM.LE.WL(1)) SIGM=SIGS(1) IF(WLAM.GE.WL(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.D-18 RETURN END C C C ********************************************************************* C C FUNCTION REIMAN(IB,FR) C ====================== C C Read table of photon energies and photo-ionization cross-sections C from Reilman & Manson (1979, Ap. J. Suppl., 40, 815) for the species C indicated by IB C C Compute linearly interpolated value of the cross-section C at the frequency FR. C C (At the moment, only a few transitions are considered) C INCLUDE 'IMPLIC.FOR' DIMENSION HEV(30),F0(30),SIG0(30,2),SIGS(30) C DATA HEV / * 130.,160.,190.,210.,240.,270.,300.,330.,360.,390., * 420.,450.,480.,510.,540.,570.,600.,630.,660.,690., * 720.,750.,780.,810.,840.,870.,900.,930.,960.,990./ DATA SIG0 / * 3*0., 4.422D-1, 3.478D-1, * 2.794D-1, 2.286D-1, 1.899D-1, 1.598D-1, 1.360D-1, * 1.169D-1, 1.013D-1, 8.845D-2, 7.776D-2, 6.877D-2, * 6.114D-2, 5.463D-2, 4.904D-2, 4.419D-2, 3.998D-2, * 3.629D-2, 3.305D-2, 3.019D-2, 2.766D-2, 2.540D-2, * 2.339D-2, 2.158D-2, 1.996D-2, 1.850D-2, 1.718D-2, * 4*0., 1.981D-1, 1.584D-1, * 1.290D-1, 1.066D-1, 8.932D-2, 7.567D-2, 6.475D-2, * 5.589D-2, 4.862D-2, 4.259D-2, 3.754D-2, 3.329D-2, * 2.966D-2, 2.656D-2, 2.388D-2, 2.157D-2, 1.954D-2, * 1.777D-2, 1.621D-2, 1.484D-2, 1.362D-2, 1.253D-2, * 1.155D-2, 1.067D-2, 9.888D-3, 9.179D-3/ SAVE HEV,SIG0 C INDEX=-IB-300 NUM=30 DO I=1,NUM F0(I)=HEV(I)*2.418573D14 SIGS(I)=SIG0(I,INDEX) END DO C IL=1 IR=NUM DO I=1,NUM-1 IF(FR.GE.F0(I).AND.FR.LE.F0(I+1)) THEN IL=I IR=I+1 GO TO 60 END IF END DO C C LINEAR INTERPOLATION: C 60 SIGM=(SIGS(IR)-SIGS(IL))*(FR-F0(IL))/(F0(IR)-F0(IL)) * + SIGS(IL) C C IF OUTSIDE WAVELENGTH RANGE SET TO FIRST(LAST) VALUE: C IF(FR.LE.F0(1)) SIGM=SIGS(1) IF(FR.GE.F0(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 REIMAN=SIGM*1.D-18 RETURN END C C C **************************************************************** C C SUBROUTINE CARBON(IB,FR,SG) C =========================== C C Photoionization cross-section for neutral carbon 2p1D and 2p1S C levels (G.B.Taylor - private communication) C INCLUDE 'IMPLIC.FOR' DIMENSION FR2(34),SG2(34),FR3(45),SG3(45) PARAMETER (FR0=3.28805D15, NC2=34, NC3=45) DATA FR2/ 0.74, 0.75, 0.76, 0.77, 0.78, 0.79, 0.80, 0.81, 0.82, * 0.83, 0.85, 0.86, 0.87, 0.88, 0.89, 0.90, * 0.91, 0.92, 0.93, 0.94, 0.95, 0.96, 0.97, 0.98, 0.99, * 1.00, 1.10, 1.20, 1.30, 1.45, 1.50, 1.60, 1.80, 2./ DATA SG2/ 12.04, 12.03, 12.09, 12.26, 12.60, 13.24, 14.36, 16.24, * 19.28, 23.94, 37.41, 42.88, 44.76, 43.41, 40.46, 37.19, * 34.26, 31.82, 29.96, 28.57, 27.68, 27.37, 27.84, 29.69, * 34.45, 46.35, 13.80, 11.54, 10.40, 8.96, 8.54, 7.47, * 6.53, 5.66/ DATA FR3/ 0.66, 0.68, 0.70, 0.72, 0.74, 0.76, 0.78, 0.80, 0.82, * 0.84, 0.86, 0.864,0.866,0.868,0.87, 0.874,0.876,0.88, * 0.882,0.884,0.886,0.888,0.89 ,0.894,0.896,0.898,0.90, * 0.904,0.908,0.910,0.920,0.94, 0.98, 1.00, 1.10, 1.20, * 1.26, 1.34, 1.36, 1.40, 1.46, 1.60, 1.70, 1.80, 2./ DATA SG3/ 13.94, 13.29, 12.56, 11.73, 10.82, 10.18, 8.62, 7.27, * 5.74, 4.14, 4.61, 5.92, 6.94, 8.34, 10.21, 16.12, * 20.64, 34.56, 44.82, 57.71, 73.09, 89.99,106.38,127.08, * 128.38,124.44,117.17, 99.32, 82.95, 76.05, 52.65, 33.23, * 21.29, 18.69, 12.62, 11.44, 9.77, 7.53, 10.47, 9.65, * 10.19, 7.28, 6.70, 6.11, 4.96/ SAVE FR2,SG2,FR3,SG3 C F=FR/FR0 IF(IB.NE.-602) GO TO 25 J=2 IF(F.LE.FR2(1)) GO TO 20 DO I=2,NC2 J=I IF(F.GT.FR2(I-1).AND.F.LE.FR2(I)) GO TO 20 END DO 20 SG=(F-FR2(J-1))/(FR2(J)-FR2(J-1))*(SG2(J)-SG2(J-1))+SG2(J-1) SG=SG*1.D-18 25 IF(IB.NE.-603) GO TO 50 J=2 IF(F.LE.FR3(1)) GO TO 40 DO I=2,NC3 J=I IF(F.GT.FR3(I-1).AND.F.LE.FR3(I)) GO TO 40 END DO 40 SG=(F-FR3(J-1))/(FR3(J)-FR3(J-1))*(SG3(J)-SG3(J-1))+SG3(J-1) SG=SG*1.D-18 50 CONTINUE RETURN END C C C **************************************************************** C FUNCTION SGHE12(FR) C =================== C C Special formula for the photoionization cross-section from the C averaged level of He I C INCLUDE 'IMPLIC.FOR' PARAMETER (C1=3.D0,C2=9.D0,C3=1.6D1,T15=1.D-15, * A1=6.45105D-18,A2=3.02D-19,A3=9.9847D-18,A4=1.1763673D-17, * A5=3.63662D-19,A6=-2.783D2,A7=1.488D1,A8=-2.311D-1, * E1=3.5D0,E2=3.6D0,E3=1.91D0,E4=2.9D0,E5=3.3D0) C X=FR*T15 XX=LOG(FR) SGHE12=(C1*(A1/X**E1+A2/X**E2)+A3/X**E3+C2*(A4/X**E4+A5/X**E5)+ * C1*EXP(A6+XX*(A7+XX*A8)))/C3 RETURN END C C C **************************************************************** C C FUNCTION SBFHE1(II,IB,FR,GG) C ============================ C C Calculates photoionization cross sections of neutral helium C from states with n = 1, 2, 3, 4. C C The levels are either non-averaged (l,s) states, or some C averaged levels. C The program allows only two standard possibilities of C constructing averaged levels: C i) all states within given principal quantum number n (>1) are C lumped together C ii) all siglet states for given n, and all triplet states for C given n are lumped together separately (there are thus two C explicit levels for a given n) C C The cross sections are calculated using appropriate averages C of the Opacity Project cross sections, calculated by procedure C HEPHOT C C For IB=21 or IB=23, Koester (1985, AA 149, 423) fits C C Input parameters: C II - index of the lower level (in the numbering of explicit C levels) C IB - photoionization switch IBF for the given transition C = 10 - means that the given transition is from an C averaged level C = 11 or 21 - the given transition is from non-averaged C singlet state C = 13 or 23 - the given transition is from non-averaged C triplet state C FR - frequency C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' C NI=NQUANT(II) IGI=INT(G(II)+0.01) IS=IB-10 IF(IB.GT.20) IS=IB-20 sbfhe1=0. C C ---------------------------------------------------------------- C IB=11 or 13 - photoionization from an non-averaged (l,s) level C ---------------------------------------------------------------- C IF(IS.EQ.1.OR.IS.EQ.3) THEN IL=(IGI/IS-1)/2 IF(IB.LT.20) THEN SBFHE1=HEPHOT(IS,IL,NI,FR) ELSE SBFHE1=CKOEST(IS,IL,NI,FR,GG) ENDIF END IF C C ---------------------------------------------------------------- C IS=10 - photoionization from an averaged level C ---------------------------------------------------------------- C IF(IS.EQ.0) THEN IF(NI.EQ.2) THEN C C ******** photoionization from an averaged level with n=2 C IF(IGI.EQ.4) THEN C C a) lower level is an averaged singlet state C SBFHE1=(HEPHOT(1,0,2,FR)+3.D0*HEPHOT(1,1,2,FR))/9.D0 ELSE IF(IGI.EQ.12) THEN C C b) lower level is an averaged triplet state C SBFHE1=(HEPHOT(3,0,2,FR)+3.D0*HEPHOT(3,1,2,FR))/9.D0 ELSE IF(IGI.EQ.16) THEN C C c) lower level is an average of both singlet and triplet states C SBFHE1=(HEPHOT(1,0,2,FR)+3.D0*(HEPHOT(1,1,2,FR)+ * HEPHOT(3,0,2,FR))+9.D0*HEPHOT(3,1,2,FR))/1.6D1 ELSE GO TO 10 END IF C C C ******** photoionization from an averaged level with n=3 C ELSE IF(NI.EQ.3) THEN IF(IGI.EQ.9) THEN C C a) lower level is an averaged singlet state C SBFHE1=(HEPHOT(1,0,3,FR)+3.D0*HEPHOT(1,1,3,FR)+ * 5.D0*HEPHOT(1,2,3,FR))/9.D0 ELSE IF(IGI.EQ.27) THEN C C b) lower level is an averaged triplet state C SBFHE1=(HEPHOT(3,0,3,FR)+3.D0*HEPHOT(3,1,3,FR)+ * 5.D0*HEPHOT(3,2,3,FR))/9.D0 ELSE IF(IGI.EQ.36) THEN C C c) lower level is an average of both singlet and triplet states C SBFHE1=(HEPHOT(1,0,3,FR)+3.D0*HEPHOT(1,1,3,FR)+ * 5.D0*HEPHOT(1,2,3,FR)+ * 3.D0*HEPHOT(3,0,3,FR)+9.D0*HEPHOT(3,1,3,FR)+ * 15.D0*HEPHOT(3,2,3,FR))/3.6D0 ELSE GO TO 10 END IF ELSE IF(NI.EQ.4) THEN C C ******** photoionization from an averaged level with n=4 C IF(IGI.EQ.16) THEN C C a) lower level is an averaged singlet state C SBFHE1=(HEPHOT(1,0,4,FR)+3.D0*HEPHOT(1,1,4,FR)+ * 5.D0*HEPHOT(1,2,4,FR)+ * 7.D0*HEPHOT(1,3,4,FR))/1.6D1 ELSE IF(IGI.EQ.48) THEN C C b) lower level is an averaged triplet state C SBFHE1=(HEPHOT(3,0,4,FR)+3.D0*HEPHOT(3,1,4,FR)+ * 5.D0*HEPHOT(3,2,4,FR)+ * 7.D0*HEPHOT(3,3,4,FR))/1.6D1 ELSE IF(IGI.EQ.64) THEN C C c) lower level is an average of both singlet and triplet states C SBFHE1=(HEPHOT(1,0,4,FR)+3.D0*HEPHOT(1,1,4,FR)+ * 5.D0*HEPHOT(1,2,4,FR)+ * 7.D0*HEPHOT(1,3,4,FR)+ * 3.D0*HEPHOT(3,0,4,FR)+ * 9.D0*HEPHOT(3,1,4,FR)+ * 15.D0*HEPHOT(3,2,4,FR)+ * 21.D0*HEPHOT(3,3,4,FR))/6.4D1 ELSE GO TO 10 END IF ELSE GO TO 10 END IF END IF RETURN 10 WRITE(6,601) NI,IGI,IS WRITE(10,601) NI,IGI,IS 601 FORMAT(1H0/' INCONSISTENT INPUT TO PROCEDURE SBFHE1'/ * ' QUANTUM NUMBER =',I3,' STATISTICAL WEIGHT',I4,' S=',I3) call quit(' ',ni,igi) END C C C **************************************************************** C C 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 'IMPLIC.FOR' INTEGER S,L,SS,LL PARAMETER (TENM18=1.D-18, FRH=3.28805D15, TWO=2.D0, * TENLG=2.302585093, PHOT0=2.815D29) DIMENSION COEF(4,53),IST(3,2),N0(3,2), * FL0(53),A(53),B(53),XFITM(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 SAVE COEF,IST,N0,FL0,A,B,XFITM 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/FRH) X=FL-FL0(I) IF(X.GE.-0.001D0) THEN IF(X.LT.XFITM(I)) THEN P=COEF(4,I) DO K=1,3 P=X*P+COEF(4-K,I) END DO HEPHOT=TENM18*EXP(TENLG*P) ELSE HEPHOT=TENM18*EXP(TENLG*(A(I)+B(I)*X)) 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=TWO*N*N HEPHOT=PHOT0/FREQ/FREQ/FREQ/N**5*(2*L+1)*S/GN RETURN END C C C **************************************************************** C C FUNCTION CKOEST(S,L,N,FREQ,GG) C ============================== C C EVALUATES HE I PHOTOIONIZATION CROSS SECTION USING C KOESTER'S FITS (1985, AA 149, 423) C C CALLING SEQUENCE INCLUDES: C S = MULTIPLICITY, EITHER 1 OR 3 C L = ANGULAR MOMENTUM, 0, 1, OR 2; C for L > 2 - hydrogenic expresion C N = PRINCIPAL QUANTUM NUMBER C FREQ = FREQUENCY C GG = STATISTICAL WEIGHT C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INTEGER S,L,SS,LL PARAMETER (PHOT0=2.815D29) DIMENSION COEF(3,11),IST(3) C DATA IST/1,2,6/ C DATA COEF/ . -58.229, 4.3965, -0.22134 , . -68.438, 5.7453, -0.26277 , . -67.310, 6.1831, -0.32244 , . -92.020, 10.313 , -0.45090 , . -68.936, 5.2666, -0.15812 , . -63.408, 3.8797, -0.12479 , . -63.778, 4.5102, -0.18213 , . -76.903, 6.3639, -0.21565 , . -61.027, 3.1833, -0.043675, . -83.287, 7.1751, -0.20821 , . -83.287, 7.1751, -0.20821 / C SAVE COEF,IST C IF(L.GT.2) GO TO 20 C C SELECT BEGINNING AND END OF COEFFICIENTS C SS=(S-1)/2 LL=2*L NSL=IST(N)+LL+SS C C EVALUATE CROSS SECTION C X=LOG(CAS/FREQ) CKOEST=EXP(COEF(1,NSL)+X*(COEF(2,NSL)+X*COEF(3,NSL)))/GG RETURN C C Hydrogenic expression for L > 2 C [multiplied by relative population of state (s,l,n), ie. C by stat.weight(s,l)/stat.weight(n)] C 20 GN=TWO*N*N CKOEST=PHOT0/FREQ/FREQ/FREQ/N**5*(2*L+1)*S/GN RETURN END C C C ****************************************************************** C C FUNCTION TOPBAS(FREQ,FREQ0,TYPLV) C ================================== C C Procedure calculates the photo-ionisation cross section SIGMA in C [cm^2] at frequency FREQ. FREQ0 is the threshold frequency from C level I of ion KI. Threshold cross-sections will be of the order C of the numerical value of 10^-18. C Opacity-Project (OP) interpolation fit formula C INCLUDE 'IMPLIC.FOR' PARAMETER (E10=2.3025851) PARAMETER (MMAXOP = 200,! maximum number of levels in OP data + MOP = 15 )! maximum number of fit points per level CHARACTER*10 IDLVOP(MMAXOP) ! level identifyer Opacity-Project data CHARACTER*10 TYPLV LOGICAL*2 LOPREA COMMON /TOPB/ SOP(MOP,MMAXOP) ,! sigma = alog10(sigma/10^-18) of fit point + XOP(MOP,MMAXOP) ,! x = alog10(nu/nu0) of fit point + NOP(MMAXOP) ,! number of fit points for current level + NTOTOP ,! total number of levels in OP data + IDLVOP ,! level identifyer Opacity-Project data + LOPREA ! .T. OP data read in; .F. OP data not yer read in DIMENSION XFIT(MOP) ,! local array containing x for OP data + SFIT(MOP) ! local array containing sigma for OP data C TOPBAS=0. C C Read OP data if not yet done C IF (.NOT.LOPREA) CALL OPDATA X = LOG10(FREQ/FREQ0) DO IOP = 1,NTOTOP IF (IDLVOP(IOP).EQ.TYPLV) THEN C level has been detected in OP-data file IF (NOP(IOP).LE.0) GO TO 20 DO IFIT = 1,NOP(IOP) XFIT(IFIT) = XOP(IFIT,IOP) SFIT(IFIT) = SOP(IFIT,IOP) END DO SIGM = YLINTP (X,XFIT,SFIT,NOP(IOP),MOP) SIGM = 1.D-18*EXP(E10*SIGM) TOPBAS=SIGM GO TO 10 END IF END DO 10 RETURN C Level is not found ,or no data for this level, in RBF.DAT 20 WRITE (61,100) TYPLV 100 FORMAT ('SIGMA.......: OP DATA NOT AVAILABLE FOR LEVEL ',A10) RETURN END C C ****************************************************************** C C SUBROUTINE OPDATA C ================= C C Procedure reads photo-ionization cross sections fit coefficients C based on Opacity-Project (OP) data from file RBF.DAT C Data, as stored, requires linear interpolation. C C Meaning of global variables: C NTOTOP = total number of levels in Opacity Project data C IDLVOP() = level identifyer of current level C NOP() = number of fit points for current level C XOP(,) = x = alog10(nu/nu0) of fit point C SOP(,) = sigma = alog10(sigma/10^-18) of fit point C INCLUDE 'IMPLIC.FOR' PARAMETER (MMAXOP = 200,! maximum number of levels in OP data + MOP = 15 )! maximum number of fit points per level CHARACTER*10 IDLVOP(MMAXOP) ! level identifyer Opacity-Project data LOGICAL*2 LOPREA COMMON /TOPB/ SOP(MOP,MMAXOP) ,! sigma = alog10(sigma/10^-18) of fit point + XOP(MOP,MMAXOP) ,! x = alog10(nu/nu0) of fit point + NOP(MMAXOP) ,! number of fit points for current level + NTOTOP ,! total number of levels in OP data + IDLVOP ,! level identifyer Opacity-Project data + LOPREA ! .T. OP data read in; .F. OP data not yer read in CHARACTER*4 IONID C OPEN (UNIT=40,FILE='RBF.DAT',STATUS='OLD') C Skip header DO IREAD = 1, 21 READ (40,*) END DO IOP = 0 C = initialize sequential level index op Opacity Project data C Read number of elements in file READ (40,*) NEOP DO IEOP = 1, NEOP C Skip element name header DO IREAD = 1, 3 READ (40,*) END DO C Read number of ionization stages of current element in file READ (40,*) NIOP DO IIOP = 1, NIOP C Read ion identifyer, atomic & electron number, # of levels C for current ion READ (40,*) IONID, IATOM_OP, IELEC_OP, NLEVEL_OP DO ILOP = 1, NLEVEL_OP C Increase sequential level index of Opacity Project data IOP = IOP+1 C Read level identifyer and number of sigma fit points READ (40,*) IDLVOP(IOP), NOP(IOP) C Read normalized log10 frequency and log10 cross section values DO IS = 1, NOP(IOP) READ (40,*) INDEX, XOP(IS,IOP), SOP(IS,IOP) END DO END DO END DO END DO NTOTOP = IOP C = total number of levels in Opacity Project data LOPREA = .TRUE. C = set flag as data has been read in C RETURN END C C C C ****************************************************************** C C FUNCTION YLINTP (XINT,X,Y,N,NTOT) C ================================= C C linear interpolation routine. Determines YINT = Y(XINT) from C grid Y(X) with N points and dimension NTOT. C INCLUDE 'IMPLIC.FOR' DIMENSION X(NTOT),Y(NTOT) C C bisection (see Numerical Recipes par 3.4 page 90) JL = 0 JU = N+1 10 IF (JU-JL.GT.1) THEN JM = (JU+JL)/2 IF ((X(N).GT.X(1)).EQV.(XINT.GT.X(JM))) THEN JL = JM ELSE JU = JM END IF GO TO 10 END IF J = JL IF (J.EQ.N) J = J-1 IF (J.EQ.0) J = J+1 CM42 version: enable extrapolation C RC = (Y(J+1)-Y(J))/(X(J+1)-X(J)) YLINTP = RC*(XINT-X(J))+Y(J) C RETURN END C C C **************************************************************** C C SUBROUTINE GFREE0(ID) C ===================== C C depth-dependent quantities for the hydrogenic free-free Gaunt factor C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (THET0=5.0404D3, * THET1=UN/THET0, * A0=1.0823d0, * B0=2.98D-2, * C0=6.70D-3, * D0=1.12D-2, * A1=3.9999187d-3, * B1=-7.8622889d-5, * C1=1.070192d0, * A2=6.4628601d-2, * B2=-6.1953813d-4, * C2=2.6061249d-1, * A3=3.7542343d-2, * B3=1.3983474d-5, * C3=5.7917786d-1, * A4=3.4169006d-1, * B4=1.1852264d-2, * XMIN=0.2D0, * XMINI=UN/XMIN, * THMIN=4.0D-2) C T=TEMP(ID) THET=UN/MAX(THET0/T,THMIN) GF0(ID)=(A0+B0*THET) GF1(ID)=(A1+B1*THET)*THET+C1 GF2(ID)=(A2+B2*THET)*THET+C2 GF3(ID)=(A3+B3*THET)*THET+C3 GF4(ID)=A4+B4*THET GF5(ID)=C0+D0*THET GF6(ID)=GF0(ID)+GF5(ID)*XMINI C C auxiliary quantities for derivatives C THT=THET0/T IF(THT.GE.THMIN) THEN THET=THT GF0D(ID)=B0*THET1 GF1D(ID)=(A1+B1*THET*TWO)*THET1 GF2D(ID)=(A2+B2*THET*TWO)*THET1 GF3D(ID)=(A3+B3*THET*TWO)*THET1 GF4D(ID)=B4*THET1 GF5D(ID)=D0*THET1 GF6D(ID)=GF0D(ID)+GF5D(ID)*XMINI ELSE GF0D(ID)=0. GF1D(ID)=0. GF2D(ID)=0. GF3D(ID)=0. GF4D(ID)=0. GF5D(ID)=0. GF6D(ID)=0. END IF RETURN END C C C **************************************************************** C C FUNCTION GFREE1(ID,X) C ===================== C C Hydrogenic free-free Gaunt factor, for depth ID, C frequency FR, and charge CH C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (XMIN=0.2D0, * XMINI=UN/XMIN) C IF(X.LT.UN) THEN GFREE1=((GF4(ID)*X-GF3(ID))*X+GF2(ID))*X+GF1(ID) ELSE IF(X.LT.XMINI) THEN GFREE1=GF0(ID)+GF5(ID)*X ELSE GFREE1=GF6(ID) END IF RETURN END C C C **************************************************************** C C SUBROUTINE GFREED(ID,FR,CH,GFR,GFRD) C ==================================== C C Hydrogenic free-free Gaunt factor (GFR) and its derivative (GFRD) C for depth ID, frequency FR, and charge CH C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (C14=2.997925D14, * XMIN=0.2D0, * XMINI=UN/XMIN) C X=C14*CH/FR IF(X.LT.UN) THEN GFR=((GF4(ID)*X-GF3(ID))*X+GF2(ID))*X+GF1(ID) GFRD=((GF4D(ID)*X-GF3D(ID))*X+GF2D(ID))*X+GF1D(ID) ELSE IF(X.LT.XMINI) THEN GFR=GF0(ID)+GF5(ID)*X GFRD=GF0D(ID)+GF5D(ID)*X ELSE GFR=GF6(ID) GFRD=GF6D(ID) END IF RETURN END C C C **************************************************************** C C FUNCTION FFCROS(IEL,IFR,T,FR) C ================================== C C Non-standard evaluation of free-free cross section; C a user supplied procedure C INCLUDE 'IMPLIC.FOR' FFCROS=0. if(iel.eq.0.or.ifr.eq.0) return t1=t fr1=fr RETURN END C C C **************************************************************** C C FUNCTION SBFHMI_old(FR) C =================== C C Bound-free cross-section for H- (negative hydrogen ion) C INCLUDE 'IMPLIC.FOR' PARAMETER (UN=1.D0) SBFHMI_old=0. FR0=1.8259D14 IF(FR.LT.FR0) RETURN IF(FR.LT.2.111D14) GO TO 10 X=2.997925D15/FR SBFHMI=(6.80133D-3+X*(1.78708D-1+X*(1.6479D-1+X*(-2.04842D-2+X* * 5.95244D-4))))*1.D-17 SBFHMI_old=sbfhmi RETURN 10 X=2.997925D15*(UN/FR0-UN/FR) SBFHMI=(2.69818D-1+X*(2.2019D-1+X*(-4.11288D-2+X*2.73236D-3))) 1 *X*1.D-17 SBFHMI_old=sbfhmi RETURN END C C C ******************************************************************** C C FUNCTION SBFHMI(FR) C =================== C C Bound-free cross-section for H- (negative hydrogen ion) C Taken from Kurucz ATLAS9 C C FROM MATHISEN (1984), AFTER WISHART(1979) AND BROAD AND REINHARDT (1976) C INCLUDE 'IMPLIC.FOR' DIMENSION WBF(85),BF(85) DATA WBF/ 18.00, 19.60, 21.40, 23.60, 26.40, 29.80, 34.30, 1 40.40, 49.10, 62.60, 111.30, 112.10, 112.67, 112.95, 113.05, 2 113.10, 113.20, 113.23, 113.50, 114.40, 121.00, 139.00, 164.00, 3 175.00, 200.00, 225.00, 250.00, 275.00, 300.00, 325.00, 350.00, 4 375.00, 400.00, 425.00, 450.00, 475.00, 500.00, 525.00, 550.00, 5 575.00, 600.00, 625.00, 650.00, 675.00, 700.00, 725.00, 750.00, 6 775.00, 800.00, 825.00, 850.00, 875.00, 900.00, 925.00, 950.00, 7 975.00,1000.00,1025.00,1050.00,1075.00,1100.00,1125.00,1150.00, 8 1175.00,1200.00,1225.00,1250.00,1275.00,1300.00,1325.00,1350.00, 9 1375.00,1400.00,1425.00,1450.00,1475.00,1500.00,1525.00,1550.00, A 1575.00,1600.00,1610.00,1620.00,1630.00,1643.91/ DATA BF/ 0.067, 0.088, 0.117, 0.155, 0.206, 0.283, 0.414, 1 0.703, 1.24, 2.33, 11.60, 13.90, 24.30, 66.70, 95.00, 2 56.60, 20.00, 14.60, 8.50, 7.10, 5.43, 5.91, 7.29, 3 7.918, 9.453, 11.08, 12.75, 14.46, 16.19, 17.92, 19.65, 4 21.35, 23.02, 24.65, 26.24, 27.77, 29.23, 30.62, 31.94, 5 33.17, 34.32, 35.37, 36.32, 37.17, 37.91, 38.54, 39.07, 6 39.48, 39.77, 39.95, 40.01, 39.95, 39.77, 39.48, 39.06, 7 38.53, 37.89, 37.13, 36.25, 35.28, 34.19, 33.01, 31.72, 8 30.34, 28.87, 27.33, 25.71, 24.02, 22.26, 20.46, 18.62, 9 16.74, 14.85, 12.95, 11.07, 9.211, 7.407, 5.677, 4.052, A 2.575, 1.302, 0.8697, 0.4974, 0.1989, 0. / C Bell and Berrington J.Phys.B,vol. 20, 801-806,1987. c HMINBF=0. IF(FR.GT.1.82365E14) THEN WAVE=2.99792458E17/FR HMINBF=YLINTP(WAVE,WBF,BF,85,85)*1.E-18 END IF SBFHMI=HMINBF RETURN END C C C **************************************************************** C C FUNCTION SFFHMI(POPI,FR,T) C ========================== C C Free-free cross-section for H- (negative hydrogen ion) C Taken from Kurucz ATLAS9 C C From Bell and Berrington J.Phys.B,vol. 20, 801-806,1987. C INCLUDE 'IMPLIC.FOR' PARAMETER (CONFF=5040.*1.380658E-16, CONTH=5040.) PARAMETER (HK = 4.79928144D-11) DIMENSION FFLOG(22,11),FFCS(11,22),FFLOG2(22) DIMENSION FFBEG(11,11),FFEND(11,11),FFTT(11),WFFLOG(22) DIMENSION THETAFF(11),WAVEK(22) EQUIVALENCE (FFCS(1,1),FFBEG(1,1)),(FFCS(1,12),FFEND(1,1)) C DATA WAVEK/.50,.40,.35,.30,.25,.20,.18,.16,.14,.12,.10,.09,.08, 1 .07,.06,.05,.04,.03,.02,.01,.008,.006/ DATA THETAFF/ 1 0.5, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.8, 3.6/ DATA FFBEG/ 1.0178,.0222,.0308,.0402,.0498,.0596,.0695,.0795,.0896, .131, .172, 2.0228,.0280,.0388,.0499,.0614,.0732,.0851,.0972, .110, .160, .211, 3.0277,.0342,.0476,.0615,.0760,.0908, .105, .121, .136, .199, .262, 4.0364,.0447,.0616,.0789,.0966, .114, .132, .150, .169, .243, .318, 5.0520,.0633,.0859, .108, .131, .154, .178, .201, .225, .321, .418, 6.0791,.0959, .129, .161, .194, .227, .260, .293, .327, .463, .602, 7.0965, .117, .157, .195, .234, .272, .311, .351, .390, .549, .711, 8 .121, .146, .195, .241, .288, .334, .381, .428, .475, .667, .861, 9 .154, .188, .249, .309, .367, .424, .482, .539, .597, .830, 1.07, A .208, .250, .332, .409, .484, .557, .630, .702, .774, 1.06, 1.36, B .293, .354, .468, .576, .677, .777, .874, .969, 1.06, 1.45, 1.83/ DATA FFEND/ 1 .358, .432, .572, .702, .825, .943, 1.06, 1.17, 1.28, 1.73, 2.17, 2 .448, .539, .711, .871, 1.02, 1.16, 1.29, 1.43, 1.57, 2.09, 2.60, 3 .579, .699, .924, 1.13, 1.33, 1.51, 1.69, 1.86, 2.02, 2.67, 3.31, 4 .781, .940, 1.24, 1.52, 1.78, 2.02, 2.26, 2.48, 2.69, 3.52, 4.31, 5 1.11, 1.34, 1.77, 2.17, 2.53, 2.87, 3.20, 3.51, 3.80, 4.92, 5.97, 6 1.73, 2.08, 2.74, 3.37, 3.90, 4.50, 5.01, 5.50, 5.95, 7.59, 9.06, 7 3.04, 3.65, 4.80, 5.86, 6.86, 7.79, 8.67, 9.50, 10.3, 13.2, 15.6, 8 6.79, 8.16, 10.7, 13.1, 15.3, 17.4, 19.4, 21.2, 23.0, 29.5, 35.0, 9 27.0, 32.4, 42.6, 51.9, 60.7, 68.9, 76.8, 84.2, 91.4, 117., 140., A 42.3, 50.6, 66.4, 80.8, 94.5, 107., 120., 131., 142., 183., 219., B 75.1, 90.0, 118., 144., 168., 191., 212., 234., 253., 325., 388./ DATA ISTART/0/ C IF(ISTART.EQ.0) THEN ISTART=1 DO IWAVE=1,22 WFFLOG(IWAVE)=LOG(91.134D0/WAVEK(IWAVE)) DO ITHETA=1,11 FFLOG(IWAVE,ITHETA)=LOG(FFCS(ITHETA,IWAVE)*1.E-26) END DO END DO ENDIF C WAVE=2.99792458E17/FR WAVELOG=LOG(WAVE) C DO ITHETA=1,11 DO IWAVE=1,22 FFLOG2(IWAVE)=FFLOG(IWAVE,ITHETA) END DO FFTLOG=YLINTP(WAVELOG,WFFLOG,FFLOG2,22,22) FFTT(ITHETA)=EXP(FFTLOG)/THETAFF(ITHETA)*CONFF END DO c THETA=CONTH/T FFTH=YLINTP(THETA,THETAFF,FFTT,11,11) SFFHMI=FFTH*POPI/(1.-exp(-hk*fr/t)) RETURN END C C C **************************************************************** C C SUBROUTINE COLIS(ID,T,COL,CLOC) C =============================== C C Driving procedure for evaluation of the collisional rates C C Input: T - temperature C Output: COL - array of quantities proportional to the C collisional rates in all transitions C for a given temperature (ie. at a given depth) C Precisely, COL(IT)*Nlow(IT) is the UPWARD C collisional rate of the transition IT C Output: CLOC - array of quantities proportional to the C collisional rates in all transitions C for a given temperature (ie. at a given depth) C Precisely, CLOC(IT)*Nupp(IT) is the DOWNWARD C collisional rate of the transition IT C C Procedure COLIS calls procedures COLH and COLHE for evaluating C the collisional rates in hydrogen and helium, C and itself evaluates collisional rates for other species C C Evaluation is controlled by input parameter ICOL(ITR). C Meaning of ICOL for all species, excluding hydrogen and helium: C C a) for ionization C ICOL = 0 - Seatons formula ; here the value of the photo- C ionization cross section at the threshold is C transmitted in array OSC0 C = 1 - Allen's formula; again, OSC0 has the meaning of C the necessary multiplicative parameter C = 2 - the so-called SIMPLE1 mode - see below C = 3 - the so-called SIMPLE2 mode - see below C b) for excitation C ICOL = 0 - Van Regemorter formula, with standard g(bar)=0.25 C = 1 - Van Regemorter formula, with "exact" g(bar) C = 2 - the so-called SIMPLE1 mode - see below C = 3 - the so-called SIMPLE2 mode - see below C = 4 - Eissner-Seaton formula - see below C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193, * EXPIA3=-0.24991055,EXPIA4=0.05519968, * EXPIA5=-0.00976004,EXPIA6=0.00107857, * EXPIB1=0.2677734343,EXPIB2=8.6347608925, * EXPIB3=18.059016973,EXPIB4=8.5733287401, * EXPIC1=3.9584969228,EXPIC2=21.0996530827, * EXPIC3=25.6329561486,EXPIC4=9.5733223454) DIMENSION COL(MTRANS),TYPEARR(MXTCOL),CCRATE(MCFIT), * CCTEMP(MCFIT),CLOC(MTRANS) C COMMON/CTRTEMP/ te C CREGER(X,U,A,GG)=19.7363*X*EXP(-U)/U*GG*A CSEATN(X,U,A)=1.55D13*X/ABS(U)*EXP(-U)*A CALLEN(X,U,A)=X*A*EXP(-U)/U/U CSMPL1(X,U,A)=5.465D-11*X*EXP(-U)*A CSMPL2(X,U,A)=5.465D-11*X*EXP(-U)*A*(1.+U) CUPSX(X,U,A)=8.631D-6/X*EXP(-U)*A C DO I=1,NTRANS CLOC(I)=0. COL(I)=0. END DO C C calculate collider's populations: e, p, H(1s) C ANE : Electron C ANP : Proton C ANHM: H- C ANH : H(1s) ANE=ELEC(ID) c IF (IELH.gt.0) THEN ! if H is an explicit atom ANP=POPUL(NNEXT(IELH),ID) ! Protons ANH=POPUL(NFIRST(IELH),ID) ! H(1s) else anh=ahtot-anp ENDIF IF (IELHM.gt.0) THEN ANHM=POPUL(NFIRST(IELHM),ID) ! if H- is an explicit atom else anhm=1.0353e-16/t/sqrt(t)*exp(8762.9/t)*anh*ane ENDIF C HKT=HK/T SRT=SQRT(T) T32=UN/T/SRT TK=HKT/H CSTD=0.25 T0=TEFF if(t0.gt.0.) then TT0=UN-T/T0 SRT0=SQRT(T0)/SRT end if C C Call procedures COLH and COLHE for hydrogen and helium C IF(IATH.NE.0) CALL COLH(ID,T,COL) IF(IATHE.NE.0) CALL COLHE(T,COL) IF(IATH.NE.0.OR.IATHE.NE.0) THEN DO I=1, NTRANS COL(I)=COL(I) * ANE IF (LINE(I)) THEN CLOC(I)=COL(I) * EXP(FR0(I)*HKT)*G(ILOW(I))/G(IUP(I)) ELSE CORR=UN NKE=NNEXT(IEL(ILOW(I))) IF(NKE.NE.IUP(I)) CORR=G(NKE)/G(IUP(I))* * EXP((ENION(NKE)-ENION(IUP(I)))*TK) CLOC(I)=COL(I) * ANE * SBF(ILOW(I))*CORR ENDIF ENDDO ENDIF C C Loop over all explicit species, excluding hydrogen and helium C DO 100 IAT=1,NATOM IF(IAT.EQ.IATH.OR.IAT.EQ.IATHE) GO TO 100 N0I=N0A(IAT) NKI=NKA(IAT) DO 50 I=N0I,NKI-1 IE=IEL(I) DO 40 J=I+1,NKI IT=ITRA(I,J) IF(IT.EQ.0) GO TO 40 IC=ICOL(IT) COL(IT)=0.0 CLOC(IT)=0.0 C1=OSC0(IT) C2=CPAR(IT) U0=FR0(IT)*HKT U0HM=U0-8752.072/T ! including H-minus potential ! U0P =U0-157821.5/T ! including H-proton potential! DO K=1, MXTCOL TYPEARR(K)=0 ENDDO IF(LINE(IT)) GO TO 30 C C the detailed balancing factor for an inverse process C CORR=UN NKE=NNEXT(IEL(I)) IF(NKE.NE.J) CORR=G(NKE)/G(J)* * EXP((ENION(NKE)-ENION(J))*TK) CINV=ANE*SBF(I)*CORR C C *********** tabulated data *************** C For collisional processes that change the total C charge of the target atom, there are three C processes considered here: C - TYPE 1 Electron Collisional ionization C - TYPE 2 Charge exchange with protons C - TYPE 3 Charge exchange with hydrogen C C There are several 'calculated' options in the code for C electron collisional excitation that are C neglected if TYPE 1 tabulated data are present. C C There is also an option for TYPE 2 that is calculated C here (ICOL ge 10) that is also overriden if TYPE 2 is C present. IF (IC.GE.1000) THEN IORICE=1 IF (IC.LT.0) IORICE=-1 IC=ABS(IC) ITYPE=IC/1000 IC=IORICE*(MOD(IC,1000)-1) !ICOL RECOVERED DO K=1, MXTCOL TYPEARR(K)=MOD(ITYPE/(2**(K-1)),2) ENDDO C C ****** START 'GENCOL' FOR IONIZATION ********** C C ****** ELECTRON COLLISIONAL IONIZATION ***** IF (TYPEARR(1).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(1,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(1,K,IT)) CCTEMP(K)=CTEMP(1,k,IT) NX=NX+1 ELSE ! CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF ENDDO cs=ylintp(t,cctemp,ccrate,nx,mcfit) CS=ANE*exp(CS) COL(IT)=COL(IT) + CS !UPPWARD CLOC(IT)=CLOC(IT) + CS*CINV !DOWNWARD ENDIF C ****** CHARGE EXCHANGE WITH PROTONS ******* IF (TYPEARR(2).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(2,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(2,K,IT)) CCTEMP(K)=CTEMP(2,K,IT) NX=NX+1 ELSE ! CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF ENDDO cs=ylintp(t,cctemp,ccrate,nx,mcfit) cs=exp(cs)*ANP COL(IT)=COL(IT) + CS ! UPPWARD CINH=G(I)/G(J)*0.5*EXP(U0P) CLOC(IT)=CLOC(IT) + CS*CINH*ANH !DOWNWARD ENDIF C ******* CHARGE EXCHANGE WITH HYDROGEN ***** IF (TYPEARR(3).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(3,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(3,K,IT)) CCTEMP(K)=CTEMP(3,K,IT) NX=NX+1 ELSE ! CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF ENDDO cs=ylintp(t,cctemp,ccrate,nx,mcfit) cs=exp(cs)*ANH COL(IT)=COL(IT) + CS ! UPPWARD CINH=G(I)/G(J)*TWO*EXP(U0HM) CLOC(IT)=CLOC(IT) + CS*CINH*ANHM !DOWNWARD ENDIF C ************** END GENCOL ****************** IF (IC.EQ.-1) GO TO 40 ENDIF C C ********* Charge transfer with protons reactions- an old scheme C IF(IC.GE.10) THEN IF(TYPEARR(2).NE.1) THEN C radiative charge transfer ionization of neutrals in the C grround state with protons te=T CS=HCTIon(1,NUMAT(IAT)) CS=CS*ANP COL(IT)=COL(IT) + CS !UPPWARD CS=CS*0.5*G(I)/G(J) * EXP(U0P) CLOC(IT)=CLOC(IT) + CS*ANH !DOWNWARD ENDIF IC=IC-10 IF(TYPEARR(1).eq.1) GO TO 40 ENDIF C C ********* Electron collisional ionization C IF(IC.EQ.0) THEN CS=CSEATN(UN/SRT,U0,C1)*ANE COL(IT)=COL(IT)+CS ELSE IF(IC.EQ.1) THEN CS=CALLEN(T32,U0,C1)*ANE COL(IT)=COL(IT)+CS ELSE IF(IC.EQ.2) THEN CS=CSMPL1(SRT,U0,C1)*ANE COL(IT)=COL(IT)+CS ELSE IF(IC.EQ.3) THEN CS=CSMPL2(SRT,U0,C1)*ANE COL(IT)=COL(IT)+CS ELSE IF(IC.EQ.4) THEN ia=numat(iatm(i)) CS=cion(ia,iz(iel(i)),enion(i)*6.24298e11,t)*ANE COL(IT)=COL(IT)+CS ELSE IF(IC.EQ.5) THEN ia=numat(iatm(i)) izc=iz(ie) rno=16. ii=i-nfirst(ie)+1 call irc(ii,t,izc,rno,cs) CS=CS*ANE col(it)=COL(IT)+CS ELSE IF(IC.LT.0) THEN CALL CSPEC(I,J,IC,C1,C2,U0,T,CS) CS=CS*ANE COL(IT)=COL(IT)+CS END IF CLOC(IT)=CLOC(IT)+CS*CINV !DOWNWARD if(ic.eq.4) go to 40 C C collisional excitations from level I to higher, non-explicit C levels are lumped into the collisional ionization rate C (the so-called modified collision ionization rate) C N0Q=NQUANT(NLAST(IE))+1 N1Q=ICUP(IE) IF(N1Q.EQ.0) GO TO 40 IQ=NQUANT(I) REL=G(I)/2./IQ/IQ DO 20 JQ=N0Q,N1Q XJ=JQ U0=(ENION(I)-EH/XJ/XJ)*TK IF(JQ.LE.20) CC1=OSH(IQ,JQ)*REL IF(JQ.GT.20) CC1=OSH(IQ,20)*(20./XJ)**3*REL GG=CSTD if(u0.gt.35.) go to 20 IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+ * U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+ * U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF GG0=0.276*EXP(U0)*EXPIU0 IF(GG0.GT.GG) GG=GG0 CS=CREGER(T32,U0,CC1,GG)*ANE COL(IT)=COL(IT)+CS !UPPWARD CLOC(IT)=CLOC(IT)+CS*ANE*SBF(I)*WOP(I,ID)*CORR !DOWNWARD 20 CONTINUE GO TO 40 C C ********* Collisional excitation C 30 CONTINUE C C the detailed balancing factor for an inverse process C CINV=EXP(U0)*G(I)/G(J) C c ********** Tabulated Data IF (IC.GE.1000) THEN IORICE=1 IF (IC.LT.0) IORICE=-1 IC=ABS(IC) ITYPE=IC/1000 IC=IORICE*(MOD(IC,1000)-1) !ICOL RECOVERED DO K=1, MXTCOL TYPEARR(K)=MOD(ITYPE/(2**(K-1)),2) END DO C ****** START 'GENCOL' FOR EXCITATION ********** C C ****** ELECTRON COLLISIONAL EXCITATION ***** IF (TYPEARR(1).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(1,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(1,K,IT)) CCTEMP(K)=CTEMP(1,K,IT) NX=NX+1 ELSE !CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF END DO cs=ylintp(t,cctemp,ccrate,nx,mcfit) CS=exp(CS)*ANE COL(IT)=COL(IT) + CS ! UPPWARD CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD END IF C ****** PROTON COLLISIONAL EXCITATION ******* IF (TYPEARR(2).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(2,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(2,K,IT)) CCTEMP(K)=CTEMP(2,K,IT) NX=NX+1 ELSE !CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF END DO cs=ylintp(t,cctemp,ccrate,nx,mcfit) CS=exp(CS)*ANP COL(IT)=COL(IT) + CS ! UPPWARD CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD END IF C ******* HYDROGEN COLLISIONAL EXCITATION ***** IF (TYPEARR(3).EQ.1) THEN NX=0 DO K=1,MCFIT IF (CTEMP(3,K,IT).NE.0) THEN CCRATE(K)=log(CRATE(3,K,IT)) CCTEMP(K)=CTEMP(3,K,IT) NX=NX+1 ELSE !CLEAN CC**** ARRAYS CCRATE(K)=0. CCTEMP(K)=0. ENDIF END DO cs=ylintp(t,cctemp,ccrate,nx,mcfit) CS=exp(CS)*ANH COL(IT)=COL(IT) + CS ! UPPWARD CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD END IF C ************** END GENCOL ****************** IF (IC.EQ.-1) GO TO 40 END IF IF(IC.LE.1.AND.IC.GT.0) THEN GG=CSTD IF(IC.EQ.1) GG=C2 IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+ * U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0* * (EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF GG0=0.276*EXP(U0)*EXPIU0 IF(GG0.GT.GG) GG=GG0 CS=CREGER(T32,U0,C1,GG)*ANE COL(IT)=COL(IT) + CS ! UPPWARD ELSE IF(IC.EQ.2) THEN CS=CSMPL1(SRT,U0,C1*C2)*ANE COL(IT)=COL(IT) + CS ! UPPWARD ELSE IF(IC.EQ.3) THEN CS=CSMPL2(SRT,U0,C2)*ANE COL(IT)=COL(IT) + CS ! UPPWARD ELSE IF(IC.EQ.4) THEN CS=CUPSX(SRT,U0,C2/G(I))*ANE COL(IT)=COL(IT) + CS ! UPPWARD ELSE IF(IC.EQ.9) THEN CS=OMECOL(I,J)*SRT0*EXP(-U0*TT0) * ANE COL(IT)=COL(IT) + CS ! UPPWARD ELSE IF(IC.LT.0) THEN CALL CSPEC(I,J,IC,C1,C2,U0,T,CS) CS=CS*ANE COL(IT)=COL(IT) + CS ! UPPWARD END IF CLOC(IT)=CLOC(IT) + CS*CINV ! DOWNWARD 40 CONTINUE 50 CONTINUE 100 CONTINUE RETURN END C C **************************************************************** C function HCTRecom(ion,nelem) c ============================ c c Code by Jim Kingdon, in collaboration with G.J. Ferland c ion is stage of ionization, 2 for the ion going to the atom c nelem is atomic number of element, 2 up to 30 c Example: O+ + H => O + H+ is HCTRecom(2,8) c integer ion , nelem INCLUDE 'IMPLIC.FOR' common/CTRTEMP/ te common/CTRecomb/ CTRecomb(6,4,30) c c local variables * real tused c integer ipIon c ipIon = ion - 1 c if( ipIon.gt.4 ) then c use statistical charge transfer for ion > 4 HCTRecom = 1.92e-9 * ipIon return endif c c Make sure te is between temp. boundaries; set constant outside of range tused = max( te,CTRecomb(5,ipIon,nelem) ) tused = min( tused , CTRecomb(6,ipIon,nelem) ) tused = tused * 1e-4 c c the interpolation equation HCTRecom = CTRecomb(1,ipIon,nelem)* 1e-9 * 1 (tused**CTRecomb(2,ipIon,nelem)) * 2 (1. + 3 CTRecomb(3,ipIon,nelem) * exp(CTRecomb(4,ipIon,nelem)*tused) ) c end ****************************************************************************** function HCTIon(ion,nelem) c ion is stage of ionization, 1 for atom c nelem is atomic number of element, 2 up to 30 c Example: O + H+ => O+ + H is HCTIon(1,8) c integer ion , nelem INCLUDE 'IMPLIC.FOR' common/CTRTEMP/ te common/CTIon/ CTIon(7,4,30) c c local variables c real tused c integer ipIon c ipIon = ion c c Make sure te is between temp. boundaries; set constant outside of range tused = max( te,CTIon(5,ipIon,nelem) ) tused = min( tused , CTIon(6,ipIon,nelem) ) tused = tused * 1e-4 c c the interpolation equation HCTIon = CTIon(1,ipIon,nelem)* 1e-9 * 1 (tused**CTIon(2,ipIon,nelem)) * 2 (1. + 3 CTIon(3,ipIon,nelem) * exp(CTIon(4,ipIon,nelem)*tused) ) * 4 exp(-CTIon(7,ipIon,nelem)/tused) c end ******************************************************************************** block data ctdata c c real CTIon c second dimension is ionization stage, c 1=+0 for parent, etc c third dimension is atomic number of atom INCLUDE 'IMPLIC.FOR' common/CTIon/ CTIon(7,4,30) c real CTRecomb c second dimension is ionization stage, c 1=+1 for parent, etc c third dimension is atomic number of atom common/CTRecomb/ CTRecomb(6,4,30) c c local variables c integer i c c digital form of the fits to the charge transfer c ionization rate coefficients c c Note: First parameter is in units of 1e-9! c Note: Seventh parameter is in units of 1e4 K c ionization data (CTIon(i,1,3),i=1,7)/2.84e-3,1.99,375.54,-54.07,1e2,1e4,0.0/ data (CTIon(i,2,3),i=1,7)/7*0./ data (CTIon(i,3,3),i=1,7)/7*0./ data (CTIon(i,1,4),i=1,7)/7*0./ data (CTIon(i,2,4),i=1,7)/7*0./ data (CTIon(i,3,4),i=1,7)/7*0./ data (CTIon(i,1,5),i=1,7)/7*0./ data (CTIon(i,2,5),i=1,7)/7*0./ data (CTIon(i,3,5),i=1,7)/7*0./ data (CTIon(i,1,6),i=1,7)/1.07e-6,3.15,176.43,-4.29,1e3,1e5,0.0/ data (CTIon(i,2,6),i=1,7)/7*0./ data (CTIon(i,3,6),i=1,7)/7*0./ data (CTIon(i,1,7),i=1,7)/4.55e-3,-0.29,-0.92,-8.38,1e2,5e4,1.086/ data (CTIon(i,2,7),i=1,7)/7*0./ data (CTIon(i,3,7),i=1,7)/7*0./ data (CTIon(i,1,8),i=1,7)/7.40e-2,0.47,24.37,-0.74,1e1,1e4,0.023/ data (CTIon(i,2,8),i=1,7)/7*0./ data (CTIon(i,3,8),i=1,7)/7*0./ data (CTIon(i,1,9),i=1,7)/7*0./ data (CTIon(i,2,9),i=1,7)/7*0./ data (CTIon(i,3,9),i=1,7)/7*0./ data (CTIon(i,1,10),i=1,7)/7*0./ data (CTIon(i,2,10),i=1,7)/7*0./ data (CTIon(i,3,10),i=1,7)/7*0./ data (CTIon(i,1,11),i=1,7)/3.34e-6,9.31,2632.31,-3.04,1e3,2e4,0.0/ data (CTIon(i,2,11),i=1,7)/7*0./ data (CTIon(i,3,11),i=1,7)/7*0./ data (CTIon(i,1,12),i=1,7)/9.76e-3,3.14,55.54,-1.12,5e3,3e4,0.0/ data (CTIon(i,2,12),i=1,7)/7.60e-5,0.00,-1.97,-4.32,1e4,3e5,1.670/ data (CTIon(i,3,12),i=1,7)/7*0./ data (CTIon(i,1,13),i=1,7)/7*0./ data (CTIon(i,2,13),i=1,7)/7*0./ data (CTIon(i,3,13),i=1,7)/7*0./ data (CTIon(i,1,14),i=1,7)/0.92,1.15,0.80,-0.24,1e3,2e5,0.0/ data (CTIon(i,2,14),i=1,7)/2.26,7.36e-2,-0.43,-0.11,2e3,1e5, 1 3.031/ data (CTIon(i,3,14),i=1,7)/7*0./ data (CTIon(i,1,15),i=1,7)/7*0./ data (CTIon(i,2,15),i=1,7)/7*0./ data (CTIon(i,3,15),i=1,7)/7*0./ data (CTIon(i,1,16),i=1,7)/1.00e-5,0.00,0.00,0.00,1e3,1e4,0.0/ data (CTIon(i,2,16),i=1,7)/7*0./ data (CTIon(i,3,16),i=1,7)/7*0./ data (CTIon(i,1,17),i=1,7)/7*0./ data (CTIon(i,2,17),i=1,7)/7*0./ data (CTIon(i,3,17),i=1,7)/7*0./ data (CTIon(i,1,18),i=1,7)/7*0./ data (CTIon(i,2,18),i=1,7)/7*0./ data (CTIon(i,3,18),i=1,7)/7*0./ data (CTIon(i,1,19),i=1,7)/7*0./ data (CTIon(i,2,19),i=1,7)/7*0./ data (CTIon(i,3,19),i=1,7)/7*0./ data (CTIon(i,1,20),i=1,7)/7*0./ data (CTIon(i,2,20),i=1,7)/7*0./ data (CTIon(i,3,20),i=1,7)/7*0./ data (CTIon(i,1,21),i=1,7)/7*0./ data (CTIon(i,2,21),i=1,7)/7*0./ data (CTIon(i,3,21),i=1,7)/7*0./ data (CTIon(i,1,22),i=1,7)/7*0./ data (CTIon(i,2,22),i=1,7)/7*0./ data (CTIon(i,3,22),i=1,7)/7*0./ data (CTIon(i,1,23),i=1,7)/7*0./ data (CTIon(i,2,23),i=1,7)/7*0./ data (CTIon(i,3,23),i=1,7)/7*0./ data (CTIon(i,1,24),i=1,7)/7*0./ data (CTIon(i,2,24),i=1,7)/4.39,0.61,-0.89,-3.56,1e3,3e4,3.349/ data (CTIon(i,3,24),i=1,7)/7*0./ data (CTIon(i,1,25),i=1,7)/7*0./ data (CTIon(i,2,25),i=1,7)/2.83e-1,6.80e-3,6.44e-2,-9.70,1e3,3e4, 1 2.368/ data (CTIon(i,3,25),i=1,7)/7*0./ data (CTIon(i,1,26),i=1,7)/7*0./ data (CTIon(i,2,26),i=1,7)/2.10,7.72e-2,-0.41,-7.31,1e4,1e5,3.005/ data (CTIon(i,3,26),i=1,7)/7*0./ data (CTIon(i,1,27),i=1,7)/7*0./ data (CTIon(i,2,27),i=1,7)/1.20e-2,3.49,24.41,-1.26,1e3,3e4,4.044/ data (CTIon(i,3,27),i=1,7)/7*0./ data (CTIon(i,1,28),i=1,7)/7*0./ data (CTIon(i,2,28),i=1,7)/7*0./ data (CTIon(i,3,28),i=1,7)/7*0./ data (CTIon(i,1,29),i=1,7)/7*0./ data (CTIon(i,2,29),i=1,7)/7*0./ data (CTIon(i,3,29),i=1,7)/7*0./ data (CTIon(i,1,30),i=1,7)/7*0./ data (CTIon(i,2,30),i=1,7)/7*0./ data (CTIon(i,3,30),i=1,7)/7*0./ c c digital form of the fits to the charge transfer c recombination rate coefficients (total) c c Note: First parameter is in units of 1e-9! c recombination data (CTRecomb(i,1,2),i=1,6)/7.47e-6,2.06,9.93,-3.89,6e3,1e5/ data (CTRecomb(i,2,2),i=1,6)/1.00e-5,0.,0.,0.,1e3,1e7/ data (CTRecomb(i,1,3),i=1,6)/6*0./ data (CTRecomb(i,2,3),i=1,6)/1.26,0.96,3.02,-0.65,1e3,3e4/ data (CTRecomb(i,3,3),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,1,4),i=1,6)/6*0./ data (CTRecomb(i,2,4),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,3,4),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,4,4),i=1,6)/5.17,0.82,-0.69,-1.12,2e3,5e4/ data (CTRecomb(i,1,5),i=1,6)/6*0./ data (CTRecomb(i,2,5),i=1,6)/2.00e-2,0.,0.,0.,1e3,1e9/ data (CTRecomb(i,3,5),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,4,5),i=1,6)/2.74,0.93,-0.61,-1.13,2e3,5e4/ data (CTRecomb(i,1,6),i=1,6)/4.88e-7,3.25,-1.12,-0.21,5.5e3,1e5/ data (CTRecomb(i,2,6),i=1,6)/1.67e-4,2.79,304.72,-4.07,5e3,5e4/ data (CTRecomb(i,3,6),i=1,6)/3.25,0.21,0.19,-3.29,1e3,1e5/ data (CTRecomb(i,4,6),i=1,6)/332.46,-0.11,-9.95e-1,-1.58e-3,1e1, 1 1e5/ data (CTRecomb(i,1,7),i=1,6)/1.01e-3,-0.29,-0.92,-8.38,1e2,5e4/ data (CTRecomb(i,2,7),i=1,6)/3.05e-1,0.60,2.65,-0.93,1e3,1e5/ data (CTRecomb(i,3,7),i=1,6)/4.54,0.57,-0.65,-0.89,1e1,1e5/ data (CTRecomb(i,4,7),i=1,6)/2.95,0.55,-0.39,-1.07,1e3,1e6/ data (CTRecomb(i,1,8),i=1,6)/1.04,3.15e-2,-0.61,-9.73,1e1,1e4/ data (CTRecomb(i,2,8),i=1,6)/1.04,0.27,2.02,-5.92,1e2,1e5/ data (CTRecomb(i,3,8),i=1,6)/3.98,0.26,0.56,-2.62,1e3,5e4/ data (CTRecomb(i,4,8),i=1,6)/2.52e-1,0.63,2.08,-4.16,1e3,3e4/ data (CTRecomb(i,1,9),i=1,6)/6*0./ data (CTRecomb(i,2,9),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,3,9),i=1,6)/9.86,0.29,-0.21,-1.15,2e3,5e4/ data (CTRecomb(i,4,9),i=1,6)/7.15e-1,1.21,-0.70,-0.85,2e3,5e4/ data (CTRecomb(i,1,10),i=1,6)/6*0./ data (CTRecomb(i,2,10),i=1,6)/1.00e-5,0.,0.,0.,5e3,5e4/ data (CTRecomb(i,3,10),i=1,6)/14.73,4.52e-2,-0.84,-0.31,5e3,5e4/ data (CTRecomb(i,4,10),i=1,6)/6.47,0.54,3.59,-5.22,1e3,3e4/ data (CTRecomb(i,1,11),i=1,6)/6*0./ data (CTRecomb(i,2,11),i=1,6)/1.00e-5,0.,0.,0.,2e3,5e4/ data (CTRecomb(i,3,11),i=1,6)/1.33,1.15,1.20,-0.32,2e3,5e4/ data (CTRecomb(i,4,11),i=1,6)/1.01e-1,1.34,10.05,-6.41,2e3,5e4/ data (CTRecomb(i,1,12),i=1,6)/6*0./ data (CTRecomb(i,2,12),i=1,6)/8.58e-5,2.49e-3,2.93e-2,-4.33,1e3, 1 3e4/ data (CTRecomb(i,3,12),i=1,6)/6.49,0.53,2.82,-7.63,1e3,3e4/ data (CTRecomb(i,4,12),i=1,6)/6.36,0.55,3.86,-5.19,1e3,3e4/ data (CTRecomb(i,1,13),i=1,6)/6*0./ data (CTRecomb(i,2,13),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,13),i=1,6)/7.11e-5,4.12,1.72e4,-22.24,1e3,3e4/ data (CTRecomb(i,4,13),i=1,6)/7.52e-1,0.77,6.24,-5.67,1e3,3e4/ data (CTRecomb(i,1,14),i=1,6)/6*0./ data (CTRecomb(i,2,14),i=1,6)/6.77,7.36e-2,-0.43,-0.11,5e2,1e5/ data (CTRecomb(i,3,14),i=1,6)/4.90e-1,-8.74e-2,-0.36,-0.79,1e3, 1 3e4/ data (CTRecomb(i,4,14),i=1,6)/7.58,0.37,1.06,-4.09,1e3,5e4/ data (CTRecomb(i,1,15),i=1,6)/6*0./ data (CTRecomb(i,2,15),i=1,6)/1.74e-4,3.84,36.06,-0.97,1e3,3e4/ data (CTRecomb(i,3,15),i=1,6)/9.46e-2,-5.58e-2,0.77,-6.43,1e3,3e4/ data (CTRecomb(i,4,15),i=1,6)/5.37,0.47,2.21,-8.52,1e3,3e4/ data (CTRecomb(i,1,16),i=1,6)/3.82e-7,11.10,2.57e4,-8.22,1e3,1e4/ data (CTRecomb(i,2,16),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,16),i=1,6)/2.29,4.02e-2,1.59,-6.06,1e3,3e4/ data (CTRecomb(i,4,16),i=1,6)/6.44,0.13,2.69,-5.69,1e3,3e4/ data (CTRecomb(i,1,17),i=1,6)/6*0./ data (CTRecomb(i,2,17),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,17),i=1,6)/1.88,0.32,1.77,-5.70,1e3,3e4/ data (CTRecomb(i,4,17),i=1,6)/7.27,0.29,1.04,-10.14,1e3,3e4/ data (CTRecomb(i,1,18),i=1,6)/6*0./ data (CTRecomb(i,2,18),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,18),i=1,6)/4.57,0.27,-0.18,-1.57,1e3,3e4/ data (CTRecomb(i,4,18),i=1,6)/6.37,0.85,10.21,-6.22,1e3,3e4/ data (CTRecomb(i,1,19),i=1,6)/6*0./ data (CTRecomb(i,2,19),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,19),i=1,6)/4.76,0.44,-0.56,-0.88,1e3,3e4/ data (CTRecomb(i,4,19),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,1,20),i=1,6)/6*0./ data (CTRecomb(i,2,20),i=1,6)/0.,0.,0.,0.,1e1,1e9/ data (CTRecomb(i,3,20),i=1,6)/3.17e-2,2.12,12.06,-0.40,1e3,3e4/ data (CTRecomb(i,4,20),i=1,6)/2.68,0.69,-0.68,-4.47,1e3,3e4/ data (CTRecomb(i,1,21),i=1,6)/6*0./ data (CTRecomb(i,2,21),i=1,6)/0.,0.,0.,0.,1e1,1e9/ data (CTRecomb(i,3,21),i=1,6)/7.22e-3,2.34,411.50,-13.24,1e3,3e4/ data (CTRecomb(i,4,21),i=1,6)/1.20e-1,1.48,4.00,-9.33,1e3,3e4/ data (CTRecomb(i,1,22),i=1,6)/6*0./ data (CTRecomb(i,2,22),i=1,6)/0.,0.,0.,0.,1e1,1e9/ data (CTRecomb(i,3,22),i=1,6)/6.34e-1,6.87e-3,0.18,-8.04,1e3,3e4/ data (CTRecomb(i,4,22),i=1,6)/4.37e-3,1.25,40.02,-8.05,1e3,3e4/ data (CTRecomb(i,1,23),i=1,6)/6*0./ data (CTRecomb(i,2,23),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,23),i=1,6)/5.12,-2.18e-2,-0.24,-0.83,1e3,3e4/ data (CTRecomb(i,4,23),i=1,6)/1.96e-1,-8.53e-3,0.28,-6.46,1e3,3e4/ data (CTRecomb(i,1,24),i=1,6)/6*0./ data (CTRecomb(i,2,24),i=1,6)/5.27e-1,0.61,-0.89,-3.56,1e3,3e4/ data (CTRecomb(i,3,24),i=1,6)/10.90,0.24,0.26,-11.94,1e3,3e4/ data (CTRecomb(i,4,24),i=1,6)/1.18,0.20,0.77,-7.09,1e3,3e4/ data (CTRecomb(i,1,25),i=1,6)/6*0./ data (CTRecomb(i,2,25),i=1,6)/1.65e-1,6.80e-3,6.44e-2,-9.70,1e3, 1 3e4/ data (CTRecomb(i,3,25),i=1,6)/14.20,0.34,-0.41,-1.19,1e3,3e4/ data (CTRecomb(i,4,25),i=1,6)/4.43e-1,0.91,10.76,-7.49,1e3,3e4/ data (CTRecomb(i,1,26),i=1,6)/6*0./ data (CTRecomb(i,2,26),i=1,6)/1.26,7.72e-2,-0.41,-7.31,1e3,1e5/ data (CTRecomb(i,3,26),i=1,6)/3.42,0.51,-2.06,-8.99,1e3,1e5/ data (CTRecomb(i,4,26),i=1,6)/14.60,3.57e-2,-0.92,-0.37,1e3,3e4/ data (CTRecomb(i,1,27),i=1,6)/6*0./ data (CTRecomb(i,2,27),i=1,6)/5.30,0.24,-0.91,-0.47,1e3,3e4/ data (CTRecomb(i,3,27),i=1,6)/3.26,0.87,2.85,-9.23,1e3,3e4/ data (CTRecomb(i,4,27),i=1,6)/1.03,0.58,-0.89,-0.66,1e3,3e4/ data (CTRecomb(i,1,28),i=1,6)/6*0./ data (CTRecomb(i,2,28),i=1,6)/1.05,1.28,6.54,-1.81,1e3,1e5/ data (CTRecomb(i,3,28),i=1,6)/9.73,0.35,0.90,-5.33,1e3,3e4/ data (CTRecomb(i,4,28),i=1,6)/6.14,0.25,-0.91,-0.42,1e3,3e4/ data (CTRecomb(i,1,29),i=1,6)/6*0./ data (CTRecomb(i,2,29),i=1,6)/1.47e-3,3.51,23.91,-0.93,1e3,3e4/ data (CTRecomb(i,3,29),i=1,6)/9.26,0.37,0.40,-10.73,1e3,3e4/ data (CTRecomb(i,4,29),i=1,6)/11.59,0.20,0.80,-6.62,1e3,3e4/ data (CTRecomb(i,1,30),i=1,6)/6*0./ data (CTRecomb(i,2,30),i=1,6)/1.00e-5,0.,0.,0.,1e3,3e4/ data (CTRecomb(i,3,30),i=1,6)/6.96e-4,4.24,26.06,-1.24,1e3,3e4/ data (CTRecomb(i,4,30),i=1,6)/1.33e-2,1.56,-0.92,-1.20,1e3,3e4/ c end C C C **************************************************************** C C SUBROUTINE COLH(ID,T,COL) C ========================= C C Hydrogen collision rates C C All standard expressions are taken from Mihalas, Heasley, and C Auer, NCAR-TN/STR-104 (1975) C C New expressions (also from Mihalas) for collisional ionization C for first 10 levels taken from Klaus Werner. C C New standard expressions from Giovanardi et al. (1987, AAS, 70, 29) C for collisional excitation (valid from 3000K to 500000K) C C Meaning of ICOL: C a) for ionization - .ge.0 - standard expression C < 0 - non-standard, user suplied formula C b) for 1 - 2 transition =0 - standard theoretical formula C = 1 - experimental fit (formula quted in C Mihalas et al.) C = 2 - formula by Crandall et al (procedure C CEH12) C c) for all other line transitions C .ge.0 - standard expression C < 0 - non-standard, user supplie formula C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (CC0 = 5.465D-11, * CEX1 = -30.20581, * CEX2 = 3.8608704, * CEX3 = 305.63574, * CI1 = 0.3, * CI2 = 0.435, * CA1 = 5.444416D7, * CA2 = -2.8185937D4, * CA3 = 19.987261, * CA4 = -5.8906298D-5, * CB1 = 1.3935312D3, * CB2 = -1.6805859D2, * CB3 = -2.539D3, * CC1 = 2.0684609D3, * CC2 = -3.341582D2, * CC3 = -7.6440625D3, * CD1 = 3.2174844D3, * CD2 = -5.5882422D2, * CD3 = -6.86325D3, * CE1 = 5.759125D3, * CE2 = 81.75, * CE3 = -1.5163D3, * CF1 = 1.461475D4, * CF2 = 393.4, * CF3 = -4.8284D3, * ALF0 = 1.8, * ALF1 = 0.4, * BET0 = 3.0, * BET1 = 1.2, * O148 = 0.148, * CHMI = 5.59D-15) PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193, * EXPIA3=-0.24991055,EXPIA4=0.05519968, * EXPIA5=-0.00976004,EXPIA6=0.00107857, * EXPIB1=0.2677734343,EXPIB2=8.6347608925, * EXPIB3=18.059016973,EXPIB4=8.5733287401, * EXPIC1=3.9584969228,EXPIC2=21.0996530827, * EXPIC3=25.6329561486,EXPIC4=9.5733223454) DIMENSION COL(MTRANS),A(6,10) DIMENSION CCOOL(4,14,15),CHOT(4,14,15),XTT(4) DATA ((A(I,J),J=1,10),I=1,6) / * -86.7633398, 2632.8369 , 7478.9556 ,-4202.8442 ,-47995.930 , * -120942.89 ,-202300.81 ,-261373.03 ,-266337.91 ,-192293.20 , * 100.919188 ,-2738.7485 ,-8495.4590 , 1937.3763 , 45825.371 , * 122209.39 , 211928.67 , 285044.75 , 309455.47 , 258802.22 , * -45.7813807, 1121.3976 , 3794.6826 , 340.35764 ,-16617.055 , * -47390.313 ,-84973.688 ,-117833.95 ,-133243.61 ,-120363.95 , * 10.1978559 ,-224.30670 ,-822.83636 ,-290.10489 , 2905.7393 , * 8944.6025 , 16556.992 , 23544.543 , 27419.742 , 26002.143 , * -1.11223557, 21.923729 , 86.619110 , 48.840523 ,-246.99014 , * -828.41028 ,-1581.2722 ,-2297.9321 ,-2738.1743 ,-2686.4087 , * .0474198818,-.83974838,-3.5534720 ,-2.6097214 , 8.1972208 , * 30.267115 , 59.521984 , 88.178680 , 107.05288 , 107.73775 / C DATA ((CCOOL(I, 1, K),I=1,4),K=1,15)/ 4*0., & 5.742D-01, 1.818D-05,-1.093D-10, 8.687D-16, & 1.934D-01,-4.698D-07, 8.352D-11,-5.576D-16, & 6.323D-03, 2.237D-06,-1.620D-11, 8.955D-17, & 2.035D-02, 6.076D-07,-2.175D-13,-2.495D-18, & 1.136D-02, 3.428D-07,-1.467D-13,-1.300D-18, & 6.999D-03, 2.126D-07,-9.963D-14,-7.672D-19, & 4.624D-03, 1.410D-07,-6.969D-14,-4.927D-19, & 3.217D-03, 9.836D-08,-5.031D-14,-3.361D-19, & 2.329D-03, 7.135D-08,-3.737D-14,-2.400D-19, & 1.741D-03, 5.342D-08,-2.845D-14,-1.775D-19, & 1.336D-03, 4.103D-08,-2.213D-14,-1.351D-19, & 1.048D-03, 3.220D-08,-1.754D-14,-1.053D-19, & 8.369D-04, 2.574D-08,-1.413D-14,-8.368D-20, & 6.791D-04, 2.090D-08,-1.154D-14,-6.763D-20/ DATA ((CCOOL(I, 2, K),I=1,4),K=1,15)/ 8*0., & 2.253D+01, 9.350D-04, 1.215D-08,-9.969D-14, & 7.816D-01, 5.414D-04,-1.827D-09, 5.140D-17, & 1.459D+00, 2.858D-04,-2.207D-09, 9.028D-15, & 7.172D-01, 1.440D-04,-1.139D-09, 4.755D-15, & 4.107D-01, 8.360D-05,-6.699D-10, 2.823D-15, & 2.591D-01, 5.319D-05,-4.293D-10, 1.819D-15, & 1.747D-01, 3.608D-05,-2.925D-10, 1.243D-15, & 1.237D-01, 2.567D-05,-2.087D-10, 8.891D-16, & 9.097D-02, 1.893D-05,-1.539D-10, 6.585D-16, & 6.896D-02, 1.438D-05,-1.174D-10, 5.017D-16, & 5.356D-02, 1.119D-05,-9.150D-11, 3.913D-16, & 4.247D-02, 8.887D-06,-7.272D-11, 3.112D-16, & 3.425D-02, 7.176D-06,-5.877D-11, 2.516D-16/ DATA ((CCOOL(I, 3, K),I=1,4),K=1,15)/ 12*0., & -1.290D+01, 2.059D-02, 5.461D-08,-9.082D-13, & 3.562D+02, 7.337D-03,-9.622D-08, 5.596D-13, & 5.744D+00, 3.570D-03,-3.259D-08, 1.452D-13, & 2.968D+00, 1.813D-03,-1.703D-08, 7.744D-14, & 1.756D+00, 1.065D-03,-1.016D-08, 4.667D-14, & 1.135D+00, 6.865D-04,-6.601D-09, 3.053D-14, & 7.802D-01, 4.713D-04,-4.558D-09, 2.116D-14, & 5.615D-01, 3.390D-04,-3.292D-09, 1.532D-14, & 4.189D-01, 2.528D-04,-2.461D-09, 1.148D-14, & 3.213D-01, 1.939D-04,-1.891D-09, 8.833D-15, & 2.523D-01, 1.522D-04,-1.487D-09, 6.953D-15, & 2.018D-01, 1.218D-04,-1.192D-09, 5.576D-15/ DATA ((CCOOL(I, 4, K),I=1,4),K=1,15)/ 16*0., & 4.139D+03, 4.645D-01,-7.097D-06, 4.388D-11, & 1.794D+03, 4.443D-02,-6.484D-07, 3.936D-12, & 1.536D+01, 2.042D-02,-2.065D-07, 9.734D-13, & 8.730D+00, 1.033D-02,-1.074D-07, 5.161D-13, & 5.434D+00, 6.084D-03,-6.423D-08, 3.116D-13, & 3.628D+00, 3.938D-03,-4.196D-08, 2.048D-13, & 2.554D+00, 2.718D-03,-2.914D-08, 1.428D-13, & 1.873D+00, 1.967D-03,-2.119D-08, 1.041D-13, & 1.418D+00, 1.476D-03,-1.594D-08, 7.843D-14, & 1.102D+00, 1.138D-03,-1.232D-08, 6.075D-14, & 8.744D-01, 8.987D-04,-9.746D-09, 4.809D-14/ DATA ((CCOOL(I, 5, K),I=1,4),K=1,15)/ 20*0., & -9.122D+02, 1.260D+00,-1.070D-05, 4.290D-11, & 3.959D+01, 2.108D-01,-2.162D-06, 1.020D-11, & 3.691D+01, 7.806D-02,-8.485D-07, 4.166D-12, & 2.352D+01, 3.911D-02,-4.365D-07, 2.179D-12, & 1.542D+01, 2.296D-02,-2.601D-07, 1.310D-12, & 1.062D+01, 1.487D-02,-1.699D-07, 8.608D-13, & 7.642D+00, 1.029D-02,-1.183D-07, 6.014D-13, & 5.695D+00, 7.464D-03,-8.621D-08, 4.394D-13, & 4.368D+00, 5.617D-03,-6.508D-08, 3.323D-13, & 3.430D+00, 4.348D-03,-5.051D-08, 2.583D-13/ DATA ((CCOOL(I, 6, K),I=1,4),K=1,15)/ 24*0., & -3.431D+03, 4.116D+00,-3.853D-05, 1.679D-10, & 4.397D+01, 6.434D-01,-7.008D-06, 3.431D-11, & 8.927D+01, 2.325D-01,-2.667D-06, 1.350D-11, & 6.153D+01, 1.152D-01,-1.354D-06, 6.957D-12, & 4.165D+01, 6.729D-02,-8.024D-07, 4.156D-12, & 2.923D+01, 4.349D-02,-5.232D-07, 2.724D-12, & 2.130D+01, 3.008D-02,-3.641D-07, 1.902D-12, & 1.603D+01, 2.185D-02,-2.656D-07, 1.391D-12, & 1.239D+01, 1.647D-02,-2.008D-07, 1.054D-12/ DATA ((CCOOL(I, 7, K),I=1,4),K=1,15)/ 28*0., & -9.280D+03, 1.116D+01,-1.122D-04, 5.167D-10, & 6.658D+01, 1.651D+00,-1.884D-05, 9.487D-11, & 2.172D+02, 5.833D-01,-6.977D-06, 3.615D-11, & 1.535D+02, 2.858D-01,-3.499D-06, 1.838D-11, & 1.049D+02, 1.660D-01,-2.060D-06, 1.090D-11, & 7.412D+01, 1.070D-01,-1.339D-06, 7.118D-12, & 5.428D+01, 7.389D-02,-9.304D-07, 4.963D-12, & 4.103D+01, 5.366D-02,-6.786D-07, 3.629D-12/ DATA ((CCOOL(I, 8, K),I=1,4),K=1,15)/ 32*0., & -2.069D+04, 2.637D+01,-2.802D-04, 1.342D-09, & 2.055D+02, 3.731D+00,-4.420D-05, 2.276D-10, & 5.123D+02, 1.292D+00,-1.599D-05, 8.442D-11, & 3.578D+02, 6.265D-01,-7.922D-06, 4.235D-11, & 2.438D+02, 3.616D-01,-4.633D-06, 2.494D-11, & 1.721D+02, 2.322D-01,-3.000D-06, 1.622D-11, & 1.260D+02, 1.601D-01,-2.081D-06, 1.129D-11/ DATA ((CCOOL(I, 9, K),I=1,4),K=1,15)/ 36*0., & -4.032D+04, 5.614D+01,-6.231D-04, 3.073D-09, & 6.989D+02, 7.655D+00,-9.352D-05, 4.903D-10, & 1.141D+03, 2.605D+00,-3.313D-05, 1.777D-10, & 7.755D+02, 1.250D+00,-1.624D-05, 8.808D-11, & 5.234D+02, 7.175D-01,-9.437D-06, 5.153D-11, & 3.677D+02, 4.590D-01,-6.087D-06, 3.338D-11/ DATA ((CCOOL(I,10, K),I=1,4),K=1,15)/ 40*0., & -7.097D+04, 1.101D+02,-1.266D-03, 6.390D-09, & 2.018D+03, 1.455D+01,-1.824D-04, 9.708D-10, & 2.383D+03, 4.875D+00,-6.348D-05, 3.449D-10, & 1.569D+03, 2.319D+00,-3.081D-05, 1.691D-10, & 1.046D+03, 1.323D+00,-1.779D-05, 9.830D-11/ DATA ((CCOOL(I,11, K),I=1,4),K=1,15)/ 44*0., & -1.150D+05, 2.020D+02,-2.392D-03, 1.231D-08, & 4.988D+03, 2.601D+01,-3.334D-04, 1.797D-09, & 4.675D+03, 8.595D+00,-1.142D-04, 6.273D-10, & 2.986D+03, 4.054D+00,-5.491D-05, 3.046D-10/ DATA ((CCOOL(I,12, K),I=1,4),K=1,15)/ 48*0., & -1.737D+05, 3.511D+02,-4.263D-03, 2.227D-08, & 1.094D+04, 4.419D+01,-5.774D-04, 3.146D-09, & 8.673D+03, 1.442D+01,-1.950D-04, 1.082D-09/ DATA ((CCOOL(I,13, K),I=1,4),K=1,15)/ 52*0., & -2.459D+05, 5.829D+02,-7.233D-03, 3.830D-08, & 2.191D+04, 7.194D+01,-9.561D-04, 5.259D-09/ DATA ((CCOOL(I,14, K),I=1,4),K=1,15)/ 56*0., & -3.273D+05, 9.312D+02,-1.178D-02, 6.306D-08/ DATA ((CHOT(I, 1, K),I=1,4),K=1,15)/ 4*0., & 5.856D-01, 1.551D-05,-9.669D-12, 5.716D-19, & 1.537D-01, 3.548D-06,-3.224D-12, 7.626D-19, & 2.400D-02, 1.419D-06,-2.008D-12, 1.356D-18, & 2.002D-02, 6.325D-07,-7.070D-13, 4.096D-19, & 1.123D-02, 3.549D-07,-3.998D-13, 2.331D-19, & 6.940D-03, 2.194D-07,-2.483D-13, 1.453D-19, & 4.593D-03, 1.453D-07,-1.648D-13, 9.667D-20, & 3.199D-03, 1.012D-07,-1.150D-13, 6.758D-20, & 2.318D-03, 7.334D-08,-8.349D-14, 4.910D-20, & 1.727D-03, 5.493D-08,-6.270D-14, 3.695D-20, & 1.326D-03, 4.218D-08,-4.821D-14, 2.844D-20, & 1.040D-03, 3.310D-08,-3.786D-14, 2.236D-20, & 8.305D-04, 2.645D-08,-3.028D-14, 1.790D-20, & 6.740D-04, 2.147D-08,-2.460D-14, 1.455D-20/ DATA ((CHOT(I, 2, K),I=1,4),K=1,15)/ 8*0., & 1.710D+01, 1.530D-03,-2.553D-09, 1.924D-15, & 8.237D+00, 3.554D-04,-7.566D-10, 6.420D-16, & 5.932D+00, 1.301D-04,-2.912D-10, 2.535D-16, & 2.987D+00, 6.419D-05,-1.444D-10, 1.260D-16, & 1.733D+00, 3.689D-05,-8.324D-11, 7.267D-17, & 1.102D+00, 2.334D-05,-5.273D-11, 4.605D-17, & 7.472D-01, 1.576D-05,-3.567D-11, 3.116D-17, & 5.312D-01, 1.118D-05,-2.532D-11, 2.212D-17, & 3.919D-01, 8.232D-06,-1.865D-11, 1.630D-17, & 2.977D-01, 6.245D-06,-1.416D-11, 1.237D-17, & 2.315D-01, 4.855D-06,-1.101D-11, 9.622D-18, & 1.838D-01, 3.851D-06,-8.734D-12, 7.635D-18, & 1.484D-01, 3.108D-06,-7.050D-12, 6.164D-18/ DATA ((CHOT(I, 3, K),I=1,4),K=1,15)/ 12*0., & 1.940D+02, 1.949D-02,-3.832D-08, 3.137D-14, & 4.729D+02, 1.927D-03,-4.171D-09, 3.628D-15, & 6.741D+01, 1.315D-03,-3.145D-09, 2.814D-15, & 3.444D+01, 6.477D-04,-1.560D-09, 1.399D-15, & 2.031D+01, 3.744D-04,-9.054D-10, 8.130D-16, & 1.311D+01, 2.388D-04,-5.789D-10, 5.203D-16, & 9.007D+00, 1.629D-04,-3.955D-10, 3.556D-16, & 6.484D+00, 1.166D-04,-2.835D-10, 2.550D-16, & 4.837D+00, 8.666D-05,-2.108D-10, 1.896D-16, & 3.711D+00, 6.631D-05,-1.614D-10, 1.452D-16, & 2.914D+00, 5.194D-05,-1.265D-10, 1.138D-16, & 2.332D+00, 4.150D-05,-1.011D-10, 9.100D-17/ DATA ((CHOT(I, 4, K),I=1,4),K=1,15)/ 16*0., & 7.204D+03, 1.627D-01,-5.181D-07, 5.605D-13, & 2.507D+03, 9.370D-03,-2.091D-08, 1.842D-14, & 3.823D+02, 6.480D-03,-1.600D-08, 1.452D-14, & 1.950D+02, 3.161D-03,-7.869D-09, 7.157D-15, & 1.154D+02, 1.823D-03,-4.561D-09, 4.154D-15, & 7.486D+01, 1.165D-03,-2.924D-09, 2.665D-15, & 5.178D+01, 7.977D-04,-2.006D-09, 1.830D-15, & 3.752D+01, 5.737D-04,-1.444D-09, 1.318D-15, & 2.816D+01, 4.283D-04,-1.080D-09, 9.858D-16, & 2.174D+01, 3.293D-04,-8.307D-10, 7.587D-16, & 1.717D+01, 2.592D-04,-6.544D-10, 5.978D-16/ DATA ((CHOT(I, 5, K),I=1,4),K=1,15)/ 20*0., & 2.166D+04, 4.690D-01,-1.122D-06, 1.008D-12, & 3.874D+03, 6.443D-02,-1.596D-07, 1.452D-13, & 1.465D+03, 2.207D-02,-5.556D-08, 5.082D-14, & 7.410D+02, 1.062D-02,-2.698D-08, 2.476D-14, & 4.374D+02, 6.096D-03,-1.556D-08, 1.430D-14, & 2.841D+02, 3.889D-03,-9.962D-09, 9.167D-15, & 1.969D+02, 2.663D-03,-6.838D-09, 6.297D-15, & 1.431D+02, 1.918D-03,-4.935D-09, 4.547D-15, & 1.078D+02, 1.436D-03,-3.698D-09, 3.409D-15, & 8.353D+01, 1.107D-03,-2.854D-09, 2.632D-15/ DATA ((CHOT(I, 6, K),I=1,4),K=1,15)/ 24*0., & 7.146D+04, 1.379D+00,-3.346D-06, 3.023D-12, & 1.187D+04, 1.794D-01,-4.501D-07, 4.118D-13, & 4.380D+03, 5.990D-02,-1.527D-07, 1.405D-13, & 2.192D+03, 2.846D-02,-7.324D-08, 6.759D-14, & 1.288D+03, 1.621D-02,-4.197D-08, 3.881D-14, & 8.351D+02, 1.031D-02,-2.678D-08, 2.480D-14, & 5.790D+02, 7.050D-03,-1.837D-08, 1.702D-14, & 4.213D+02, 5.079D-03,-1.326D-08, 1.229D-14, & 3.179D+02, 3.804D-03,-9.944D-09, 9.226D-15/ DATA ((CHOT(I, 7, K),I=1,4),K=1,15)/ 28*0., & 1.954D+05, 3.426D+00,-8.397D-06, 7.624D-12, & 3.057D+04, 4.266D-01,-1.080D-06, 9.917D-13, & 1.103D+04, 1.392D-01,-3.582D-07, 3.309D-13, & 5.458D+03, 6.530D-02,-1.696D-07, 1.572D-13, & 3.189D+03, 3.693D-02,-9.653D-08, 8.966D-14, & 2.062D+03, 2.338D-02,-6.136D-08, 5.707D-14, & 1.429D+03, 1.595D-02,-4.200D-08, 3.910D-14, & 1.039D+03, 1.148D-02,-3.029D-08, 2.282D-14/ DATA ((CHOT(I, 8, K),I=1,4),K=1,15)/ 32*0., & 4.651D+05, 7.527D+00,-1.859D-05, 1.694D-11, & 6.930D+04, 9.038D-01,-2.302D-06, 2.121D-12, & 2.450D+04, 2.891D-01,-7.487D-07, 6.939D-13, & 1.200D+04, 1.340D-01,-3.505D-07, 3.260D-13, & 6.970D+03, 7.523D-02,-1.981D-07, 1.846D-13, & 4.493D+03, 4.741D-02,-1.254D-07, 1.170D-13, & 3.106D+03, 3.226D-02,-8.559D-08, 7.997D-14/ DATA ((CHOT(I, 9, K),I=1,4),K=1,15)/ 36*0., & 9.956D+05, 1.506D+01,-3.741D-05, 3.418D-11, & 1.425D+05, 1.754D+00,-4.489D-06, 4.146D-12, & 4.949D+04, 5.510D-01,-1.435D-06, 1.333D-12, & 2.401D+04, 2.526D-01,-6.645D-07, 6.196D-13, & 1.386D+04, 1.408D-01,-3.729D-07, 3.485D-13, & 8.904D+03, 8.835D-02,-2.350D-07, 2.200D-13/ DATA ((CHOT(I,10, K),I=1,4),K=1,15)/ 40*0., & 1.961D+06, 2.798D+01,-6.982D-05, 6.394D-11, & 2.715D+05, 3.175D+00,-8.158D-06, 7.551D-12, & 9.279D+04, 9.821D-01,-2.567D-06, 2.390D-12, & 4.460D+04, 4.458D-01,-1.178D-06, 1.100D-12, & 2.561D+04, 2.468D-01,-6.566D-07, 6.150D-13/ DATA ((CHOT(I,11, K),I=1,4),K=1,15)/ 44*0., & 3.613D+06, 4.898D+01,-1.227D-04, 1.125D-10, & 4.861D+05, 5.434D+00,-1.401D-05, 1.299D-11, & 1.638D+05, 1.658D+00,-4.348D-06, 4.054D-12, & 7.810D+04, 7.456D-01,-1.976D-06, 1.850D-12/ DATA ((CHOT(I,12, K),I=1,4),K=1,15)/ 48*0., & 6.300D+06, 8.163D+01,-2.051D-04, 1.884D-10, & 8.271D+05, 8.881D+00,-2.296D-05, 2.131D-11, & 2.753D+05, 2.676D+00,-7.037D-06, 6.571D-12/ DATA ((CHOT(I,13, K),I=1,4),K=1,15)/ 52*0., & 1.049D+07, 1.305D+02,-3.288D-04, 3.025D-10, & 1.348D+06, 1.396D+01,-3.617D-05, 3.361D-11/ DATA ((CHOT(I,14, K),I=1,4),K=1,15)/ 56*0., & 1.680D+07, 2.016D+02,-5.089D-04, 4.687D-10/ C HKT=HK/T CT=CC0*SQRT(T) TK=HKT/H t0=t X=LOG10(T) X2=X*X X3=X*X2 X4=X2*X2 X5=X3*X2 XTT(1)=1. XTT(2)=T XTT(3)=T*T XTT(4)=T*T*T SQT=SQRT(T) N0HN=NFIRST(IELH) N1H=NLAST(IELH) NKH=NKA(IATH) N0Q=NQUANT(N1H)+1 N1Q=ICUP(IELH) DO 200 II=N0HN,N1H I=II-N0HN+1 IT=ITRA(II,NKH) IF(IT.EQ.0) GO TO 100 C C *************** Collisional ionization C c for high temperature, use XSTAR formulae C if(t0.gt.1.e6) then rno=16. izc=1 call irc(i,t0,izc,rno,cs) col(it)=cs go to 100 end if C IC=ICOL(IT) U0=FR0(IT)*HKT IF(IC.LT.0) GO TO 90 if(ifwop(ii).lt.0) go to 95 GAM=I*I*I IF(I.GT.10) GO TO 80 GAM=A(1,I)+A(2,I)*X+A(3,I)*X2+A(4,I)*X3 * +A(5,I)*X4+A(6,I)*X5 80 COL(IT)=CT*EXP(-U0)*GAM GO TO 100 C C non-standard (user supplied) formula C 90 CALL CSPEC(II,NKH,IC,OSC0(IT),CPAR(IT),U0,T,COL(IT)) go to 100 c c ionization from the merged state c 95 sum1=0. sum2=0. ehk=eh/tk n00q=nquant(n1h-1)+1 n11q=nlmx do img=n00q,n11q xi=img xii=xi*xi sum1=sum1+xii*xii*xi*wnhint(img,id) sum2=sum2+xii*wnhint(img,id)*exp(ehk/xii) end do col(it)=ct*sum1/sum2 go to 200 C C ***************** Collisional excitation C 100 CONTINUE I1=I+1 XI=I VI=XI*XI ALF=ALF0-ALF1/VI BET=BET0-BET1/XI NHL=N1H-N0HN+1 IF(N1Q.GT.0) NHL=N1Q N1HC=N1H IF(IFWOP(N1H).LT.0) THEN NHL=NLMX N1HC=N1H-1 END IF CSUM=0. IF(I1.GT.NHL) GO TO 200 CSCA=8.63D-6/2./VI/SQT DO 190 J=I1,NHL XJ=J VJ=XJ*XJ IC=0 JJ=J+N0HN-1 IF(JJ.GT.N1HC) GO TO 150 ICT=ITRA(II,JJ) IF(ICT.EQ.0) GO TO 190 IC=ICOL(ICT) U0=FR0(ICT)*HKT E=U0/EH/TK C1=OSC0(ICT) IF(IC.LT.0) THEN CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT)) ELSE IF(IC.EQ.0) THEN GO TO 160 ELSE IF(IC.EQ.1) THEN COL(ICT)=CT*EXP(-U0)*(CEX1+CEX2*X+CEX3/X/X) ELSE IF(IC.GE.2) THEN COL(ICT)=CEH12(T) END IF GO TO 190 C C collisional excitations from level I to higher, non-explicit C levels are lumped into the collisional ionization rate C (the so-called modified collision ionization rate) C 150 CONTINUE E=UN/VI-UN/VJ U0=EH*E*TK IF(J.LE.20) C1=OSH(I,J) IF(J.GT.20) THEN C1=OSH(I,20)*((400.-VI)/20.*XJ/(VJ-VI))**3 end if 160 CONTINUE C IF(ICOLHN.EQ.1.AND.J.LE.7) GO TO 250 IF(ICOLHN.EQ.2.AND.J.LE.15) GO TO 260 C C Old standard formula for the collisional excitation rate - used for C rates in explicit transitions as well as for evaluation of the C modified collisional rate C IF(ICOLHN.EQ.1.AND.J.LE.7) GO TO 250 IF(ICOLHN.EQ.2.AND.J.LE.15) GO TO 260 CS=4.*CT*C1/E/E EX=EXP(-U0) IF(U0.LE.UN) THEN E1=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE E1=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF E5=E1 DO IX=1,4 E5=(EX-U0*E5)/IX END DO CS=CS*U0*(E1+O148*U0*E5) IF(J-I.NE.1) CS=CS*(BET+TWO*(ALF-BET)/(XJ-XI)) GO TO 180 C End of the old standard formula (Mihalas et al 1975) C c Butler new calculations c 250 call butler(i,j,t,u0,cs,ierr) go to 180 c C Giovanardi et al. 1987, AAS, 70, 269 C Cool: T<=60000K ; Hot: T>60000K C 260 IF(T.GT.60000.) GO TO 270 CS=CCOOL(1,I,J) DO ICA=2,4 CS=CS+CCOOL(ICA,I,J)*XTT(ICA) END DO GO TO 280 270 CS=CHOT(1,I,J) DO ICA=2,4 CS=CS+CHOT(ICA,I,J)*XTT(ICA) END DO 280 CS=CSCA*CS*EXP(-U0) C 180 IF(JJ.GT.N1HC) THEN CSUM=CSUM+CS ELSE COL(ICT)=CS END IF 190 CONTINUE IF(IT.NE.0.AND.N1Q.GT.0) COL(IT)=COL(IT)+CSUM ITH=ITRA(II,N1H) IF(IFWOP(N1H).LT.0.AND.ITH.GT.0) COL(ITH)=CSUM 200 CONTINUE C C special standard formula for collisional ionization of H- C IF(IELHM.EQ.0) RETURN IT=ITRA(NFIRST(IELHM),N0HN) IF(IT.EQ.0) RETURN IC=ICOL(IT) IF(IC.GE.0) THEN COL(IT)=CHMI*T*SQRT(T) ELSE C C if desired, non-standard, user supplied, formula for H- C U0=ENION(NFIRST(IELHM))*TK CALL CSPEC(NFIRST(IELHM),N0HN,IC,OSC0(IT),CPAR(IT),U0,T,CS) COL(IT)=CS END IF RETURN END C C C **************************************************************** C C SUBROUTINE BUTLER (NI,NJ,T,U0,COL,IERR) C ======================================= C C Rate coefficients for collisional excitation of hydrogen C by electrons. Interpolates in Table 3 of Przybilla & Butler C (2004, ApJ). C C C Input: C NI Principal quantum number lower level C NJ "" upper level C T Temperature C U0 =h*nu/K/T C Output: C COL collisional rate (cm3 s-1) C IERR error flat (0=ok, 1=T exceeds table range, C 2=NI higher than 6 or lower than 1 C NJ higher than 7 or lower than 2) C INCLUDE 'IMPLIC.FOR' DIMENSION COLSTR(16,21),TREF(16) DATA (TREF(I), I=1,16) / * 2.5d3, 5d3, 7.5d3, 1d4, 1.5d4, 2d4, 2.5d4, 3d4, 4d4, 5d4, 6d4, * 8d4, 1d5, 1.5d5, 2d5, 2.5d5 / DATA ((COLSTR(I,J),J=1,21),I=1,16) / C J=1,21 corresponds to (NI,NJ)={(1,2),(1,3),...,(1,NL),(2,3),...} C where NL=7 (higher n covered in Table) C I=1,16 corresponds to T={2.5e3,5e3,7.5e3,1e4,1.5e4,2e4,2.5e4,3e4, C 4e4,5e4,6e4,8e4,1e5,1.5e5,2e5,2.5e5} * 6.40d-1, 2.20d-1, 9.93d-2, 4.92d-2, 2.97d-2, 5.03d-2, 2.35d+1, * 1.07d+1, 5.22d+0, 2.91d+0, 5.25d+0, 1.50d+2, 7.89d+1, 4.13d+1, * 7.60d+1, 5.90d+2, 2.94d+2, 4.79d+2, 1.93d+3, 1.95d+3, 6.81d+3, * 6.98d-1, 2.40d-1, 1.02d-1, 5.84d-2, 4.66d-2, 6.72d-2, 2.78d+1, * 1.15d+1, 5.90d+0, 4.53d+0, 7.26d+0, 1.90d+2, 9.01d+1, 6.11d+1, * 1.07d+2, 8.17d+2, 4.21d+2, 7.06d+2, 2.91d+3, 3.24d+3, 1.17d+4, * 7.57d-1, 2.50d-1, 1.10d-1, 7.17d-2, 6.28d-2, 7.86d-2, 3.09d+1, * 1.23d+1, 6.96d+0, 6.06d+0, 8.47d+0, 2.28d+2, 1.07d+2, 8.21d+1, * 1.25d+2, 1.07d+3, 5.78d+2, 8.56d+2, 4.00d+3, 4.20d+3, 1.50d+4, * 8.09d-1, 2.61d-1, 1.22d-1, 8.58d-2, 7.68d-2, 8.74d-2, 3.38d+1, * 1.34d+1, 8.15d+0, 7.32d+0, 9.27d+0, 2.70d+2, 1.26d+2, 1.01d+2, * 1.37d+2, 1.35d+3, 7.36d+2, 9.66d+2, 5.04d+3, 4.95d+3, 1.73d+4, * 8.97d-1, 2.88d-1, 1.51d-1, 1.12d-1, 9.82d-2, 1.00d-1, 4.01d+1, * 1.62d+1, 1.04d+1, 9.17d+0, 1.03d+1, 3.64d+2, 1.66d+2, 1.31d+2, * 1.52d+2, 1.93d+3, 1.02d+3, 1.11d+3, 6.81d+3, 6.02d+3, 2.03d+4, * 9.78d-1, 3.22d-1, 1.80d-1, 1.33d-1, 1.14d-1, 1.10d-1, 4.71d+1, * 1.90d+1, 1.23d+1, 1.05d+1, 1.08d+1, 4.66d+2, 2.03d+2, 1.54d+2, * 1.61d+2, 2.47d+3, 1.26d+3, 1.21d+3, 8.20d+3, 6.76d+3, 2.21d+4, * 1.06d+0, 3.59d-1, 2.06d-1, 1.50d-1, 1.25d-1, 1.16d-1, 5.45d+1, * 2.18d+1, 1.39d+1, 1.14d+1, 1.12d+1, 5.70d+2, 2.37d+2, 1.72d+2, * 1.68d+2, 2.96d+3, 1.46d+3, 1.29d+3, 9.29d+3, 7.29d+3, 2.33d+4, * 1.15d+0, 3.96d-1, 2.28d-1, 1.64d-1, 1.33d-1, 1.21d-1, 6.20d+1, * 2.44d+1, 1.52d+1, 1.21d+1, 1.14d+1, 6.72d+2, 2.68d+2, 1.86d+2, * 1.72d+2, 3.40d+3, 1.64d+3, 1.34d+3, 1.02d+4, 7.70d+3, 2.41d+4, * 1.32d+0, 4.64d-1, 2.66d-1, 1.85d-1, 1.45d-1, 1.27d-1, 7.71d+1, * 2.89d+1, 1.74d+1, 1.31d+1, 1.17d+1, 8.66d+2, 3.19d+2, 2.08d+2, * 1.78d+2, 4.14d+3, 1.92d+3, 1.41d+3, 1.15d+4, 8.26d+3, 2.52d+4, * 1.51d+0, 5.26d-1, 2.95d-1, 2.01d-1, 1.53d-1, 1.31d-1, 9.14d+1, * 3.27d+1, 1.90d+1, 1.38d+1, 1.18d+1, 1.04d+3, 3.62d+2, 2.24d+2, * 1.81d+2, 4.75d+3, 2.15d+3, 1.46d+3, 1.26d+4, 8.63d+3, 2.60d+4, * 1.68d+0, 5.79d-1, 3.18d-1, 2.12d-1, 1.58d-1, 1.34d-1, 1.05d+2, * 3.60d+1, 2.03d+1, 1.44d+1, 1.19d+1, 1.19d+3, 3.98d+2, 2.36d+2, * 1.83d+2, 5.25d+3, 2.33d+3, 1.50d+3, 1.34d+4, 8.88d+3, 2.69d+4, * 2.02d+0, 6.70d-1, 3.55d-1, 2.29d-1, 1.65d-1, 1.35d-1, 1.29d+2, * 4.14d+1, 2.23d+1, 1.51d+1, 1.19d+1, 1.46d+3, 4.53d+2, 2.53d+2, * 1.85d+2, 6.08d+3, 2.61d+3, 1.55d+3, 1.49d+4, 9.21d+3, 2.90d+4, * 2.33d+0, 7.43d-1, 3.83d-1, 2.39d-1, 1.70d-1, 1.37d-1, 1.51d+2, * 4.56d+1, 2.37d+1, 1.56d+1, 1.20d+1, 1.67d+3, 4.95d+2, 2.65d+2, * 1.86d+2, 6.76d+3, 2.81d+3, 1.57d+3, 1.63d+4, 9.43d+3, 3.17d+4, * 2.97d+0, 8.80d-1, 4.30d-1, 2.59d-1, 1.77d-1, 1.39d-1, 1.93d+2, * 5.31d+1, 2.61d+1, 1.63d+1, 1.19d+1, 2.08d+3, 5.68d+2, 2.83d+2, * 1.87d+2, 8.08d+3, 3.15d+3, 1.61d+3, 1.97d+4, 9.78d+3, 3.94d+4, * 3.50d+0, 9.79d-1, 4.63d-1, 2.71d-1, 1.82d-1, 1.39d-1, 2.26d+2, * 5.83d+1, 2.78d+1, 1.68d+1, 1.19d+1, 2.39d+3, 6.16d+2, 2.94d+2, * 1.86d+2, 9.13d+3, 3.36d+3, 1.62d+3, 2.27d+4, 1.00d+4, 4.73d+4, * 3.95d+0, 1.06d+0, 4.88d-1, 2.81d-1, 1.85d-1, 1.40d-1, 2.52d+2, * 6.23d+1, 2.89d+1, 1.71d+1, 1.19d+1, 2.62d+3, 6.51d+2, 3.02d+2, * 1.87d+2, 1.00d+4, 3.51d+3, 1.63d+3, 2.54d+4, 1.02d+4, 5.50d+4 / NL=7 IERR=0 COL=0.0d0 IF (T.LT.2.5d3.OR.T.GE.2.5d5) IERR=1 IF (NI.LT.1.OR.NI.GT.NL-1.OR.NJ.LT.2.OR.NJ.GT.NL) IERR=2 IF (IERR.EQ.0) THEN J=0 DO I=1,NI-1 J=J+(NL-I) END DO DO K=I+1,NJ J=J+1 END DO C find out nearest points in TREF ILOW=1 DO WHILE (T.GE.TREF(ILOW+1)) ILOW=ILOW+1 END DO IHIG=16 DO WHILE (T.LT.TREF(IHIG-1)) IHIG=IHIG-1 END DO IF (IHIG.EQ.ILOW) IHIG=IHIG+1 C interpolate linearly (log-log) the collision strength SL=LOG10(COLSTR(IHIG,J))-LOG10(COLSTR(ILOW,J)) SL=SL/(LOG10(TREF(IHIG))-LOG10(TREF(ILOW))) OR=LOG10(COLSTR(IHIG,J))-SL*LOG10(TREF(IHIG)) COL=LOG10(T)*SL+OR COL=10.**COL C derive the rate COL=8.631d-6/(2.d0*NI**2)/SQRT(T)*EXP(-U0)*COL END IF RETURN END C C C **************************************************************** C C SUBROUTINE COLHE(T,COL) C ======================= C C Helium (both neutral and ionized) collision rates C C Meaning of ICOL: for all kinds of transitions and for both HeI C and HeII: C ICOL = 0 - approximate expressions taken from Mihalas, Heasley C and Auer, NCAR-TN/STR-104 (1975) - for He I and II C C New expression for He II collisional ionization from Klaus Werner C (ICOL >= 1) (also originally from Mihalas) C C For He I bound-bound transitions, the following standard C possibilities are also available: C C ICOL = 1, 2, or 3 - much more accurate Storey's rates, C subroutine written by D.G.Hummer (COLLHE). C This procedure can be used only for transitions C between states with n = 1, 2, 3, 4. C ICOL = 1 - means that a given transition is a transition C between non-averaged (l,s) states. In this case, C labeling of the He I energy levels must agree C with that given in subroutine COLLHE, ie. states C have to be labeled sequentially in order of C increasing frequency. C ICOL = 2 - means that a given transition is a transition between C a non-averaged (l,s) lower state and averaged upper C state. C ICOL = 3 - means that a given transition is a transition between C two averaged states. C Note: C The program allows only two standard possibilities of C constructing averaged levels of He I: C i) all states within given principal quantum number n (>1) are C lumped together C ii) all siglet states for given n, and all triplet states for C given n are lumped together separately (there are thus two C explicit levels for a given n). C If the user wants to use another averaging, he had to take care C of appropriate averaged collisional rates himself (by updating C subroutine CSPEC) C C C ICOL < 0 - non-standard, user supplied formula C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' DIMENSION COL(MTRANS) DIMENSION FHE1(16),G0(3),G1(3),G2(3),G3(3),A(6,10) PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193, * EXPIA3=-0.24991055,EXPIA4=0.05519968, * EXPIA5=-0.00976004,EXPIA6=0.00107857, * EXPIB1=0.2677734343,EXPIB2=8.6347608925, * EXPIB3=18.059016973,EXPIB4=8.5733287401, * EXPIC1=3.9584969228,EXPIC2=21.0996530827, * EXPIC3=25.6329561486,EXPIC4=9.5733223454) DATA FHE1/0.,2.75D-1,7.29D-2,2.96D-2,1.48 D-2,8.5D-3,5.3D-3, * 3.5D-3,2.5D-3,1.8D-3,1.5D-3,1.2D-3,9.4D-4,7.5D-4, * 6.1D-4,5.3D-4/ DATA G0/ 7.3399521D-2, 1.7252867, 8.6335087 /, * G1/-1.4592763D-7, 2.0944117D-6, 2.7575544D-5 /, * G2/ 7.6621299D5, 5.4254879D6, 6.6395519D6 /, * G3/ 2.3775439D2, 2.2177891D3, 5.20725D3 / DATA ((A(I,J),J=1,10),I=1,6) / * -8.5931587 , 85.014091 , 923.64099, 2018.6470, 1551.5061 , * -2327.4819 ,-10701.481 ,-27619.789,-41099.602,-61599.023 , * 9.3868790 ,-78.834488 ,-969.18451,-2243.1768,-2059.9768 , * 1546.7107 , 9834.3447 , 27067.436, 41421.254, 63594.133 , * -4.0027571 , 28.360615 , 401.23965, 983.83374, 1051.4103 , * -204.82320 ,-3335.4211 ,-10100.119,-15863.257,-24949.125 , * 0.83941799 ,-4.7963457 ,-81.122566,-209.86169,-251.30855 , * -43.175175 , 530.37292 , 1826.1049, 2941.6460, 4740.8364 , * -.86396709E-01,0.37385577 , 8.0078983, 21.757591, 28.375637 , * 11.890312 ,-39.536087 ,-161.52513,-266.86011,-440.88257 , * 0.34853835E-02,-.10401310E-01,-.30957383,-.87988985,-1.2254572 , * -.72724497 , 1.0879648 , 5.6239786, 9.5323009, 16.150818 / SAVE FHE1,G0,G1,G2,G3 C HKT=HK/T TK=HKT/H SRT=SQRT(T) t0=t CT=5.465D-11*SRT CT1=5.4499487/T/SRT C C -------------- C Neutral helium C -------------- C IF(IELHE1.EQ.0) GO TO 60 ICALL=0 N0I=NFIRST(IELHE1) N1I=NLAST(IELHE1) NKI=NNEXT(IELHE1) N0Q=NQUANT(NLAST(IELHE1))+1 N1Q=ICUP(IELHE1) DO 50 II=N0I,N1I IT=ITRA(II,NKI) IF(IT.EQ.0) GO TO 10 C C ******** Collisional ionization C IC=ICOL(IT) C1=OSC0(IT) C2=CPAR(IT) U0=ENION(II)*TK IF(IC.GE.0) THEN U1=U0+0.27 U2=(U0+3.43)/(U0+1.43)**3 IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF IF(U1.LE.UN) THEN EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+ * U1*(EXPIA5+U1*EXPIA6)))) ELSE EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+ * U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+ * U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1 END IF COL(IT)=CT*C1*U0*(EXPIU0-U0*(0.728*EXPIU1/U1+ * 0.189*EXP(-U0)*U2)) ELSE CALL CSPEC(II,NKI,IC,C1,C2,U0,T,COL(IT)) END IF 10 IF(II.GE.N1I) GO TO 30 C C ********* Collisional excitation C DO 20 JJ=II+1,N1I ICT=ITRA(II,JJ) IF(ICT.EQ.0) GO TO 20 IC=ICOL(ICT) C1=OSC0(ICT) C2=CPAR(ICT) U0=FR0(ICT)*HKT IF(IC.EQ.0) THEN C C *** ICOL = 0 Formula used by Mihalas, Heasley, and Auer C IF(U0.LE.UN) THEN EX=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EX=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF IF(II.EQ.N0I) THEN C C excitation from the ground state C COL(ICT)=CT1*EX/U0*C1 ELSE C C transitions between excited states C U1=U0+0.2 IF(U1.LE.UN) THEN EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+ * U1*(EXPIA5+U1*EXPIA6)))) ELSE EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+ * U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+ * U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1 END IF COL(ICT)=CT1/U0*(EX-U0/U1*0.81873*EXPIU1)*C1 END IF ELSE IF(IC.EQ.1) THEN C C *** ICOL = 1 Storey - Hummer collisional rates between C non-averaged states C (Note: procedure COLLHE, which calculates all rates, C is called only once) C IF(ICALL.EQ.0) CALL COLLHE(T,COLHE1) ICALL=1 COL(ICT)=COLHE1(II-N0I+1,JJ-N0I+1) ELSE IF(IC.EQ.2.OR.IC.EQ.3) THEN C C *** ICOL = 2 or 3 Storey - Hummer collisional rates between C averaged states C IF(ICALL.EQ.0) CALL COLLHE(T,COLHE1) ICALL=1 COL(ICT)=CHEAV(II,JJ,IC) ELSE IF(IC.LT.0) THEN C C Non-standard, user supplied formula C CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT)) END IF 20 CONTINUE C C collisional excitations from level II to higher, non-explicit C levels are lumped into the collisional ionization rate C (the so-called modified collision ionization rate); C the individual rates are calculated by expressions used by C Mihalas, Heasley, and Auer C 30 IF(N1Q.EQ.0.OR.IT.EQ.0) GO TO 50 I=NQUANT(II) REL=G(II)/2./I/I DO 40 J=N0Q,N1Q XJ=J U0=(ENION(II)-EH/XJ/XJ)*TK IF(I.EQ.1) THEN GAM=0. C1=FHE1(J) ELSE C1=OSH(I,J)*REL U1=U0+0.2 IF(U1.LE.UN) THEN EXPIU1=-LOG(U1)+EXPIA1+U1*(EXPIA2+U1*(EXPIA3+U1*(EXPIA4+ * U1*(EXPIA5+U1*EXPIA6)))) ELSE EXPIU1=EXP(-U1)*((EXPIB1+U1*(EXPIB2+U1*(EXPIB3+ * U1*(EXPIB4+U1))))/(EXPIC1+U1*(EXPIC2+ * U1*(EXPIC3+U1*(EXPIC4+U1)))))/U1 END IF GAM=U0/U1*0.81873*EXPIU1 END IF IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF COL(IT)=COL(IT)+CT1/U0*C1*(EXPIU0-GAM) 40 CONTINUE 50 CONTINUE C C -------------- C Ionized helium C -------------- C 60 IF(IELHE2.EQ.0) RETURN N0I=NFIRST(IELHE2) N1I=NLAST(IELHE2) NKI=NNEXT(IELHE2) N0Q=NQUANT(NLAST(IELHE2))+1 N1Q=ICUP(IELHE2) X=LOG10(T) X2=X*X X3=X2*X X4=X3*X X5=X4*X CT2=3.7036489/T/SRT C DO 200 II=N0I,N1I I=II-N0I+1 IT=ITRA(II,NKI) IF(IT.EQ.0) GO TO 100 C C ********* Collisional ionization C c for high temperature, use XSTAR formulae C if(t0.gt.1.e5) then rno=16. izc=2 call irc(i,t0,izc,rno,cs) col(it)=cs go to 100 end if C IC=ICOL(IT) U0=FR0(IT)*HKT IF(IC.EQ.0) THEN IF(I.LE.3) THEN GAM=G0(I)-G1(I)*T+(G2(I)/T-G3(I))/T ELSE IF(I.EQ.4) THEN GAM=-95.23828+(62.656249-8.1454078*X)*X ELSE IF(I.EQ.5) THEN GAM=472.99219-74.144287*X-1869.6562/X2 ELSE IF(I.EQ.6) THEN GAM=825.17186-134.23096*X-2739.4375/X2 ELSE IF(I.EQ.7) THEN GAM=1181.3516-200.71191*X-2810.7812/X2 ELSE IF(I.EQ.8) THEN GAM=1440.1016-259.75781*X-1283.5625/X2 ELSE IF(I.EQ.9) THEN GAM=2492.1250-624.84375*X+30.101562*X2 ELSE IF(I.EQ.10) THEN GAM=4663.3129-1390.1250*X+97.671874*X2 ELSE GAM=I*I*I END IF COL(IT)=CT*EXP(-U0)*GAM ELSE IF(IC.GE.1) THEN GAM=I*I*I IF(I.LE.10) GAM=A(1,I)+A(2,I)*X+A(3,I)*X2+ * A(4,I)*X3+A(5,I)*X4+A(6,I)*X5 COL(IT)=CT*EXP(-U0)*GAM ELSE CALL CSPEC(II,NKI,IC,OSC0(IT),CPAR(IT),U0,T,COL(IT)) END IF C 100 I1=I+1 XI=I VI=XI*XI NHL=N1I-N0I+1 IF(N1Q.GT.0) NHL=N1Q IF(I1.GT.NHL) GO TO 200 C C ********** collisional excitation C C both explicit transitions as well as contributions to the C modified collisional ionization rate C DO 150 J=I1,NHL JJ=J+N0I-1 IC=0 IF(JJ.GT.N1I) GO TO 110 ICT=ITRA(II,JJ) IF(ICT.EQ.0) GO TO 150 IC=ICOL(ICT) 110 XJ=J VJ=XJ*XJ U0=ENION(N0I)*(1./VI-1./VJ)*TK IF(J.LE.20) C1=OSH(I,J) IF(J.GT.20) C1=OSH(I,20)*(20./XJ)**3 IF(IC.LT.0) GO TO 120 GAM=XI-(XI-1.)/(XJ-XI) IF(GAM.GT.XJ-XI) GAM=XJ-XI IF(I.GT.1) GAM=GAM*1.1 IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF CS=CT2/U0*C1*(0.693*EXP(-U0)+EXPIU0)*GAM GO TO 130 120 CALL CSPEC(II,JJ,IC,C1,CPAR(ICT),U0,T,COL(ICT)) GO TO 150 130 IF(JJ.GT.N1I) GO TO 140 COL(ICT)=CS GO TO 150 140 IF(IT.NE.0) COL(IT)=COL(IT)+CS 150 CONTINUE 200 CONTINUE RETURN END C C C **************************************************************** C C FUNCTION CEH12(T) C ================= C C Special formula for collisional rate in hydrogen Lyman-alpha C transition C After Crandall et al. Ap.J. 191, 789 (1974) C INCLUDE 'IMPLIC.FOR' DIMENSION A(6),B(8) PARAMETER (C=-118353.41) DATA A/ 2.579997D-10, -1.629166D-10, 7.713069D-11, * -2.668768D-11, 6.642513D-12, -9.422885D-13/ SAVE A c DO I=1,8 B(I)=0. END DO X=LOG10(T)-4. DO I=1,6 J=7-I B(J)=2.*X*B(J+1)-B(J+2)+A(J) END DO CEH12=2.4*SQRT(T)*(B(1)-B(3))*EXP(C/T) RETURN END C C C **************************************************************** C C SUBROUTINE CSPEC(I,J,IC,OS,CP,U0,T,CS) C ====================================== C C Non-standard evaluation of collision rates C Basically user-supplied procedure; here is an example C C Van Regemorter's formula following the recommendations of C Mihalas (1978, Stellar Atmospheres, 2nd edition) C IC=-1 for neutrals C IC=-2 for ions C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' DIMENSION CHE1FB(3,4) DATA CHE1FB/ 9.63675,-2.22941,-17.30103, * 10.85578,-2.40931,-27.00903, * 8.38043,-2.04791,-7.36621, * 6.95825,-2.01967,-5.98779/ PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193, * EXPIA3=-0.24991055,EXPIA4=0.05519968, * EXPIA5=-0.00976004,EXPIA6=0.00107857, * EXPIB1=0.2677734343,EXPIB2=8.6347608925, * EXPIB3=18.059016973,EXPIB4=8.5733287401, * EXPIC1=3.9584969228,EXPIC2=21.0996530827, * EXPIC3=25.6329561486,EXPIC4=9.5733223454) CS=0. IF(IC.GT.-10) THEN IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF CCCCCC Neutrals (See Auer & Mihalas 1973) IF(IC.EQ.-1) THEN IF(U0.LE.14.) THEN GG=0.276*EXP(U0)*EXPIU0 ELSE GG=0.066*(1.+1.5/U0)/SQRT(U0) ENDIF CCCCCC Ions (See Mihalas 1972) ELSE IF(IC.EQ.-2) THEN GG0=0.276*EXP(U0)*EXPIU0 GG=CP IF(GG0.GT.CP) GG=GG0 END IF T32=T**(-1.5) CS=CS+19.7363*T32*EXP(-U0)/U0*GG*OS RETURN END IF C IF(IC.EQ.-11) THEN XR=-1.68D0 CS=CS+2.16*U0**XR/T/SQRT(T)*EXP(-U0)*OS C C Forbidden transitions between n=2 He I sublevels C (from Klaus Werner) C ELSE IF(IC.EQ.-12) THEN N0I=NFIRST(IELHE1) I=I-N0I+1 J=J-N0I+1 IFORB=0 IF(I.EQ.2 .AND. J.EQ.3) IFORB=1 IF(I.EQ.2 .AND. J.EQ.5) IFORB=2 IF(I.EQ.3 .AND. J.EQ.4) IFORB=3 IF(I.EQ.4 .AND. J.EQ.5) IFORB=4 IF(IFORB.EQ.0) CALL QUIT(' Inconsistent ICOL - CSPEC',iforb,0) XT=LOG10(T) GAM=CHE1FB(1,IFORB)+CHE1FB(2,IFORB)*XT+CHE1FB(3,IFORB)/XT/XT GAM=EXP(2.30258509299405*GAM) CS=CS+5.465D-11*SQRT(T)*EXP(-U0)*GAM END IF RETURN END C C C **************************************************************** C C SUBROUTINE COLLHE(TEMP,COLHE1) C ============================== C C GENERATES COLLISIONAL RATE COEFFICIENTS AMONG THE 19 STATES OF C HELIUM WITH N = 1, 2, 3, AND 4, USING RATES EVALUATED FROM THE C CROSS SECTIONS CALCULATED BY BERRINGTON AND KINGSTON (J. PHYS.B. 20, C 6631(1987)). COLLISIONAL RATE COEFFICIENTS HAVE BEEN EVALUATED C NUMERICALLY BY P.J.STOREY FROM THE UNPUBLISHED COMPUTER OUTPUT C FILES OF BERRINGTON AND KINGSTON. C C THE STATES INCLUDED IN THE CALCULATION ARE LABELLED SEQUENTIALLY C IN ORDER OF INCREASING ENERGY: C 1 1 SING S C 2 2 TRIP S C 3 2 SING S C 4 2 TRIP P C 5 2 SING P C 6 3 TRIP S C 7 3 SING S C 8 3 TRIP P C 9 3 TRIP D C 10 3 SING D C 11 3 SING P C 12 4 TRIP S C 13 4 SING S C 14 4 TRIP P C 15 4 TRIP D C 16 4 SING D C 17 4 TRIP F C 18 4 SING F C 19 4 SING P C C THIS ORDERING DIFFERS SLIGHTLY FROM THAT OF BERRINGTON AND KINGSTON, C IN WHICH 15 AND 16, AND 17 AND 18, WERE INTERCHANGED. C C THE INTRINSIC ACCURACY OF TRANSITIONS AMONG STATES WITH N = 1, 2, C AND 3 IS EXPECTED TO BE CONSIDERABLY BETTER THAN THOSE WITH N = 4 C AS DISCUSSED BY BERRINGTON AND KINGSTON. THE FITTING ACCURACY IS C EVERYWHERE BETTER THAN 2%. THE ENERGIES OF THE LEVELS ARE TAKEN C FROM W. C. MARTIN, PHYS. CHEM. REF. DATA., VOL.2, 257 (1973) AND C ARE GIVEN IN ELECTRON VOLTS. (BOLTZMANN'S CONSTANT = 8.62E-5) C C FIRST REVISED VERSION: D.G.HUMMER, MAY 1988, JILA C slightly modified by I.H., July 1988 C INCLUDE 'IMPLIC.FOR' PARAMETER (UN=1.D0, * C1=3.849485D0, * C2=8.49485002D-1, * N=19) DIMENSION ENER(19),COLHE1(19,19), * NSTART(172),A(929),B(10),STWT(19) C DATA ENER/ 0.0D0,19.8198D0,20.6160D0,20.96432D0,21.2182D0, .22.7187D0,22.9206D0,23.00731D0,23.0739D0,23.0743D0,23.0873D0, .23.5942D0,23.6738D0,23.7081D0,23.7363D0,23.7366D0,23.7373D0, .23.7373D0,23.7423D0/ C DATA STWT/1.0D0,3.0D0,1.0D0,9.0D0,3.0D0,3.0D0,1.0D0,9.0D0, .1.5D1,5.0D0,3.0D0,3.0D0,1.0D0,9.0D0,1.5D1,5.0D0,2.1D1, .7.0D0,3.0D0/ C DATA NSTART/ . 1, 6, 11, 16, 20, 28, 32, 40, 44, 52, 57, 62, 67, 72, 77, 82, . 88, 92, 98,104,110,114,120,125,129,135,139,147,151,157,164,170, .177,183,190,195,202,208,213,220,225,232,236,243,247,251,260,266, .273,278,285,290,300,304,309,316,320,324,329,333,338,343,347,352, .357,362,367,372,376,382,386,391,395,401,405,410,414,421,425,431, .435,440,445,449,454,459,465,470,475,480,487,491,497,503,508,515, .520,525,530,536,542,547,552,559,564,571,576,581,587,592,598,603, .608,613,617,623,630,635,642,646,650,655,660,666,671,677,683,689, .695,702,707,713,718,723,728,732,737,741,745,750,754,759,765,771, .777,782,789,796,801,805,810,815,819,824,831,837,844,850,856,861, .868,873,877,882,890,895,905,909,913,920,925,930/ C DATA (A(I),I=1,95)/ . 1.7339D-07, 2.7997D-08,-1.3812D-08, 2.6639D-09, 1.7776D-09, . 2.9820D-07, 7.5210D-08,-3.5975D-09, 3.2270D-09, 1.5245D-09, . 1.5601D-05, 1.5340D-06,-2.2122D-06,-1.1073D-07, 1.9249D-07, . 2.3682D-08, 1.0638D-08, 2.0959D-09, 2.8381D-10, 3.0497D-05, . 1.9252D-05, 6.3109D-06, 6.9098D-07,-2.8039D-07,-2.1128D-07, .-1.2192D-07,-4.4417D-08, 1.3896D-06, 1.5715D-07,-8.4358D-08, .-2.8800D-08, 5.9599D-08, 3.4756D-08, 1.2183D-08, 3.7999D-09, . 8.5500D-10,-3.9428D-10,-5.3999D-10,-2.2962D-10, 2.2510D-06, . 6.1436D-07,-1.2437D-07,-7.1718D-08, 5.9026D-05, 3.8150D-05, . 1.1426D-05, 9.2886D-07,-6.4827D-07,-4.4270D-07,-1.8611D-07, .-5.6403D-08, 5.8752D-06, 2.5167D-06, 2.0787D-07,-2.3353D-07, .-8.9900D-08, 5.6334D-08, 2.9313D-09, 1.7775D-09, 5.5494D-10, .-5.8914D-10, 8.1939D-06, 2.4014D-07, 3.8681D-07, 2.8446D-07, .-6.1936D-08, 1.8173D-06,-4.7530D-07,-6.6432D-08, 5.4898D-08, .-1.2377D-08, 2.0732D-05, 6.5991D-07, 1.5840D-06, 4.9920D-07, .-1.8332D-07, 3.2273D-06,-4.9880D-07,-2.4929D-07, 1.1964D-07, .-2.1996D-08, 9.7096D-08, 1.3557D-08, 7.4404D-09, 1.3858D-09, .-1.3778D-09,-8.4885D-10, 3.5068D-06,-5.0675D-07,-1.2252D-07, . 6.0514D-08, 7.0524D-06, 1.4454D-06, 8.3966D-07, 2.7203D-07/ DATA (A(I),I=96,190)/ .-2.3854D-08,-8.6693D-08, 7.1193D-06, 8.3111D-09,-9.3916D-07, .-2.7944D-08, 1.7803D-07,-3.9216D-08, 9.2760D-06, 2.4761D-06, . 1.0095D-06, 3.4039D-07,-8.6900D-08,-1.1156D-07, 2.5036D-05, .-5.7791D-06,-1.8197D-06, 1.0630D-06, 9.8746D-09, 3.1048D-09, . 1.2172D-09, 1.8411D-10,-1.5835D-10,-1.4443D-10, 1.9240D-06, . 1.5012D-07, 7.9741D-08, 2.9323D-08,-1.2796D-08, 5.0457D-07, .-5.5146D-08,-2.7506D-08, 1.4341D-09, 1.3321D-05, 2.6960D-06, . 2.8059D-07, 1.7548D-08,-2.3623D-07,-1.4619D-07, 1.5294D-06, .-9.4925D-08,-1.1347D-07, 8.1980D-09, 1.3324D-04, 7.8068D-05, . 2.9238D-05, 4.2718D-06,-1.6556D-06,-1.4529D-06,-8.6046D-07, .-2.1062D-07, 2.8510D-06,-4.7936D-07,-2.4042D-07, 6.2333D-08, . 1.3493D-09, 3.5113D-10,-4.7269D-11, 2.4872D-11,-9.7136D-12, .-1.4217D-11, 1.5680D-06, 8.9272D-07, 2.8313D-07, 5.2456D-08, .-2.3404D-08,-2.7304D-08,-8.4539D-09, 1.7967D-07, 6.2133D-08, .-3.2814D-09,-3.7299D-09,-1.9587D-09,-1.6685D-09, 1.2707D-05, . 7.5029D-06, 2.8330D-06, 6.7478D-07,-1.5012D-07,-2.3916D-07, .-8.9594D-08, 7.6160D-07, 2.0422D-07,-2.5881D-08,-1.7624D-08, .-8.3518D-09,-4.1743D-09, 4.6044D-05, 2.2425D-05, 3.3079D-06, . 3.6752D-07,-8.4476D-08,-4.8455D-07,-2.5391D-07, 7.0824D-07/ DATA (A(I),I=191,285)/ . 1.4917D-07,-1.2005D-07,-1.6983D-08, 1.1545D-08, 7.2866D-04, . 3.8907D-04, 9.6365D-05, 2.3153D-05, 1.8462D-07,-9.0627D-06, .-5.4332D-06, 1.0458D-08, 1.6430D-09, 5.6453D-10, 2.0276D-10, .-1.6501D-10,-1.0656D-10, 5.2198D-07, 4.2898D-08,-1.0332D-08, .-5.6754D-09,-7.1960D-09, 3.0390D-06, 1.5385D-06, 6.2110D-07, . 1.4111D-07,-3.7415D-08,-4.8395D-08,-1.7219D-08, 2.7227D-06, . 1.4381D-07,-5.5030D-08,-2.2192D-10,-2.8583D-08, 1.8417D-05, . 9.3860D-06, 3.9999D-06, 1.0424D-06,-2.1337D-07,-3.3271D-07, .-1.2684D-07, 4.6063D-06,-6.7185D-07,-2.5830D-07, 2.9976D-08, . 7.8012D-05, 3.4921D-05, 8.3012D-06, 1.5643D-06,-4.3892D-07, .-9.5318D-07,-4.6534D-07, 1.7584D-05,-2.8817D-06,-1.0081D-06, . 1.3259D-07, 1.8561D-05, 2.6602D-06,-1.7243D-06,-3.5533D-07, . 2.3315D-08, 1.6239D-08, 7.3739D-09, 1.9570D-09,-2.5667D-10, .-5.8101D-10,-2.3947D-10, 4.5821D-12, 4.5024D-11, 3.8796D-07, . 1.1239D-07,-2.9033D-08,-5.7237D-09, 2.4186D-09,-2.9670D-09, . 1.0887D-06, 4.3737D-07, 8.3753D-08, 3.6771D-08, 1.6545D-09, .-1.3849D-08,-5.8855D-09, 2.1028D-06, 4.3725D-07,-1.7621D-07, .-3.0743D-08, 1.7119D-08, 8.4698D-06, 4.5395D-06, 1.5774D-06, . 4.1647D-07,-7.9865D-08,-1.6003D-07,-6.0171D-08, 3.1692D-06/ DATA (A(I),I=286,380)/ . 3.6965D-07,-4.9333D-07,-2.8856D-08, 4.2819D-08, 2.0492D-04, . 1.3705D-04, 4.0972D-05, 2.9565D-06,-1.4061D-06,-1.8775D-06, .-1.6306D-06,-3.6380D-07, 3.1213D-07, 2.0912D-07, 1.1965D-05, . 9.9088D-07,-1.3565D-06,-2.3128D-07, 1.1379D-05, 2.6632D-06, .-1.6877D-06,-4.0541D-07, 9.8921D-08, 5.9262D-03, 3.2332D-03, . 9.2954D-04, 1.6597D-04,-3.7972D-05,-7.1646D-05,-4.0073D-05, . 2.5789D-08, 5.2124D-09,-2.2517D-10,-7.9400D-10, 3.3181D-06, . 1.9117D-07, 1.0299D-07,-7.7443D-08, 2.2953D-06,-1.0879D-06, . 3.4368D-07,-1.1230D-07, 1.6826D-08, 6.9774D-06, 9.2721D-07, .-1.8983D-08,-1.6068D-07, 1.5843D-06,-3.5616D-08,-1.1262D-07, .-4.3051D-08, 8.8140D-09, 3.4244D-05, 8.0163D-06, 2.9703D-06, .-1.6480D-07,-6.3282D-07, 2.3791D-06,-4.9305D-07,-1.7122D-07, . 1.2147D-07, 7.2131D-05, 1.7699D-05, 8.4281D-06,-9.3966D-07, .-6.8048D-07, 5.3785D-05, 6.9745D-06,-2.3554D-06,-7.2141D-07, . 3.8501D-07, 4.4794D-06,-6.2435D-07,-2.7340D-07, 2.3127D-08, . 4.2314D-08, 3.3784D-06,-5.1356D-07,-2.4321D-07,-6.2698D-09, . 3.0812D-08, 5.6419D-08, 1.6889D-08, 2.7037D-09,-1.7433D-09, .-9.4507D-10, 1.9714D-06, 4.2743D-08,-7.4114D-08,-2.9304D-08, . 2.8973D-06, 1.0079D-06, 2.9561D-07,-6.2977D-09,-4.5782D-08/ DATA (A(I),I=381,475)/ .-2.4331D-08, 4.3284D-06, 2.8398D-07,-3.2705D-07,-1.5079D-07, . 5.2686D-06, 1.6539D-06, 3.6079D-07,-1.1589D-07,-5.4904D-08, . 7.0939D-06,-1.9534D-06, 3.2391D-08, 5.5702D-08, 3.9072D-05, . 1.7299D-05, 5.1530D-06,-6.0911D-07,-1.2652D-06,-4.6507D-07, . 1.1506D-05,-2.0422D-06,-6.1195D-07, 5.8641D-08, 1.0150D-05, .-4.6977D-07,-6.9446D-07, 2.2516D-08, 1.1109D-07, 3.6715D-05, . 5.6186D-06,-3.2309D-06,-1.6403D-06, 4.1051D-05, 2.3335D-05, . 7.8106D-06, 2.0279D-07,-8.1139D-07,-3.7619D-07,-1.4982D-07, . 2.5621D-05,-1.0798D-05, 1.4607D-06, 3.2421D-07, 6.5478D-09, . 2.7233D-09, 3.8646D-10,-1.9143D-10,-1.0483D-10,-4.8664D-11, . 1.0698D-06, 2.7752D-07,-2.6636D-08,-3.7583D-08, 2.6989D-07, . 3.0325D-08,-2.4613D-08,-1.0828D-08, 2.2522D-09, 8.0777D-06, . 2.2558D-06, 7.4760D-08,-2.4140D-07,-5.4292D-08, 8.8362D-07, . 9.5045D-08,-5.0543D-08,-1.9134D-08, 1.1284D-05, 4.0659D-06, . 7.6246D-07,-9.0394D-08,-8.7408D-08, 1.2192D-06,-2.0362D-07, .-1.0700D-07, 2.1990D-08, 1.2519D-08, 5.2758D-05, 2.0175D-05, . 3.6690D-06,-4.9014D-07,-7.0474D-07,-3.9931D-07, 4.7638D-05, . 1.5546D-05, 6.2294D-07,-1.3428D-06,-1.8177D-07, 4.1203D-06, .-4.9340D-07,-3.0198D-07,-1.5902D-08, 2.8567D-08, 2.2397D-06/ DATA (A(I),I=476,570)/ .-2.1306D-08,-1.7897D-07, 2.8178D-08, 4.1722D-08, 2.0594D-04, . 1.2838D-04, 5.8219D-05, 1.1735D-05,-6.9778D-06,-6.2486D-06, .-1.3800D-06, 2.9170D-06,-7.0833D-07,-1.2673D-07, 4.5069D-08, . 1.0974D-09, 4.7908D-10, 3.0294D-11,-7.0815D-11,-1.2039D-11, . 5.6357D-12, 8.1274D-07, 4.5158D-07, 1.1655D-07,-2.1481D-08, .-2.2493D-08,-6.5884D-09, 9.8696D-08, 3.6499D-08, 1.4768D-09, .-8.0141D-09,-2.8147D-09, 5.8287D-06, 3.2469D-06, 9.4927D-07, .-7.2550D-08,-1.4231D-07,-5.8408D-08,-1.4468D-08, 4.6070D-07, . 1.5956D-07,-3.2311D-09,-3.3487D-08,-7.9013D-09, 4.0092D-06, . 1.2195D-06, 1.1192D-07,-1.3870D-07,-6.2194D-08, 5.4918D-07, .-5.1133D-08,-5.4844D-08,-3.1054D-09, 6.1049D-09, 2.4833D-05, . 1.1280D-05, 2.2680D-06,-4.4637D-07,-2.8942D-07,-1.2382D-07, . 6.8223D-05, 3.6505D-05, 7.8792D-06,-1.7946D-06,-1.4925D-06, .-4.6018D-07, 2.5677D-06,-7.2440D-08,-2.2441D-07,-4.1769D-08, . 2.3833D-08, 1.1885D-06, 4.0457D-09,-1.2273D-07,-2.3271D-08, . 1.5149D-08, 9.1912D-05, 5.6621D-05, 1.4338D-05,-2.6072D-06, .-2.3688D-06,-6.2490D-07,-1.4386D-07, 1.0821D-06,-1.6304D-07, .-7.9756D-08,-4.9881D-09, 9.9527D-09, 1.5288D-03, 9.8517D-04, . 3.4966D-04, 3.4238D-05,-4.3610D-05,-3.2734D-05,-8.3676D-06/ DATA (A(I),I=571,665)/ . 9.6630D-09, 3.2976D-09, 2.1545D-10,-3.3938D-10,-1.4397D-10, . 3.4140D-07, 7.6536D-08,-2.2485D-08,-1.8244D-08,-2.0611D-09, . 1.3128D-06, 6.4165D-07, 1.4728D-07,-2.7600D-08,-3.0125D-08, .-1.0320D-08, 1.6295D-06, 3.3697D-07,-5.7547D-08,-7.3134D-08, .-1.5301D-08, 8.0375D-06, 4.0695D-06, 1.1441D-06,-5.8423D-08, .-1.6488D-07,-7.5920D-08, 2.1173D-06,-1.9184D-07,-2.4986D-07, . 7.2656D-09, 2.7560D-08, 7.9040D-06, 3.3963D-06, 4.8082D-07, .-3.1619D-07,-1.6501D-07, 5.8017D-06,-5.5173D-07,-6.3613D-07, . 1.9633D-08, 7.8681D-08, 9.4568D-06, 9.8227D-08,-7.8983D-07, .-2.0343D-07, 7.0351D-05, 3.6017D-05, 8.0504D-06,-1.7276D-06, .-1.5329D-06,-4.7799D-07, 3.5263D-05, 1.8639D-05, 4.2070D-06, .-4.2643D-07,-5.2726D-07,-2.5481D-07,-1.0144D-07, 4.4613D-06, .-8.7802D-07,-3.9633D-07, 6.7953D-08, 4.1539D-08, 1.8780D-04, . 1.0547D-04, 2.0983D-05,-3.7076D-06,-3.7090D-06,-1.5934D-06, .-2.6146D-07, 1.6384D-05,-3.3765D-06,-7.8390D-07, 1.2382D-07, . 1.5748D-05,-9.4352D-07,-4.8936D-07,-4.9967D-07, 3.8177D-10, . 9.6781D-11,-1.9622D-11,-1.7859D-11,-4.4781D-12, 3.0310D-07, . 1.1193D-07,-5.4059D-09,-1.4249D-08,-1.9549D-09, 4.7664D-08, . 8.5684D-09,-5.0948D-09,-3.1313D-09, 4.9557D-10, 4.2702D-10/ DATA (A(I),I=666,760)/ . 2.3433D-06, 8.3824D-07, 2.6585D-08,-7.5944D-08,-1.5093D-08, . 1.8775D-07, 2.7614D-08,-2.1193D-08,-1.0264D-08, 1.9660D-09, . 1.1637D-09, 7.7890D-06, 3.2901D-06,-2.9753D-07,-5.3153D-07, .-5.2098D-08, 3.3947D-08, 5.5937D-07, 5.1363D-08,-8.5390D-08, .-2.2580D-08, 1.0857D-08, 3.5157D-09, 4.1303D-05, 2.1947D-05, . 3.9480D-06,-1.4234D-06,-9.0220D-07,-2.4485D-07, 1.1031D-04, . 6.6726D-05, 1.9581D-05,-4.3637D-07,-2.8911D-06,-1.4332D-06, .-3.2332D-07, 3.0922D-06, 2.0624D-07,-4.0771D-07,-1.0402D-07, . 4.8807D-08, 1.2491D-06, 2.1187D-07,-1.5951D-07,-7.2537D-08, . 1.4035D-08, 9.6514D-09, 2.5146D-05,-9.4490D-08,-3.4103D-06, . 2.4020D-07, 2.9564D-07, 6.6566D-07,-3.0772D-08,-1.0055D-07, .-3.1082D-09, 1.4897D-08, 7.7189D-04, 3.3710D-04, 3.9258D-05, .-1.5271D-05,-6.0652D-06, 2.1986D-04,-3.3135D-05,-8.5682D-06, .-9.2988D-07, 3.8085D-06,-1.3259D-07,-3.8517D-07,-5.7276D-08, . 3.7226D-08, 2.0825D-09, 1.6707D-10,-1.2443D-10,-3.9117D-11, . 1.0068D-07, 6.2278D-09,-5.9169D-09,-3.9535D-09, 5.3334D-07, . 2.2022D-07, 1.4522D-08,-2.8440D-08,-8.1406D-09, 6.0187D-07, . 5.8318D-08,-2.7772D-08,-2.6639D-08, 3.0929D-06, 1.0648D-06, . 1.2317D-07,-9.9233D-08,-4.0796D-08, 1.5217D-06, 8.3095D-08/ DATA (A(I),I=761,855)/ .-1.9819D-07,-6.0417D-08, 2.9553D-08, 9.0905D-09, 8.6651D-06, . 3.9125D-06,-2.2871D-07,-6.4651D-07,-7.4440D-08, 4.3543D-08, . 4.4505D-06, 2.7350D-07,-4.6428D-07,-2.2293D-07, 5.5275D-08, . 3.6505D-08, 8.3471D-06, 5.0215D-07,-1.1189D-06,-2.5404D-07, . 1.3175D-07, 1.1687D-04, 7.0674D-05, 2.0219D-05,-1.2136D-06, .-3.2299D-06,-1.3981D-06,-2.8271D-07, 3.7298D-05, 2.2054D-05, . 5.5510D-06,-9.1515D-07,-1.0832D-06,-3.6657D-07,-4.8581D-08, . 2.2506D-06,-2.9469D-07,-2.1641D-07,-3.9630D-08, 5.2879D-08, . 2.7894D-05,-3.9312D-06,-2.6413D-06, 5.5848D-07, 8.7829D-06, .-1.4800D-06,-7.0982D-07,-2.1645D-08, 1.3258D-07, 1.2248D-05, .-1.4244D-06,-7.6696D-07,-1.5029D-07, 6.8467D-08, 1.9392D-04, .-2.6676D-05,-8.0536D-06,-6.3609D-07, 2.3074D-05, 7.2856D-07, .-2.3751D-06,-5.8464D-07, 1.3685D-07, 1.9646D-08, 1.2918D-08, . 4.6924D-09, 5.1593D-10,-4.4715D-10,-3.4091D-10,-9.7254D-11, . 3.4117D-07, 1.2731D-07,-2.2300D-08,-2.5297D-08,-1.1877D-10, . 2.3436D-09, 9.4463D-07, 4.9464D-07, 8.9138D-08,-2.2158D-08, .-1.2008D-08,-4.3715D-09,-2.8719D-09, 1.4091D-06, 4.8184D-07, .-9.6135D-08,-1.0945D-07,-9.3174D-09, 9.0166D-09, 4.3747D-06, . 2.1053D-06, 1.7702D-07,-3.0956D-07,-1.2902D-07,-8.9418D-09/ DATA (A(I),I=856,929)/ . 1.4297D-06, 7.7612D-08,-1.7188D-07, 6.4348D-10, 1.1572D-08, . 7.4828D-06, 4.0177D-06, 1.0890D-06, 8.6393D-08,-5.4701D-08, .-5.7656D-08,-3.3030D-08, 5.0379D-06, 1.2861D-07,-7.1313D-07, .-3.3703D-09, 7.9367D-08, 6.2235D-06, 9.8196D-07,-4.6416D-07, .-2.3278D-07, 2.9519D-05, 1.5275D-05, 3.1448D-06,-6.4571D-07, .-3.4445D-07, 3.6508D-05, 2.0524D-05, 3.1203D-06,-2.3606D-06, .-1.5012D-06,-2.5807D-07, 1.3807D-07, 9.9656D-08, 3.1628D-06, .-5.6361D-08,-3.8861D-07,-1.0385D-09, 2.9930D-08, 3.1351D-04, . 2.3774D-04, 1.0342D-04, 1.2429D-05,-1.4107D-05,-9.2597D-06, .-1.7338D-06, 8.4903D-07, 7.3795D-07, 2.2065D-07, 1.2134D-05, . 4.6651D-07,-9.3659D-07,-2.7485D-07, 1.2462D-05, 6.2559D-07, .-6.1634D-07,-5.1080D-07, 1.2493D-02, 8.2057D-03, 2.9562D-03, . 3.3090D-04,-3.7349D-04,-2.8886D-04,-7.4606D-05, 1.2726D-05, .-1.6480D-07,-1.5006D-06,-1.1181D-07, 1.4846D-07, 8.7160D-03, . 4.2652D-03, 5.2455D-04,-2.6363D-04,-7.9836D-05/ SAVE ENER,NSTART,A,STWT C C SET ALL ELEMENTS OF COLHE1 = 0 C DO I=1,N DO J=1,N COLHE1(I,J)=0. END DO END DO C C EVALUATE GAMMAS FOR REQUESTED LEVELS C XXX=2.D0*(LOG10(TEMP)-C1)/C2 TFAC=UN/SQRT(TEMP) C C LOOPS OVER LEVELS C DO IL=1,N-1 DO IU=IL+1,N J=((IU*IU-3*IU+4)/2)+IL-1 N1=NSTART(J) NF=NSTART(J+1)-1 NT=NF-N1+1 NTM2=NT-2 C C CLENSHAW SUMMATION C B(NT)=A(NF) B(NT-1)=XXX*B(NT)+A(NF-1) IR=NTM2 JJ=NF-2 DO J=1,NTM2 B(IR)=XXX*B(IR+1)-B(IR+2)+A(JJ) IR=IR-1 JJ=JJ-1 END DO COLHE1(IU,IL)=(B(1)-B(3))*TFAC X=(ENER(IL)-ENER(IU))/8.62D-5/TEMP COLHE1(IL,IU)=COLHE1(IU,IL)*STWT(IU)/STWT(IL)*EXP(X) END DO END DO RETURN END C C C **************************************************************** C C FUNCTION CHEAV(II,JJ,IC) C ======================== C C Calculates collisional excitation rates of neutral helium C between states with n= 1, 2, 3, 4; with either the upper state C alone, or both upper and lower states are some averaged states C The program allows only two standard possibilities of C constructing averaged levels: C i) all states within given principal quantum number n (>1) are C lumped together C ii) all siglet states for given n, and all triplet states for C given n are lumped together separately (there are thus two C explicit levels for a given n) C C The rates are calculated using appropriate summations and/or C averages of the Storey-Hummer rates (calculated by procedure C COLLHE and stored in array COLHE1) C C Input parameters: C II,JJ - indices of the lower and the upper level (in the C numbering of the explicit levels) C IC - collisional switch ICOL for the given transition C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' C CHEAV=0. NI=NQUANT(II) NJ=NQUANT(JJ) IGI=INT(G(II)+0.01) IGJ=INT(G(JJ)+0.01) C C ---------------------------------------------------------------- C IC=2 - transition from an (l,s) lower level to an averaged upper C level C ---------------------------------------------------------------- C IF(IC.EQ.2) THEN I=II-NFIRST(IELHE1)+1 CHEAV=CHEAVJ(I,NJ,IGJ) END IF C C ---------------------------------------------------------------- C IC=3 - transition from an averaged lower level to an averaged C upper level C ---------------------------------------------------------------- C IF(IC.EQ.3) THEN IF(NI.EQ.2) THEN C C ******** transitions from an averaged level with n=2 C IF(IGI.EQ.4) THEN C C a) lower level is an averaged singlet state C CHEAV=(CHEAVJ(3,NJ,IGJ)+3.D0*CHEAVJ(5,NJ,IGJ))/4.D0 ELSE IF(IGI.EQ.12) THEN C C b) lower level is an averaged triplet state C CHEAV=(CHEAVJ(2,NJ,IGJ)+3.D0*CHEAVJ(4,NJ,IGJ))/4.D0 ELSE IF(IGI.EQ.16) THEN C C c) lower level is an average of both singlet and triplet states C CHEAV=(CHEAVJ(3,NJ,IGJ)+3.D0*(CHEAVJ(5,NJ,IGJ)+ * CHEAVJ(2,NJ,IGJ))+9.D0*CHEAVJ(4,NJ,IGJ))/1.6D1 ELSE GO TO 10 END IF C C C ******** transitions from an averaged level with n=3 C ELSE IF(NI.EQ.3) THEN IF(IGI.EQ.9) THEN C C a) lower level is an averaged singlet state C CHEAV=(CHEAVJ(7,NJ,IGJ)+3.D0*CHEAVJ(11,NJ,IGJ)+ * 5.D0*CHEAVJ(10,NJ,IGJ))/9.D0 ELSE IF(IGI.EQ.27) THEN C C b) lower level is an averaged triplet state C CHEAV=(CHEAVJ(6,NJ,IGJ)+3.D0*CHEAVJ(8,NJ,IGJ)+ * 5.D0*CHEAVJ(9,NJ,IGJ))/9.D0 ELSE IF(IGI.EQ.36) THEN C C c) lower level is an average of both singlet and triplet states C CHEAV=(CHEAVJ(7,NJ,IGJ)+3.D0*CHEAVJ(11,NJ,IGJ)+ * 5.D0*CHEAVJ(10,NJ,IGJ)+ * 3.D0*CHEAVJ(6,NJ,IGJ)+9.D0*CHEAVJ(8,NJ,IGJ)+ * 1.5D1*CHEAVJ(9,NJ,IGJ))/3.6D1 ELSE GO TO 10 END IF C C ******** transitions from an averaged level with n=4 C ELSE IF(NI.EQ.4) THEN IF(IGI.EQ.16) THEN C C a) lower level is an averaged singlet state C CHEAV=(CHEAVJ(13,NJ,IGJ)+ * 3.D0*CHEAVJ(19,NJ,IGJ)+ * 5.D0*CHEAVJ(16,NJ,IGJ)+ * 7.D0*CHEAVJ(18,NJ,IGJ))/1.6D1 ELSE IF(IGI.EQ.48) THEN C C b) lower level is an averaged triplet state C CHEAV=(CHEAVJ(12,NJ,IGJ)+ * 3.D0*CHEAVJ(14,NJ,IGJ)+ * 5.D0*CHEAVJ(15,NJ,IGJ)+ * 7.D0*CHEAVJ(17,NJ,IGJ))/1.6D1 ELSE IF(IGI.EQ.64) THEN C C c) lower level is an average of both singlet and triplet states C CHEAV=(CHEAVJ(13,NJ,IGJ)+ * 3.D0*CHEAVJ(19,NJ,IGJ)+ * 5.D0*CHEAVJ(16,NJ,IGJ)+ * 7.D0*CHEAVJ(18,NJ,IGJ)+ * 3.D0*CHEAVJ(12,NJ,IGJ)+ * 9.D0*CHEAVJ(14,NJ,IGJ)+ * 15.D0*CHEAVJ(15,NJ,IGJ)+ * 21.D0*CHEAVJ(17,NJ,IGJ))/6.4D1 ELSE GO TO 10 END IF ELSE GO TO 10 END IF END IF RETURN 10 WRITE(6,601) NI,NJ,IGI,IGJ write(10,601) NI,NJ,IGI,IGJ 601 FORMAT(1H0/' INCONSISTENT INPUT TO PROCEDURE CHEAV'/ * ' QUANTUM NUMBERS =',2I3,' STATISTICAL WEIGHTS',2I4) call quit(' ',ni,nj) END C C C **************************************************************** C C FUNCTION CHEAVJ(I,NJ,IGJ) C ========================= C C Calculates collisional excitation rates from a non-averaged (l,s) C state of He I, with n=1, 2, 3, to some averaged state C with n = 2, 3, 4. C C The rates are calculated using appropriate summations of the C Storey-Hummer rates (calculated by procedure COLLHE, and stored C in array COLHE1) C C Input: C I - index of the lower state, using the ordering defined in C COLLHE, ie. I=1 for 1 sing S, I=2 for 2 trip S, etc. C NJ - principal quantum number of the (averaged) upper level C IGJ - statistical weight of the upper level C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' CHEAVJ=0. C C ----------------------------------------------------- C ******** transitions to an averaged level with n=2 C ----------------------------------------------------- C IF(NJ.EQ.2) THEN IF(IGJ.EQ.4) THEN C C a) upper level is an averaged singlet state C CHEAVJ=COLHE1(1,3)+COLHE1(1,5) ELSE IF(IGJ.EQ.12) THEN C C b) upper level is an averaged triplet state C CHEAVJ=COLHE1(1,2)+COLHE1(1,4) ELSE IF(IGJ.EQ.16) THEN C C c) upper level is an average of both siglet and triplet states C CHEAVJ=COLHE1(1,3)+COLHE1(1,5)+COLHE1(1,2)+COLHE1(1,4) ELSE GO TO 10 END IF C C ----------------------------------------------------- C ******** transitions to an averaged level with n=3 C ----------------------------------------------------- C ELSE IF(NJ.EQ.3) THEN IF(IGJ.EQ.9) THEN C C a) upper level is an averaged singlet state C CHEAVJ=COLHE1(I,7)+COLHE1(I,11)+COLHE1(I,10) ELSE IF(IGJ.EQ.27) THEN C C b) upper level is an averaged triplet state C CHEAVJ=COLHE1(I,6)+COLHE1(I,8)+COLHE1(I,9) ELSE IF(IGJ.EQ.36) THEN C C c) upper level is an average of both siglet and triplet states C CHEAVJ=COLHE1(I,7)+COLHE1(I,11)+COLHE1(I,10)+ * COLHE1(I,6)+COLHE1(I,8)+COLHE1(I,9) ELSE GO TO 10 END IF C C ----------------------------------------------------- C ******** transitions to an averaged level with n=4 C ----------------------------------------------------- C ELSE IF(NJ.EQ.4) THEN IF(IGJ.EQ.16) THEN C C a) upper level is an averaged singlet state C CHEAVJ=COLHE1(I,13)+COLHE1(I,19)+COLHE1(I,16)+ * COLHE1(I,18) ELSE IF(IGJ.EQ.48) THEN C C b) upper level is an averaged triplet state C CHEAVJ=COLHE1(I,12)+COLHE1(I,14)+COLHE1(I,15)+ * COLHE1(I,17) ELSE IF(IGJ.EQ.64) THEN C C c) upper level is an average of both siglet and triplet states C CHEAVJ=COLHE1(I,13)+COLHE1(I,19)+COLHE1(I,16)+ * COLHE1(I,18)+COLHE1(I,12)+COLHE1(I,14)+ * COLHE1(I,15)+COLHE1(I,17) ELSE GO TO 10 END IF ELSE GO TO 10 END IF RETURN 10 WRITE(6,601) NJ,IGJ WRITE(10,601) NJ,IGJ 601 FORMAT(1H0/' INCONSISTENT INPUT TO PROCEDURE CHEAVJ'/ * ' QUANTUM NUMBER =',I3,' STATISTICAL WEIGHT',2I4) call quit(' ',nj,igj) END C C C **************************************************************** C C 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' DIMENSION A(NR,NR) C DO I=2,N IM1=I-1 DO J=1,IM1 JM1=J-1 DIV=A(J,J) SUM=0. IF(JM1.GE.1) THEN DO K=1,JM1 SUM=SUM+A(I,K)*A(K,J) END DO END IF A(I,J)=(A(I,J)-SUM)/DIV END DO DO J=I,N SUM=0. DO K=1,IM1 SUM=SUM+A(I,K)*A(K,J) END DO A(I,J)=A(I,J)-SUM END DO END DO C DO II=2,N I=N+2-II IM1=I-1 IF(IM1.GE.1) THEN DO JJ=1,IM1 J=I-JJ JP1=J+1 SUM=0. IF(JP1.LE.IM1) THEN DO K=JP1,IM1 SUM=SUM+A(I,K)*A(K,J) END DO END IF A(I,J)=-A(I,J)-SUM END DO END IF END DO C DO II=1,N I=N+1-II DIV=A(I,I) IP1=I+1 IF(IP1.LE.N) THEN DO JJ=IP1,N J=N+IP1-JJ SUM=0. DO K=IP1,J SUM=SUM+A(I,K)*A(K,J) END DO A(I,J)=-SUM/DIV END DO END IF A(I,I)=1.0D0/A(I,I) END DO C DO I=1,N DO 230 J=1,N K0=I IF(J.GE.I) GO TO 220 SUM=0. 200 DO K=K0,N SUM=SUM+A(I,K)*A(K,J) END DO 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 END DO RETURN END C C C **************************************************************** C C SUBROUTINE MINV3(A) C =================== C C Special routine for an invresion of a 3 x 3 matrix C INCLUDE 'IMPLIC.FOR' PARAMETER (UN=1.D0) DIMENSION A(3,3) C A(2,1)=A(2,1)/A(1,1) A(2,2)=A(2,2)-A(2,1)*A(1,2) A(2,3)=A(2,3)-A(2,1)*A(1,3) A(3,1)=A(3,1)/A(1,1) A(3,2)=(A(3,2)-A(3,1)*A(1,2))/A(2,2) A(3,3)=A(3,3)-A(3,1)*A(1,3)-A(3,2)*A(2,3) C A(3,2)=-A(3,2) A(3,1)=-A(3,1)-A(3,2)*A(2,1) A(2,1)=-A(2,1) C A(3,3)=UN/A(3,3) A(2,3)=-A(2,3)*A(3,3)/A(2,2) A(2,2)=UN/A(2,2) A(1,3)=-(A(1,2)*A(2,3)+A(1,3)*A(3,3))/A(1,1) A(1,2)=-A(1,2)*A(2,2)/A(1,1) A(1,1)=UN/A(1,1) C A(1,1)=A(1,1)+A(1,2)*A(2,1)+A(1,3)*A(3,1) A(1,2)=A(1,2)+A(1,3)*A(3,2) A(2,1)=A(2,2)*A(2,1)+A(2,3)*A(3,1) A(2,2)=A(2,2)+A(2,3)*A(3,2) A(3,1)=A(3,3)*A(3,1) A(3,2)=A(3,3)*A(3,2) C RETURN END C C C ****************************************************************** C C 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' DIMENSION A(NR,NR),B(NR),X(NR),D(MLEVEL),IP(MLEVEL) c if(n.eq.2) then a11=a(1,1) a12=a(1,2) a21=a(2,1) a22=a(2,2) x(1)=(a(2,2)*b(1)-a(1,2)*b(2))/ * (a(1,1)*a(2,2)-a(1,2)*a(2,1)) x(2)=(b(2)-a(2,1)*x(1))/a(2,2) return end if c DO I=1,N DO J=1,N D(J)=A(J,I) END DO IM1=I-1 IF(IM1.GE.1) THEN DO J=1,IM1 IT=IP(J) A(J,I)=D(IT) D(IT)=D(J) JP1=J+1 DO K=JP1,N D(K)=D(K)-A(K,J)*A(J,I) END DO END DO END IF AM=ABS(D(I)) IP(I)=I DO K=I,N IF(AM.LT.ABS(D(K))) THEN IP(I)=K AM=ABS(D(K)) END IF END DO IT=IP(I) A(I,I)=D(IT) D(IT)=D(I) IP1=I+1 IF(IP1.GT.N) GO TO 10 DO K=IP1,N A(K,I)=D(K)/A(I,I) END DO END DO C 10 CONTINUE DO I=1,N IT=IP(I) X(I)=B(IT) B(IT)=B(I) IP1=I+1 IF(IP1.GT.N) GO TO 20 DO J=IP1,N B(J)=B(J)-A(J,I)*X(I) END DO END DO C 20 CONTINUE DO I=1,N K=N-I+1 SUM=0. KP1=K+1 IF(KP1.LE.N) THEN DO J=KP1,N SUM=SUM+A(K,J)*X(J) END DO END IF X(K)=(X(K)-SUM)/A(K,K) END DO RETURN END C C C **************************************************************** C C FUNCTION EXPINT(X) C ================== C C First exponential integral function E1(X) C INCLUDE 'IMPLIC.FOR' PARAMETER (A1 = -0.57721566, * A2 = 0.99999193, * A3 = -0.24991055, * A4 = 0.05519968, * A5 = -0.00976004, * A6 = 0.00107857, * B1 = 0.2677734343, * B2 = 8.6347608925, * B3 = 18.059016973, * B4 = 8.5733287401, * C1 = 3.9584969228, * C2 = 21.0996530827, * C3 = 25.6329561486, * C4 = 9.5733223454, * UN = 1.0) C IF(X.LE.UN) THEN EXPINT=-LOG(X)+A1+X*(A2+X*(A3+X*(A4+X*(A5+X*A6)))) ELSE EXPINT=EXP(-X)*((B1+X*(B2+X*(B3+X*(B4+X))))/ * (C1+X*(C2+X*(C3+X*(C4+X)))))/X END IF RETURN END C C C **************************************************************** C C 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' DIMENSION X(MDEPTH),Y(MDEPTH),XX(MDEPTH),YY(MDEPTH) C C no interpolation for NPOL.LE.0 or NX.le.0 C IF(NPOL.LE.0.OR.NX.LE.0) THEN N=NX IF(NXX.GE.NX) N=NXX DO I=1,N XX(I)=X(I) YY(I)=Y(I) END DO RETURN END IF C C interpolation C C if required, compute logarithms to be interpolated C IF(ILOGX.GT.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.GT.0) THEN DO I=1,NX Y(I)=LOG10(Y(I)) END DO END IF C 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 10 END DO I=NUP 10 J=I-NM JJ=J+NPOL-1 YYY=0. DO K=J,JJ T=1. DO 20 M=J,JJ IF(K.EQ.M) GO TO 20 T=T*(XXX-X(M))/(X(K)-X(M)) 20 CONTINUE YYY=Y(K)*T+YYY END DO YY(ID)=YYY END DO C IF(ILOGX.GT.0) THEN DO I=1,NX X(I)=EXP(X(I)*2.30258509299405) END DO DO I=1,NXX XX(I)=EXP(XX(I)*2.30258509299405) END DO END IF IF(ILOGY.GT.0) THEN DO I=1,NX Y(I)=EXP(Y(I)*2.30258509299405) END DO DO I=1,NXX YY(I)=EXP(YY(I)*2.30258509299405) END DO END IF C RETURN END C C C **************************************************************** C C SUBROUTINE OUTPUT C ================= C C Output of computed model atmosphere on file 7 C This file may be used as input file 8 (initial model atmosphere) C for a subsequent run of the program C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C NUMLT=3 IF(IDISK.EQ.1) NUMLT=4 IF(IFMOL.EQ.1) NUMLT=NUMLT+1 NUMPAR=NLEVEL+NUMLT IF(LTE.AND.IPRINP.EQ.0) NUMPAR=NUMLT IF(IFMOL.GT.0) NUMPAR=-NUMPAR C C NUMPAR - number of model parameters in each depth C = NUMLT for LTE model, ie. TEMP - temperature C ELEC - electron density C DENS - density C = NUMLT+NLEVEL for NLTE model, ie. the above + populations C --------------------------------------------------------------------- C 2. DM(ID),ID=1,ND - mass-depth points for the input model C --------------------------------------------------------------------- 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 REWIND 7 WRITE(7,501) ND,NUMPAR WRITE(7,502) (DM(ID),ID=1,ND) IF(IDISK.EQ.0) THEN DO ID=1,ND IF(LTE.AND.IPRINP.EQ.0) THEN IF(IFMOL.EQ.0) THEN WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID) ELSE WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID) END IF ELSE IF(IFMOL.EQ.0) THEN WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID), * (POPUL(J,ID),J=1,NLEVEL) ELSE WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID), * (POPUL(J,ID),J=1,NLEVEL) END IF END IF END DO ELSE DO ID=1,ND IF(LTE.AND.IPRINP.EQ.0) THEN IF(IFMOL.EQ.0) THEN WRITE(7,503) TEMP(ID),ELEC(ID), * DENS(ID),ZD(ID) ELSE WRITE(7,503) TEMP(ID),ELEC(ID), * DENS(ID),TOTN(ID),ZD(ID) END IF ELSE IF(IFMOL.EQ.0) THEN WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID), * (POPUL(J,ID),J=1,NLEVEL) ELSE WRITE(7,503) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID),ZD(ID), * (POPUL(J,ID),J=1,NLEVEL) END IF END IF END DO END IF CLOSE(7) IF(IPRIND.GT.0) THEN WRITE(17,501) ND,NUMPAR WRITE(17,502) (DM(I),I=1,ND) IF(IDISK.EQ.0) THEN IF(LTE) THEN DO ID=1,ND WRITE(17,503) TEMP(ID),ELEC(ID),DENS(ID) END DO ELSE WRITE(20,501) ND,NUMPAR WRITE(20,502) (DM(ID),ID=1,ND) DO ID=1,ND WRITE(17,503) TEMP(ID),ELEC(ID),DENS(ID), * (POPUL(J,ID),J=1,NLEVEL) WRITE(20,503) TEMP(ID),ELEC(ID),DENS(ID), * (BFAC(J,ID),J=1,NLEVEL) END DO END IF ELSE IF(LTE) THEN DO ID=1,ND WRITE(17,503) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID) END DO ELSE WRITE(20,501) ND,NUMPAR WRITE(20,502) (DM(ID),ID=1,ND) DO ID=1,ND WRITE(17,503) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID), * (POPUL(J,ID),J=1,NLEVEL) WRITE(20,503) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID), * (BFAC(J,ID),J=1,NLEVEL) END DO END IF END IF END IF 501 FORMAT(2I5) 502 FORMAT(1P6E13.6) 503 FORMAT(1P5E15.6) RETURN END C C C **************************************************************** C C SUBROUTINE OUTPRI C ================= C C Output on unit 6 (printer) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) dimension aes(mlevel,mlevel),bes(mlevel),poplte(mlevel), * bfab(mlevel,mdepth) C C ************ Print emergent radiation field on unit 13, namely C C FREQ(IJ) - value of frequency C FLUX(IJ) - emergent flux, precisely the second moment H(freq) C at the surface, in ergs/cm**2/s/sterad/Hz C FH(IJ) - Eddington factor f(H), ie the ratio H/J, J is the C mean intensity of radiation C WRITE(6,600) ITER-1 FLTT=SIG4P*TEFF**4 TOTF=0. DO IJ=1,NFREQ IJP=IJ IF(ispodf.eq.0) IJP=JIK(IJ) IF(IJX(IJP).NE.-1) THEN WRITE(13,602) FREQ(IJP),FLUX(IJP),FH(IJP) TOTF=TOTF+FLUX(IJP)*W(IJP) FLAM=FLUX(IJP)*FREQ(IJP)*FREQ(IJP)/2.997925E18 write(14,614) 2.997925e18/freq(ijp),flam END IF END DO WRITE(6,603) TOTF C C ************ For partial opacity table, print electron C densities - actual, and that from opacity table C if(ioptab.ne.0) call eldenc C C ************ Print basic model parameters, namely C C ID - depth index C DM(ID) - mass-depth variable (in g/cm**2) C TEMP(ID) - temperature (in K) C ELEC(ID) - electron density (cm**-3) C AN - total particle number density (cm**-3) C DENS(ID) - mass density (g/cm**3) C P - total gas pressure (cgs) C GR - radiative acceleration (cgs) C FLTOT(ID)- total (integrated over frequencies) radiative flux C if(idisk.eq.0) then WRITE(6,611) else WRITE(6,613) end if DO IJ=1,NFREQE IJT=IJFR(IJ) CALL OPACF1(IJT) DO ID=1,ND ABSOEX(IJ,ID)=ABSO1(ID) END DO END DO DO ID=1,ND C C contributions from explicit (linearized) frequencies to the C flux and radiation pressure C GRP=0. FLEX=0. IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE RAD0(IJ)=RADEX(IJ,ID) FK0(IJ)=FAKEX(IJ,ID) ABSO0(IJ)=ABSOEX(IJ,ID) IJT=IJFR(IJ) WD0C=W(IJT) IF(ID.EQ.1) THEN FLUXW=FH(IJT)*RAD0(IJ)-HEXTRD(IJT) IF(.NOT.LSKIP(ID,IJT)) GRP=GRP+W(ijt)*FLUXW*ABSO0(IJ) FLEX=FLEX+WD0C*FLUXW ELSE RADM(IJ)=RADEX(IJ,ID-1) FKM(IJ)=FAKEX(IJ,ID-1) ABSOM(IJ)=ABSOEX(IJ,ID-1) FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) IF(.NOT.LSKIP(ID,IJFR(IJ))) GRP=GRP+W(ijt)*FRD DTAUM=(ABSO0(IJ)*DENS1(ID)+ABSOM(IJ)*DENS1(ID-1))* * DELDM(ID-1) FLEX=FLEX+WD0C*FRD/DTAUM END IF END DO END IF GRAD(ID)=GRP+FPRD(ID) if(ifryb.gt.0) GRAD(ID)=GRD(ID) IF(ID.EQ.1) THEN GRAD(ID)=GRAD(ID)/DENS(ID) ELSE GRAD(ID)=GRAD(ID)/(DM(ID)-DM(ID-1)) END IF FLTOT(ID)=FLEX C C other quantities C AN=DENS(ID)/WMM(ID)+ELEC(ID) P=AN*TEMP(ID)*BOLK IF(ID.LT.ND.AND.GRAD(ID).GT.0.) * GR=LOG10(GRAD(ID)*4.1916825D-10) FLTO=FLTOT(ID)+FLFIX(ID)+flxc(id) flto=flrd(id)+flxc(id) ptotal(id)=pgs(id)+pradt(id) if(idisk.eq.0) then WRITE(6,612) ID,DM(ID),TROSS(ID),TEMP(ID),ELEC(ID),DENS(ID), * P,GR, * flrd(id)/fltt,flxc(id)/fltt,flto/fltt else IF(ID.EQ.1) THEN GRV=QGRAV*ZD(ID) pgint=pgs(1)/dens(1)*dm(1) ptint=ptotal(1)/dens(1)*dm(1) ELSE GRV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF pgint=pgint+(dm(id)-dm(id-1))*(pgs(id)/dens(id)+ * pgs(id-1)/dens(id-1))*half ptint=ptint+(dm(id)-dm(id-1))*(ptotal(id)/dens(id)+ * ptotal(id-1)/dens(id-1))*half END IF GRVL=0. IF(GRV.GT.0.) GRVL=LOG10(GRV) HMECH=SIG4P*TEFF**4*(UN-THETAV(ID)) WRITE(6,622) ID,DM(ID),TROSS(ID),TEMP(ID),ELEC(ID), * dens(id),pgs(id), * flxc(id)/FLTO,FLTO,HMECH,hmech/flto,ZD(ID),GRVL,GR 622 format(i4,1p2e10.2,0pf10.1,1p10e10.2) wbar=wbarm/dm(nd) if(p.gt.0.) alpg=omeg32*wbar*dens(id)*viscd(id)/p pto=ptotal(id) if(pto.gt.0.) alpt=omeg32*wbar*dens(id)*viscd(id)/pto disip=viscd(id)*dens(id)*edisc write(98,698) id,dm(id),zd(id),abrosd(id),temp(id),pgint, * ptotal(id),p,dens(id),disip,alpg,alpt if(id.eq.nd) write(98,698) id,edisc,viscd(id),dens(id),p, * omeg32,wbar 698 format(i3,1p11d11.4) end if END DO C if(idisk.eq.1) then if(pgint.gt.0.) alpgav=omeg32*wbar/pgint*dm(nd) if(ptint.gt.0.) alptav=omeg32*wbar/ptint*dm(nd) write(6,606) omeg32,wbar,alpgav,alptav 606 format(// * ' omega*3/2 ',1pe10.2/ * ' wbar ',1pe10.2/ * ' equivalent alpha for Pg ',1pe10.2/ * ' equivalent alpha for Ptot',1pe10.2) end if C IF(.NOT.LTE) THEN C C ************ Print b-factors on unit 12 and C "absolute" b-factors on unit 22 c the traditional b-factors are already computed (BFAC), c here we compute the absolute ones c LTE=.TRUE. DO ID=1,ND CALL WNSTOR(ID) CALL SABOLF(ID) CALL RATMAL(ID,AES,BES) CALL LEVSOL(AES,BES,POPLTE,IIFOR,NLEVEL,0) DO I=1,NLEVEL BFAB(I,ID)=1. IF(POPLTE(I).GT.0.) BFAB(I,ID)=POPUL(I,ID)/POPLTE(I) END DO END DO LTE=.FALSE. idlte=idlt0 C NUMP=NLEVEL+3 IF(IFMOL.GT.0) NUMP=NLEVEL+4 IF(IDISK.EQ.0) THEN NUMPAR=NUMP IF(IFMOL.GT.0) NUMPAR=-NUMPAR WRITE(12,701) ND,NUMPAR WRITE(12,702) (DM(ID),ID=1,ND) WRITE(22,701) ND,NUMPAR WRITE(22,704) (DM(ID),ID=1,ND) DO ID=1,ND IF(IFMOL.EQ.0) THEN WRITE(12,703) TEMP(ID),ELEC(ID),DENS(ID), * (BFAC(J,ID),J=1,NLEVEL) WRITE(22,703) TEMP(ID),ELEC(ID),DENS(ID), * (BFAB(J,ID),J=1,NLEVEL) ELSE WRITE(12,703) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID), * (BFAC(J,ID),J=1,NLEVEL) WRITE(22,703) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID), * (BFAB(J,ID),J=1,NLEVEL) END IF END DO ELSE NUMPAR=NUMP+1 IF(IFMOL.GT.0) NUMPAR=-NUMPAR WRITE(12,701) ND,NUMPAR WRITE(12,702) (DM(ID),ID=1,ND) WRITE(22,701) ND,NUMPAR WRITE(22,704) (DM(ID),ID=1,ND) DO ID=1,ND IF(IFMOL.EQ.0) THEN WRITE(12,703) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID), * (BFAC(J,ID),J=1,NLEVEL) WRITE(22,703) TEMP(ID),ELEC(ID),DENS(ID),ZD(ID), * (BFAB(J,ID),J=1,NLEVEL) ELSE WRITE(12,703) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID), * ZD(ID),(BFAC(J,ID),J=1,NLEVEL) WRITE(22,703) TEMP(ID),ELEC(ID),DENS(ID),TOTN(ID), * ZD(ID),(BFAB(J,ID),J=1,NLEVEL) END IF END DO END IF END IF C 600 FORMAT(/' ************************************'/ * ' FINAL RESULTS:'/' '/ * ' MODEL QUANTITIES IN',I3,'. ITERATION'/ * ' ************************************'/) c 601 FORMAT(' IJ',8X,'FREQ',11X,'LAMBDA',8X,'FLUX',9X, c * 'FH',4X,'LOG(FNU)',3X,'LOG(FLAM)'/) 602 FORMAT(1PE15.8,1PE12.4,0PF7.3) 603 FORMAT(' TOTAL SURFACE FLUX',1PD15.8) 611 FORMAT(/' ----------------------'/ * ' FINAL MODEL ATMOSPHERE'/ * ' ----------------------'/ * ' ID MASS',6X,'TAUROSS',5X,'TEMP',7X,'NE',9X,'DENS', * 6X,'P_gas',4X,'LOG(G_rad)',3x,'RAD/TOT',3x,'CON/TOT', * 2x,'(RAD+CON)/TOT'/) 612 FORMAT(1H ,I3,1P2E11.3,0PF10.1,1P6E11.3,3E13.5) 613 FORMAT(/' ---------------------'/ * ' FINAL DISK RING MODEL'/ * ' ---------------------'/ *' ID MASS',4X,'TAUROSS',5X,'TEMP',7X,'NE',7X,'RHO', * 7X,'PGAS'5X,'CON/TOT RAD.FLX DISSIP',2X, * 'FLX/DISSIP',4X,'Z',7X, * 'LOG G',2X,'LOG G(RAD)'/) 614 FORMAT(F15.3,1pe15.3) 701 FORMAT(2I5) 702 FORMAT(1P8E10.3) 703 FORMAT(1P5E15.6) 704 FORMAT(1P6E13.6) RETURN END C C C **************************************************************** C C C SUBROUTINE SOLVE C ================ C C Driving procedure for complete linearization C Solution of the system C C A * del(PSI{ID-1}) + B * del(PSI{ID}) + C * del(PSI{ID+1}) = VECL C C where PSI{ID} means vector PSI at depth ID, C del(PSI{ID}) linearization corrections to PSI; C Vector PSI is a vector composed of all unknown model parameters, C the choice and order of which is given by input parameters INHE, C INRE,INPC,INSE, and INMP (see START). C A,B,C are the so-called matrices of complete linearization C and VECL is the corressponding rhs vector, pertinent to depth ID. C C The above block tridiagonal system is solved by the standard C Gaussian elimination, ie. C C del(PSI{ID}) = BET{ID} - ALF{ID} * del{PSI{ID+1}), C C (the so-called back-solution), C where the auxiliary matrix ALF and vector BET, at each depth, C are given by (the so-called forward elimination) C C ALF{ID} = (B - A * ALF{ID-1})**-1 * C , C and C BET{ID} = (B - A * ALF{ID-1})**-1 * (VECL - A * BET{ID-1}) C C Programming notes: C Although matrices A,B,C have size (NN x NN), only matrix B is C represented as array (MTOT x MTOT), MTOT being the maximum value C of NN; other matrices have large parts void, so that C A - is represented as array (MAROWS x MTOT), the maximum number of C rows of A is MFREX+2 (because only the transfer equations, the C hydrostatic equilibrium, and optionally radiative equilibrium C equations couple the depth point ID and ID-1) C C - is represented as array (MFREX x MCCOLS), ie. C the maximum number of rows is MFREX (only the transfer C equations couple the depth point ID and ID+1); C and since the upper square block (NFREQE x NFREQE), corresponding C to the radiative transfer equations, is diagonal, all the C transfer equations may be represemted as one column, thus C reducing the number of columns of C to number of constraint C equations + 1, ie. the maximum number to MCCOLS=MLEVEL+5. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' COMMON/CMATZD/CZZ,CZN,CZE,CZM DIMENSION ALF(MTOT,MTOT),BET(MTOT,MDEPTH),DPSI(MTOT) EQUIVALENCE (DPSI(1),Y2(1)) C REWIND 91 REWIND 92 REWIND 93 N=NN M=NFREQE IF(IFALI.LE.5) THEN M1=NFREQE+2 IF(ICONV.GT.0.OR.NRETC.NE.0) M1=NFREQE+3 ELSE M1=N END IF C C -------------------------------- C First part - forward elimination C -------------------------------- C LMKA=.FALSE. IF(ITER.LT.NITER) LMKA=KANT(ITER+1).EQ.1 LASO=KANT(ITER).EQ.1 DO ID=1,ND C C evaluate matrices A,B,C, and rhs vector VECL, corresponding C to depth ID C CALL WNSTOR(ID) IF(.NOT.LASO) THEN CALL MATGEN(ID) IF(LMKA) WRITE(93) ((A(I,J),I=1,M1),J=1,N) ELSE CALL RHSGEN(ID) READ(93) ((A(I,J),I=1,M1),J=1,N) ENDIF IF(ID.GT.1) THEN C C expression VECL-A*BET C DO I=1,M1 SUM=0. DO J=1,N SUM=SUM+A(I,J)*BET(J,ID-1) eND DO VECL(I)=VECL(I)-SUM END DO C C expression B-A*ALF, stored in array B C IF(.NOT.LASO) THEN DO I=1,M1 DO J=1,N SUM=0. DO K=1,N SUM=SUM+A(I,K)*ALF(K,J) END DO B(I,J)=B(I,J)-SUM END DO END DO END IF END IF C C expression (B-A*ALF)**-1, stored in array B C IF(LASO) THEN READ(92) ((B(I,J),I=1,N),J=1,N) ELSE CALL MATINV(B,N,MTOT) IF(LMKA) WRITE(92) ((B(I,J),I=1,N),J=1,N) END IF C C auxiliary vector BET = (B-A*ALF)**-1 * (L-A*BET) C DO I=1,N SUM=0. DO J=1,N SUM=SUM+B(I,J)*VECL(J) END DO BET(I,ID)=SUM END DO C IF(ID.LT.ND) THEN C C auxiliary matrix ALF = (B-A*ALF)**-1 * C C IF(LASO) THEN IF(ID.LT.(ND-1)) THEN READ(91) ALF(1,1) ELSE READ(91) ((ALF(I,J),I=1,N),J=1,N) ENDIF ELSE DO I=1,N DO J=1,M ALF(I,J)=B(I,J)*C(J,J) END DO END DO DO I=1,N DO J=M+1,N SUM=0. DO K=1,M SUM=SUM+B(I,K)*C(K,J) END DO IF(IFALI.GT.5.OR.ICONV.LE.2) THEN DO K=M+1,N SUM=SUM+B(I,K)*C(K,J) END DO END IF ALF(I,J)=SUM END DO C C taking into account the separate elements of matrix C C BZ=0. IF(INZD.GT.0) BZ=B(I,M+INZD) IF(INZD.GT.0) ALF(I,M+INZD)=ALF(I,M+INZD)+BZ*CZZ IF(INHE.GT.0) ALF(I,M+INHE)=ALF(I,M+INHE)+BZ*CZN IF(INPC.GT.0) ALF(I,M+INPC)=ALF(I,M+INPC)+BZ*CZE IF(INMP.GT.0) ALF(I,M+INMP)=ALF(I,M+INMP)+BZ*CZM END DO C C store the auxiliary matrix ALF C WRITE(91) ((ALF(I,J),I=1,N),J=1,N) END IF END IF END DO C C -------------------------- C Second part - backsolution C -------------------------- C DO I=1,N VECL(I)=0. END DO DO IID=1,ND ID=ND-IID+1 IF(ID.LT.ND) THEN C C read old PSI C DO I=1,N PSI0(I)=PSY0(I,ID) END DO C C read auxiliary matrix ALF and vector BET C BACKSPACE 91 READ(91) ((ALF(I,J),I=1,N),J=1,N) BACKSPACE 91 C C expression ALF * delta(PSI{previous depth}), stored C in array VECL C DO I=1,N SUM=0. DO J=1,N SUM=SUM+ALF(I,J)*DPSI(J) END DO VECL(I)=SUM END DO END IF C C finally, evaluate delta(PSI) and corresponding relative changes C delta(PSI)/PSI C DO I=1,N DPSI(I)=BET(I,ID)-VECL(I) CHAN=0. IF(PSI0(I).GT.0.) CHAN=DPSI(I)/PSI0(I) BET(I,ID)=CHAN C C over-relaxation C IF(I.GE.NFREQE+INSE) CHAN=ORELAX*CHAN C C To avoid instabilities, relative changes of all quantities C are artificially limited not to exceed certain predefined values C IF(CHAN.LE.UN/DPSILG-UN) CHAN=UN/DPSILG-UN IF(CHAN.GE.DPSILG-UN) CHAN=DPSILG-UN IF(INRE.GT.0) THEN DPLP=DPSILT-UN DPLM=UN/DPSILT-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INRE) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INRE) CHAN=DPLP END IF IF(INHE.GT.0) THEN DPLP=DPSILN-UN DPLM=UN/DPSILN-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INHE) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INHE) CHAN=DPLP END IF IF(INPC.GT.0) THEN DPLP=DPSILN-UN DPLM=UN/DPSILN-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INPC) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INPC) CHAN=DPLP END IF IF(INDL.GT.0) THEN DPLP=DPSILD-UN DPLM=UN/DPSILD-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INDL) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INDL) CHAN=DPLP END IF C C new vector PSI C PSI0(I)=PSI0(I)*(CHAN+UN) END DO IF(INRE.GT.0) CHANT(ID)=BET(NFREQE+INRE,ID) C C new vector PSI is stored C DO I=1,N PSY0(I,ID)=PSI0(I) END DO END DO C c call lucy C C print out the relative changes of vector PSI C CALL PRCHAN(BET,CHMX,CHMT) C C STOP if changes become too large C IF(ITER.NE.1 .AND. ABS(CHMX).GT.1.D16) THEN WRITE(6,610) ITER,CHMX WRITE(10,610) ITER,CHMX STOP END IF C Reset iron lines cross-sections if changes are still large if(iter.le.1) LIROST=.FALSE. LITEK=.FALSE. if(iter.eq.7 .or. iter.eq.11 .or. iter.eq.15) LITEK=.TRUE. if(chmt.gt.chmaxt .and. ispodf.ge.1) LIROST=.TRUE. if(LITEK.and.LIROST) then call iroset LIROST=.FALSE. end if C Set up Kantorovich method IF(LASO) THEN WRITE(6,600) ITER WRITE(10,600) ITER END IF c END IF C C Finally, set up quantity LFIN that indicates whether or not C this iteration of complete linearization is the last one C LFIN=ABS(CHMX).LE.CHMAX.OR.ITER.GE.NITER RETURN 600 FORMAT(' **** KANTOROVICH acceleration: ITER',I4) 610 FORMAT(' **** STOP in SOLVE after ITER',I4,/, * ' Max change:',1PE12.2) END C C C **************************************************************** C C SUBROUTINE SOLVES C ================= C C Same routine than SOLVE, but used for small systems of C equations (NN<=MSMX) to keep matrices in memory and to avoid I/O C C Driving procedure for complete linearization C Solution of the system C C A * del(PSI{ID-1}) + B * del(PSI{ID}) + C * del(PSI{ID+1}) = VECL C C where PSI{ID} means vector PSI at depth ID, C del(PSI{ID}) linearization corrections to PSI; C Vector PSI is a vector composed of all unknown model parameters, C the choice and order of which is given by input parameters INHE, C INRE,INPC,INSE, and INMP (see START). C A,B,C are the so-called matrices of complete linearization C and VECL is the corressponding rhs vector, pertinent to depth ID. C C The above block tridiagonal system is solved by the standard C Gaussian elimination, ie. C C del(PSI{ID}) = BET{ID} - ALF{ID} * del{PSI{ID+1}), C C (the so-called back-solution), C where the auxiliary matrix ALF and vector BET, at each depth, C are given by (the so-called forward elimination) C C ALF{ID} = (B - A * ALF{ID-1})**-1 * C , C and C BET{ID} = (B - A * ALF{ID-1})**-1 * (VECL - A * BET{ID-1}) C C Programming notes: C Although matrices A,B,C have size (NN x NN), only matrix B is C represented as array (MTOT x MTOT), MTOT being the maximum value C of NN; other matrices have large parts void, so that C A - is represented as array (MAROWS x MTOT), the maximum number of C rows of A is MFREX+2 (because only the transfer equations, the C hydrostatic equilibrium, and optionally radiative equilibrium C equations couple the depth point ID and ID-1) C C - is represented as array (MFREX x MCCOLS), ie. C the maximum number of rows is MFREX (only the transfer C equations couple the depth point ID and ID+1); C and since the upper square block (NFREQE x NFREQE), corresponding C to the radiative transfer equations, is diagonal, all the C transfer equations may be represemted as one column, thus C reducing the number of columns of C to number of constraint C equations + 1, ie. the maximum number to MCCOLS=MLEVEL+5. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION ALF(MTOT,MTOT),BET(MTOT,MDEPTH),DPSI(MTOT) COMMON/STOMAT/STOA(MSMX,MSMX,MDEPTH),STOB(MSMX,MSMX,MDEPTH), * STOALF(MSMX,MSMX,MDEPTH) COMMON/CMATZD/CZZ,CZN,CZE,CZM EQUIVALENCE (DPSI(1),Y2(1)) C N=NN M=NFREQE IF(IFALI.LE.5) THEN M1=NFREQE+2 IF(ICONV.GT.0.OR.NRETC.NE.0) M1=NFREQE+3 ELSE M1=N END IF C C -------------------------------- C First part - forward elimination C -------------------------------- C LMKA=.FALSE. IF(ITER.LT.NITER) LMKA=KANT(ITER+1).EQ.1 LASO=KANT(ITER).EQ.1 DO ID=1,ND C C evaluate matrices A,B,C, and rhs vector VECL, corresponding C to depth ID C CALL WNSTOR(ID) IF(.NOT.LASO) THEN CALL MATGEN(ID) IF(LMKA) THEN DO J=1,N DO I=1,M1 STOA(I,J,ID)=A(I,J) END DO END DO END IF ELSE CALL RHSGEN(ID) DO J=1,N DO I=1,M1 A(I,J)=STOA(I,J,ID) END DO END DO END IF IF(ID.GT.1) THEN C C expression VECL-A*BET C DO 20 I=1,M1 SUM=0. DO 10 J=1,N SUM=SUM+A(I,J)*BET(J,ID-1) 10 CONTINUE VECL(I)=VECL(I)-SUM 20 CONTINUE C C expression B-A*ALF, stored in array B C IF(.NOT.LASO) THEN DO I=1,M1 DO J=1,N SUM=0. DO K=1,N SUM=SUM+A(I,K)*ALF(K,J) END DO B(I,J)=B(I,J)-SUM END DO END DO END IF END IF C C expression (B-A*ALF)**-1, stored in array B C IF(LASO) THEN DO J=1,N DO I=1,N B(I,J)=STOB(I,J,ID) END DO END DO ELSE CALL MATINV(B,N,MTOT) IF(LMKA) THEN DO J=1,N DO I=1,N STOB(I,J,ID)=B(I,J) END DO END DO END IF END IF C C auxiliary vector BET = (B-A*ALF)**-1 * (L-A*BET) C DO I=1,N SUM=0. DO J=1,N SUM=SUM+B(I,J)*VECL(J) END DO BET(I,ID)=SUM END DO C IF(ID.LT.ND) THEN C C auxiliary matrix ALF = (B-A*ALF)**-1 * C C IF(LASO) THEN DO J=1,N DO I=1,N ALF(I,J)=STOALF(I,J,ID) END DO END DO ELSE DO I=1,N DO J=1,M ALF(I,J)=B(I,J)*C(J,J) END DO END DO DO I=1,N DO J=M+1,N SUM=0. DO K=1,M SUM=SUM+B(I,K)*C(K,J) END DO IF(IFALI.GT.5.OR.ICONV.LE.2) THEN DO K=M+1,N SUM=SUM+B(I,K)*C(K,J) END DO END IF ALF(I,J)=SUM END DO C C taking into account the separate elements of matrix C C BZ=0. IF(INZD.GT.0) BZ=B(I,M+INZD) IF(INZD.GT.0) ALF(I,M+INZD)=ALF(I,M+INZD)+BZ*CZZ IF(INHE.GT.0) ALF(I,M+INHE)=ALF(I,M+INHE)+BZ*CZN IF(INPC.GT.0) ALF(I,M+INPC)=ALF(I,M+INPC)+BZ*CZE IF(INMP.GT.0) ALF(I,M+INMP)=ALF(I,M+INMP)+BZ*CZM END DO C C store the auxiliary matrix ALF C DO J=1,N DO I=1,N STOALF(I,J,ID)=ALF(I,J) END DO END DO END IF END IF END DO C C -------------------------- C Second part - backsolution C -------------------------- C DO I=1,N VECL(I)=0. END DO C DO IID=1,ND ID=ND-IID+1 IF(ID.LT.ND) THEN C C read old PSI C DO I=1,N PSI0(I)=PSY0(I,ID) END DO C C read auxiliary matrix ALF and vector BET C DO J=1,N DO I=1,N ALF(I,J)=STOALF(I,J,ID) END DO END DO C C expression ALF * delta(PSI{previous depth}), stored C in array VECL C DO I=1,N SUM=0. DO J=1,N SUM=SUM+ALF(I,J)*DPSI(J) END DO VECL(I)=SUM END DO END IF C C finally, evaluate delta(PSI) and corresponding relative changes C delta(PSI)/PSI C DO I=1,N DPSI(I)=BET(I,ID)-VECL(I) CHAN=0. IF(PSI0(I).GT.0.) CHAN=DPSI(I)/PSI0(I) BET(I,ID)=CHAN C C over-relaxation C IF(I.GE.NFREQE+INSE) CHAN=ORELAX*CHAN C C To avoid instabilities, relative changes of all quantities C are artificially limited not to exceed certain predefined values C IF(CHAN.LE.UN/DPSILG-UN) CHAN=UN/DPSILG-UN IF(CHAN.GE.DPSILG-UN) CHAN=DPSILG-UN IF(INRE.GT.0) THEN DPLP=DPSILT-UN DPLM=UN/DPSILT-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INRE) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INRE) CHAN=DPLP END IF IF(INHE.GT.0) THEN DPLP=DPSILN-UN DPLM=UN/DPSILN-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INHE) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INHE) CHAN=DPLP END IF IF(INPC.GT.0) THEN DPLP=DPSILN-UN DPLM=UN/DPSILN-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INPC) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INPC) CHAN=DPLP END IF IF(INDL.GT.0) THEN DPLP=DPSILD-UN DPLM=UN/DPSILD-UN IF(CHAN.LE.DPLM.AND.I.EQ.NFREQE+INDL) CHAN=DPLM IF(CHAN.GT.DPLP.AND.I.EQ.NFREQE+INDL) CHAN=DPLP END IF C C new vector PSI C PSI0(I)=PSI0(I)*(CHAN+UN) END DO IF(INRE.GT.0) CHANT(ID)=BET(NFREQE+INRE,ID) C C new vector PSI is stored C DO I=1,N PSY0(I,ID)=PSI0(I) END DO END DO C C print out the relative changes of vector PSI C CALL PRCHAN(BET,CHMX,CHMT) C C STOP if changes become too large C IF(ITER.NE.1 .AND. ABS(CHMX).GT.1.D16) THEN WRITE(6,610) ITER,CHMX WRITE(10,610) ITER,CHMX STOP END IF C Reset iron lines cross-sections if changes are still large if(iter.le.1) LIROST=.FALSE. LITEK=.FALSE. if(iter.eq.7 .or. iter.eq.11 .or. iter.eq.15) LITEK=.TRUE. if(chmt.gt.chmaxt .and. ispodf.ge.1) LIROST=.TRUE. if(LITEK.and.LIROST) then call iroset LIROST=.FALSE. end if C Set up Kantorovich method IF(LASO) THEN WRITE(6,600) ITER WRITE(10,600) ITER END IF C C Finally, set up quantity LFIN that indicates whether or not C this iteration of complete linearization is the last one C LFIN=ABS(CHMX).LE.CHMAX.OR.ITER.GE.NITER C 600 FORMAT(' **** KANTOROVICH acceleration: ITER',I4) 610 FORMAT(' **** STOP in SOLVE after ITER',I4,/, * ' Max change:',1PE12.2) RETURN END C C C **************************************************************** C C SUBROUTINE MATGEN(ID) C ===================== C C Auxiliary procedure for SOLVE C controls evaluation of matrices A,B, and C C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' C C C evaluation of the opacity, emissivity, scattering, and C their derivatives, at the current depth point ID; C DO I=1,NN PSI0(I)=PSY0(I,ID) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) WDEP0(IJ)=W(IJT) RAD0(IJ)=RADEX(IJ,ID) FK0(IJ)=FAKEX(IJ,ID) ABSO0(IJ)=ABSOEX(IJ,ID) EMIS0(IJ)=EMISEX(IJ,ID) SCAT0(IJ)=SCATEX(IJ,ID) DABT0(IJ)=DABTEX(IJ,ID) DEMT0(IJ)=DEMTEX(IJ,ID) DABN0(IJ)=DABNEX(IJ,ID) DEMN0(IJ)=DEMNEX(IJ,ID) DABM0(IJ)=DABMEX(IJ,ID) DEMM0(IJ)=DEMMEX(IJ,ID) DO II=1,NLVEXP DRCH0(II,IJ)=DRCHEX(II,IJ,ID) DRET0(II,IJ)=DRETEX(II,IJ,ID) END DO END DO END IF C IF(ID.GT.1) THEN DO I=1,NN PSIM(I)=PSY0(I,ID-1) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) RADM(IJ)=RADEX(IJ,ID-1) FKM(IJ)=FAKEX(IJ,ID-1) ABSOM(IJ)=ABSOEX(IJ,ID-1) EMISM(IJ)=EMISEX(IJ,ID-1) SCATM(IJ)=SCATEX(IJ,ID-1) DABTM(IJ)=DABTEX(IJ,ID-1) DEMTM(IJ)=DEMTEX(IJ,ID-1) DABNM(IJ)=DABNEX(IJ,ID-1) DEMNM(IJ)=DEMNEX(IJ,ID-1) DABMM(IJ)=DABMEX(IJ,ID-1) DEMMM(IJ)=DEMMEX(IJ,ID-1) DO II=1,NLVEXP DRCHM(II,IJ)=DRCHEX(II,IJ,ID-1) DRETM(II,IJ)=DRETEX(II,IJ,ID-1) END DO END DO END IF END IF C IF(ID.LT.ND) THEN DO I=1,NN PSIP(I)=PSY0(I,ID+1) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) RADP(IJ)=RADEX(IJ,ID+1) FKP(IJ)=FAKEX(IJ,ID+1) ABSOP(IJ)=ABSOEX(IJ,ID+1) EMISP(IJ)=EMISEX(IJ,ID+1) SCATP(IJ)=SCATEX(IJ,ID+1) DABTP(IJ)=DABTEX(IJ,ID+1) DEMTP(IJ)=DEMTEX(IJ,ID+1) DABNP(IJ)=DABNEX(IJ,ID+1) DEMNP(IJ)=DEMNEX(IJ,ID+1) DABMP(IJ)=DABMEX(IJ,ID+1) DEMMP(IJ)=DEMMEX(IJ,ID+1) DO II=1,NLVEXP DRCHP(II,IJ)=DRCHEX(II,IJ,ID+1) DRETP(II,IJ)=DRETEX(II,IJ,ID+1) END DO END DO END IF END IF C C C ------------------------------------------------------------ C Actual evaluation of matrices A,B,C, and the rhs vector VECL C ------------------------------------------------------------ C C First null arrays A,B,C,VECL C DO I=1,NN0 VECL(I)=0. DO J=1,NN0 B(J,I)=0. A(J,I)=0. C(J,I)=0. E(J,I)=0. END DO END DO C C for the sake of clarity, the matrices are evaluated by several C different subroutines C IF(IDISK.EQ.0) THEN CALL BRTE(ID) IF(INHE.NE.0) CALL BHE(ID) IF(INRE.NE.0) CALL BRE(ID) ELSE IF(IZSCAL.EQ.0) THEN CALL BRTE(ID) IF(INHE.NE.0.or.inzd.ne.0) CALL BHED(ID) IF(INRE.NE.0) CALL BRE(ID) ELSE CALL BRTEZ(ID) IF(INHE.NE.0.or.inzd.ne.0) CALL BHEZ(ID) IF(INRE.NE.0) CALL BREZ(ID) END IF END IF C C contribution to matrix elements due to convection C CALL MATCON(ID) C IF(INSE.GT.0) THEN CALL SABOLF(ID) CALL BPOP(ID) CALL EMAT(ID) C C skip rows corresponding to fully-zeroed populations C NSE=NFREQE+INSE INONZ=NSE DO II=NSE,NN0 IF(IGZERT(II-NSE+1).EQ.0) THEN IF(INONZ.NE.II) THEN DO JJ=1,NN0 B(INONZ,JJ)=B(II,JJ) A(INONZ,JJ)=A(II,JJ) C(INONZ,JJ)=C(II,JJ) END DO VECL(INONZ)=VECL(II) END IF INONZ=INONZ+1 END IF END DO C C skip also corresponding columns C INONZ=NSE DO II=NSE,NN0 IF(IGZERT(II-NSE+1).EQ.0) THEN IF(INONZ.NE.II) THEN DO JJ=1,NN B(JJ,INONZ)=B(JJ,II) A(JJ,INONZ)=A(JJ,II) C(JJ,INONZ)=C(JJ,II) END DO END IF INONZ=INONZ+1 END IF END DO END IF C RETURN END C C C **************************************************************** C C SUBROUTINE BRTE(ID) C =================== C C The part of matrices A,B,C corresponding to the linearized C radiative transfer equation C i.e. the first NFREQE rows C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0) C IF(NFREQE.LE.0) RETURN ispl=isplin if(isplin.ge.5) isplin=isplin-5 NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NSE=NFREQE+INSE-1 NMP=NFREQE+INMP C GP=0. GN=UN IF(INMP.GT.0) THEN GP=UN GN=0. END IF c c in the case of Compton scattering - boundary condition c for the highest frequency C IJ1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) then IJ1=2 ij=1 iji=nfreq zj1=exp(-hk*freq(ij)/temp(id)) zj2=exp(-hk*freq(ij+1)/temp(id)) dlt=delj(iji-1,id) if(ichcoo.eq.0) then zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id)) zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2 combid=zj0/dlnfr(iji-1)+(un-dlt)*zxx comaid=-zj0/dlnfr(iji-1)+dlt*zxx else e2=ycon*temp(id) zxx0=xcon*freq(ij)*(un+zj1)-3.*e2 zxxm=xcon*freq(ij+1)*(un+zj2)-3.*e2 zxx=(un-dlt)*zxx0+dlt*zxxm combid=e2/dlnfr(iji-1)+(un-dlt)*zxx comaid=-e2/dlnfr(iji-1)+dlt*zxx end if b(ij,ij)=combid b(ij,ij+1)=comaid vecl(ij)=-b(ij,ij)*rad(iji,id)-b(ij,ij+1)*rad(iji-1,id) end if C C ---------------------------------------- C For ID = 1 - upper boundary condition C ---------------------------------------- C IF(ID.GT.1) GO TO 50 DDP=(DM(2)-DM(1))*HALF DO IJ=IJ1,NFREQE IJT=IJFR(IJ) OMEG0=ABSO0(IJ)/DENS(ID) OMEGP=ABSOP(IJ)/DENS(ID+1) DZP=OMEG0+OMEGP DTAUP=DZP*DDP ALF1=(FK0(IJ)*RAD0(IJ)-FKP(IJ)*RADP(IJ))/DTAUP CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) BS=HALF*DTAUP CS=0. C2=0. GAM2=0. BET2=0. SP=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(MOD(ISPLIN,3).GT.0) THEN C C Spline collocation and/or Hermitian method (ISPLIN=1 or 2) - C both give the same expression for the boundary conditions C BS=DTAUP*THIRD CS=HALF *BS SP=(EMISP(IJ)+CHIELP*RADP(IJ))/ABSOP(IJ) C2=CS/ABSOP(IJ) GAM2=CS*(RADP(IJ)-SP) END IF C C auxiliary quantities C ALF2=BS*(RAD0(IJ)-S0) BET2=ALF2+GAM2 X1=(ALF1-BET2)/DZP B2=(BS+Q0(IJT))/ABSO0(IJ) B1=X1/DENS(1) B1=B1+UU0(IJT)*S0*DM(1)*HALF/DENS(1) C1=X1/DENS(2) C C *** elements of the IJ-th row of matrices B and C C RTN=OMEG0*WMM(1)*B1 B(IJ,NHE)=-GN*RTN B1=B1-B2*S0 C RTNC=OMEGP*WMM(2)*C1 C(IJ,NHE)=-GN*RTNC C1=C1-C2*SP C B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) C(IJ,NRE)=C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ)) B(IJ,NPC)=B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+ * GN*RTN C(IJ,NPC)=C1*DABNP(IJ)+ * C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))+ * GN*RTNC B(IJ,NMP)=B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN C(IJ,NMP)=C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC DO II=1,NLVEXP B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) C(IJ,NSE+II)=C(IJ,NSE+II)+ * C1*DRCHP(II,IJ)+C2*DRETP(II,IJ) END DO B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAUP-FH(IJT)-BS*(UN-CHIEL0/ABSO0(IJ)) * +Q0(IJT)*CHIEL0/ABSO0(IJ) C(IJ,NFREQE)=0. C(IJ,IJ)=FKP(IJ)/DTAUP-CS*(UN-CHIELP/ABSOP(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=ALF1+BET2+FH(IJT)*RAD0(IJ) * -S0*Q0(IJT) IF(IWINBL.LT.0) VECL(IJ)=VECL(IJ)-HEXTRD(IJT) c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO isplin=ispl go to 500 C C --------------------------------------- C For 1 < ID < ND - normal depth point C --------------------------------------- C 50 DDM=(DM(ID)-DM(ID-1))*HALF IF(ID.EQ.ND) GO TO 150 DDP=(DM(ID+1)-DM(ID))*HALF DO IJ=IJ1,NFREQE IJT=IJFR(IJ) OMEG0=ABSO0(IJ)/DENS(ID) OMEGP=ABSOP(IJ)/DENS(ID+1) OMEGM=ABSOM(IJ)/DENS(ID-1) DZP=OMEG0+OMEGP DZM=OMEG0+OMEGM DTAUP=DZP*DDP DTAUM=DZM*DDM DTAU0=HALF *(DTAUP+DTAUM) FRD=FK0(IJ)*RAD0(IJ) ALF1=(FRD-FKP(IJ)*RADP(IJ))/DTAUP/DTAU0 GAM1=(FRD-FKM(IJ)*RADM(IJ))/DTAUM/DTAU0 BET1=ALF1+GAM1 X1=HALF *BET1/DTAU0 A1=(GAM1+X1*DTAUM)/DZM C1=(ALF1+X1*DTAUP)/DZP B1=(A1+C1)/DENS(ID) A1=A1/DENS(ID-1) C1=C1/DENS(ID+1) BS=UN CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) AS=0. CS=0. A2=0. C2=0. A3=0. C3=0. BET2=0. SM=0. SP=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(MOD(ISPLIN,3).EQ.0) GO TO 60 SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ) SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ) IF(ISPLIN.EQ.1) THEN C C spline collocation (ISPLIN=1) C AS=DTAUM/DTAU0*SIXTH CS=DTAUP/DTAU0*SIXTH BS=0.666666666666667D0 ALF2=AS*(RADM(IJ)-SM) GAM2=CS*(RADP(IJ)-SP) BET2=ALF2+GAM2 X =HALF *BET2/DTAU0 A2=(GAM2-X*DTAUM)/DZM C2=(ALF2-X*DTAUP)/DZP ELSE C C Hermitian method (ISPLIN=2) C AS=DTAUP*DTAUP/DTAUM/DTAU0 CS=DTAUM*DTAUM/DTAUP/DTAU0 AL3=(RADP(IJ)-SP-RAD0(IJ)+S0)*SIXTH GA3=(RADM(IJ)-SM-RAD0(IJ)+S0)*SIXTH AV=AL3*CS CV=GA3*AS AS=(UN-HALF *AS)*SIXTH CS=(UN-HALF *CS)*SIXTH BS=UN-AS-CS X=(AV+CV)/DTAU0/4.D0 A2=(X*DTAUM+HALF *CV-AV)/DZM C2=(X*DTAUP+HALF *AV-CV)/DZP BET2=AS*(RADM(IJ)-SM)+CS*(RADP(IJ)-SP) END IF C C auxiliary quantities C B1=B1-(A2+C2)/DENS(ID) A1=A1-A2/DENS(ID-1) C1=C1-C2/DENS(ID+1) A2=AS/ABSOM(IJ) C2=CS/ABSOP(IJ) A3=A2*SM C3=C2*SP 60 B2=BS/ABSO0(IJ) B3=B2*S0 C C *** elements of the IJ-th row of matrices A, B, and C C RTNA=OMEGM*WMM(ID-1)*A1 A(IJ,NHE)=-GN*RTNA A1=A1-A3 C RTN=OMEG0*WMM(ID)*B1 B(IJ,NHE)=-GN*RTN B1=B1-B3 C RTNC=OMEGP*WMM(ID+1)*C1 C(IJ,NHE)=-GN*RTNC C1=C1-C3 C A(IJ,NRE)= A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ)) B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) C(IJ,NRE)= C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ)) A(IJ,NPC)= A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+ * GN*RTNA B(IJ,NPC)= B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+ * GN*RTN C(IJ,NPC)= C1*DABNP(IJ)+ * C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ))+ * GN*RTNC A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN C(IJ,NMP)= C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC DO II=1,NLVEXP A(IJ,NSE+II)=A(IJ,NSE+II)+ * A1*DRCHM(II,IJ)+A2*DRETM(II,IJ) B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) C(IJ,NSE+II)=C(IJ,NSE+II)+ * C1*DRCHP(II,IJ)+C2*DRETP(II,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM/DTAU0-AS*(UN-CHIELM/ABSOM(IJ)) B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAU0*(UN/DTAUP+UN/DTAUM)- * BS*(UN-CHIEL0/ABSO0(IJ)) C(IJ,NFREQE)=0. C(IJ,IJ)=FKP(IJ)/DTAUP/DTAU0-CS*(UN-CHIELP/ABSOP(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=BET1+BET2+BS*(RAD0(IJ)-S0) c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO isplin=ispl go to 500 C C -------------------------------------- C For ID=ND - lower boundary condition C -------------------------------------- C 150 CONTINUE IF(IDISK.EQ.0.OR.IFZ0.LT.0) THEN T=TEMP(ID) TM=TEMP(ID-1) IF(TEMPBD.NE.0.) THEN T=TEMPBD TM=T END IF HKT=HK/T HKTM=HK/TM C C auxiliary quantites C DO IJ=IJ1,NFREQE IJT=IJFR(IJ) CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) OMEGM=ABSOM(IJ)/DENS(ID-1) OMEG0=ABSO0(IJ)/DENS(ID) DZM=OMEG0+OMEGM DTAUM=DZM*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAM1=FRD/DTAUM A1=GAM1/DZM AS=0. BS=0. A2=0. B2=0. A3=0. B3=0. ALF2=0. BET2=0. GAM2=0. C C second-order boundary condition C IF(IBC.GT.0.AND.IBC.LT.4) THEN BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C GAM2=BS*(RAD0(IJ)-S0) BET2=GAM2 X1=BET2/DZM A1=A1-X1 B2=BS/ABSO0(IJ) B3=B2*S0 END IF C C auxiliary parameters C FR=FREQ(IJT) FR15=FR*1.D-15 X=HKT*FR EX=EXP(X) XM=HKTM*FR EXM=EXP(XM) PLAN=BN*FR15*FR15*FR15/(EX-UN)*RRDIL IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN PLANM=BN*FR15*FR15*FR15/(EXM-UN)*RRDIL GAM3=(PLAN-PLANM)/DTAUM*THIRD A1=A1-GAM3/DZM GAM1=GAM1-GAM3 END IF C1=A1 A1=C1/DENS(ID-1) B1=C1/DENS(ID) C C *** elements of the IJ-th row of matrices A and B C RTNA=OMEGM*WMM(ID-1)*A1 A(IJ,NHE)=-GN*RTNA A1=A1-A3 C RTN=OMEG0*WMM(ID)*B1 B(IJ,NHE)=-GN*RTN B1=B1-B3 C DPLANM=PLANM*XM/TM/(UN-UN/EXM) A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))- * DPLANM/DTAUM*THIRD A(IJ,NPC)=A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+ * GN*RTNA BB=HALF+THIRD/DTAUM DPLAN=PLAN*X/T/(UN-UN/EX) B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))+ * BB*DPLAN B(IJ,NPC)= B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+ * GN*RTN A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN DO II=1,NLVEXP A(IJ,NSE+II)=A(IJ,NSE+II)+ * A1*DRCHM(II,IJ)+A2*DRETM(II,IJ) B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ)) B(IJ,NFREQE)=0. C C *** the IJ-th element of the rhs vector C IF(IBC.EQ.0.OR.IBC.EQ.4) THEN B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM- * BS*(UN-CHIEL0/ABSO0(IJ))-HALF VECL(IJ)=GAM1+BET2-HALF*(PLAN-RAD0(IJ)) ELSE B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM- * BS*(UN-CHIEL0/ABSO0(IJ))-FHD(IJT) VECL(IJ)=GAM1+BET2-HALF*PLAN+FHD(IJT)*RAD0(IJ) END IF c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO C ELSE C C -------------------------------------- C For ID=ND - lower boundary condition C -------------------------------------- C C for disks - C lower b.c. expresses just I(taumax,-mu,nu)=I(taumax,+mu,nu) C DO IJ=IJ1,NFREQE IJT=IJFR(IJ) CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) OMEGM=ABSOM(IJ)/DENS(ID-1) OMEG0=ABSO0(IJ)/DENS(ID) DZM=OMEG0+OMEGM DTAUM=DZM*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAM1=FRD/DTAUM A1=GAM1/DZM AS=0. A2=0. A3=0. ALF2=0. GAM2=0. BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C GAM2=BS*(RAD0(IJ)-S0) BET2=ALF2+GAM2 X1=BET2/DZM A1=A1-X1 B2=BS/ABSO0(IJ) B3=B2*S0 C1=A1 A1=C1/DENS(ID-1) B1=C1/DENS(ID) C C *** elements of the IJ-th row of matrix A C RTN=OMEGM*WMM(ID)*A1 A(IJ,NHE)=-GN*RTN A(IJ,NMP)=-GP*RTN A1=A1-A3 A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ)) A(IJ,NPC)=A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ))+ * GN*RTN A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA DO I=1,NLVEXP A(IJ,NSE+I)=A1*DRCHM(I,IJ)+A2*DRETM(I,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ)) C C *** elements of the IJ-th row of matrix B C RTN=OMEG0*WMM(ID)*B1 B(IJ,NHE)=-GN*RTN B(IJ,NMP)=-GP*RTN B1=B1-B3 B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) B(IJ,NPC)=B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ))+ * GN*RTN B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN DO I=1,NLVEXP B(IJ,NSE+I)=B1*DRCH0(I,IJ)+B2*DRET0(I,IJ) END DO B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAUM-BS*(UN-CHIEL0/ABSO0(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=GAM1+BET2 c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO END IF isplin=ispl 500 CONTINUE c c zeroing radiation field for very low intensities (if required) c if(radzer.gt.0) then c C find the peak in nu*rad_nu: c radsum=0. DO IJ=IJ1,NFREQE radsum=max(freq(ij)*radex(ij,id),radsum) END DO C C if much smaller than peak in nu*rad_nu, then set to zero: C DO IJ=IJ1,NFREQE if(freq(ij)*radex(ij,id).lt.radzer*radsum) then do ii=1,nn0 a(ij,ii)=0. b(ij,ii)=0. c(ij,ii)=0. end do vecl(ij)=0. b(ij,ij)=un end if end do end if isplin=ispl isplin=ispl c RETURN END C C C C **************************************************************** C C SUBROUTINE BRTEZ(ID) C ==================== C C The part of matrices A,B,C corresponding to the linearized C radiative transfer equation C i.e. the first NFREQE rows C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0) C IF(NFREQE.LE.0) RETURN ispl=isplin if(isplin.ge.5) isplin=isplin-5 NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NSE=NFREQE+INSE-1 NMP=NFREQE+INMP C GP=0. GN=UN IF(INMP.GT.0) THEN GP=UN GN=0. END IF c c in the case of Compton scattering - boundary condition c for the highest frequency C IJ1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) then IJ1=2 ij=1 iji=nfreq zj1=exp(-hk*freq(ij)/temp(id)) zj2=exp(-hk*freq(ij+1)/temp(id)) dlt=delj(iji-1,id) if(ichcoo.eq.0) then zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id)) zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2 combid=zj0/dlnfr(iji-1)+(un-dlt)*zxx comaid=-zj0/dlnfr(iji-1)+dlt*zxx else e2=ycon*temp(id) zxx0=xcon*freq(ij)*(un+zj1)-3.*e2 zxxm=xcon*freq(ij+1)*(un+zj2)-3.*e2 zxx=(un-dlt)*zxx0+dlt*zxxm combid=e2/dlnfr(iji-1)+(un-dlt)*zxx comaid=-e2/dlnfr(iji-1)+dlt*zxx end if b(ij,ij)=combid b(ij,ij+1)=comaid vecl(ij)=-b(ij,ij)*rad(iji,id)-b(ij,ij+1)*rad(iji-1,id) end if C C C ---------------------------------------- C For ID = 1 - upper boundary condition C ---------------------------------------- C IF(ID.GT.1) GO TO 50 DDP=(ZD(1)-ZD(2))*HALF DO IJ=IJ1,NFREQE IJT=IJFR(IJ) OMEG0=ABSO0(IJ) OMEGP=ABSOP(IJ) DZP=OMEG0+OMEGP DTAUP=DZP*DDP ALF1=(FK0(IJ)*RAD0(IJ)-FKP(IJ)*RADP(IJ))/DTAUP CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) BS=HALF*DTAUP CS=0. C2=0. GAM2=0. BET2=0. SP=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(MOD(ISPLIN,3).GT.0) THEN C C Spline collocation and/or Hermitian method (ISPLIN=1 or 2) - C both give the same expression for the boundary conditions C BS=DTAUP*THIRD CS=HALF *BS SP=(EMISP(IJ)+CHIELP*RADP(IJ))/ABSOP(IJ) C2=CS/ABSOP(IJ) GAM2=CS*(RADP(IJ)-SP) END IF C C auxiliary quantities C ALF2=BS*(RAD0(IJ)-S0) BET2=ALF2+GAM2 X1=(ALF1-BET2)/DZP B2=(BS+Q0(IJ))/ABSO0(IJ) B1=X1 B1=B1+UU0(IJ)*S0*DM(1)/DENS(1) C1=X1 B1=B1-B2*S0 C1=C1-C2*SP C C *** elements of the IJ-th row of matrices B and C C B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) C(IJ,NRE)=C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ)) B(IJ,NPC)=B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ)) C(IJ,NPC)=C1*DABNP(IJ)+ * C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ)) B(IJ,NMP)=B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN C(IJ,NMP)=C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC DO II=1,NLVEXP B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) C(IJ,NSE+II)=C(IJ,NSE+II)+ * C1*DRCHP(II,IJ)+C2*DRETP(II,IJ) END DO B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAUP-FH(IJT)-BS*(UN-CHIEL0/ABSO0(IJ))+ * Q0(IJ)*CHIEL0/ABSO0(IJ) C(IJ,NFREQE)=0. C(IJ,IJ)=FKP(IJ)/DTAUP-CS*(UN-CHIELP/ABSOP(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=ALF1+BET2+FH(IJT)*RAD0(IJ)-S0*Q0(IJ) IF(IWINBL.LT.0) VECL(IJ)=VECL(IJ)-HEXTRD(IJT) c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO isplin=ispl go to 500 C C --------------------------------------- C For 1 < ID < ND - normal depth point C --------------------------------------- C 50 DDM=(ZD(ID-1)-ZD(ID))*HALF IF(ID.EQ.ND) GO TO 150 DDP=(ZD(ID)-ZD(ID+1))*HALF DO IJ=IJ1,NFREQE IJT=IJFR(IJ) OMEG0=ABSO0(IJ) OMEGP=ABSOP(IJ) OMEGM=ABSOM(IJ) DZP=OMEG0+OMEGP DZM=OMEG0+OMEGM DTAUP=DZP*DDP DTAUM=DZM*DDM DTAU0=HALF *(DTAUP+DTAUM) FRD=FK0(IJ)*RAD0(IJ) ALF1=(FRD-FKP(IJ)*RADP(IJ))/DTAUP/DTAU0 GAM1=(FRD-FKM(IJ)*RADM(IJ))/DTAUM/DTAU0 BET1=ALF1+GAM1 X1=HALF *BET1/DTAU0 A1=(GAM1+X1*DTAUM)/DZM C1=(ALF1+X1*DTAUP)/DZP B1=A1+C1 BS=UN CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) AS=0. CS=0. A2=0. C2=0. A3=0. C3=0. BET2=0. SM=0. SP=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(MOD(ISPLIN,3).EQ.0) GO TO 60 SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ) SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ) IF(ISPLIN.EQ.1) THEN C C spline collocation (ISPLIN=1) C AS=DTAUM/DTAU0*SIXTH CS=DTAUP/DTAU0*SIXTH BS=0.666666666666667D0 ALF2=AS*(RADM(IJ)-SM) GAM2=CS*(RADP(IJ)-SP) BET2=ALF2+GAM2 X =HALF *BET2/DTAU0 A2=(GAM2-X*DTAUM)/DZM C2=(ALF2-X*DTAUP)/DZP ELSE C C Hermitian method (ISPLIN=2) C AS=DTAUP*DTAUP/DTAUM/DTAU0 CS=DTAUM*DTAUM/DTAUP/DTAU0 AL3=(RADP(IJ)-SP-RAD0(IJ)+S0)*SIXTH GA3=(RADM(IJ)-SM-RAD0(IJ)+S0)*SIXTH AV=AL3*CS CV=GA3*AS AS=(UN-HALF *AS)*SIXTH CS=(UN-HALF *CS)*SIXTH BS=UN-AS-CS X=(AV+CV)/DTAU0/4.D0 A2=(X*DTAUM+HALF *CV-AV)/DZM C2=(X*DTAUP+HALF *AV-CV)/DZP BET2=AS*(RADM(IJ)-SM)+CS*(RADP(IJ)-SP) END IF C C auxiliary quantities C B1=B1-(A2+C2) A1=A1-A2 C1=C1-C2 A2=AS/ABSOM(IJ) C2=CS/ABSOP(IJ) A3=A2*SM C3=C2*SP 60 B2=BS/ABSO0(IJ) B3=B2*S0 A1=A1-A3 B1=B1-B3 C1=C1-C3 C C *** elements of the IJ-th row of matrices A, B, and C C A(IJ,NRE)= A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ)) B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) C(IJ,NRE)= C1*DABTP(IJ)+C2*(DEMTP(IJ)+DST*RADP(IJ)) A(IJ,NPC)= A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ)) B(IJ,NPC)= B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ)) C(IJ,NPC)= C1*DABNP(IJ)+ * C2*(DEMNP(IJ)+(DSN+SIGEC(IJT))*RADP(IJ)) A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN C(IJ,NMP)= C1*DABMP(IJ)+C2*DEMMP(IJ)-GP*RTNC DO II=1,NLVEXP A(IJ,NSE+II)=A(IJ,NSE+II)+ * A1*DRCHM(II,IJ)+A2*DRETM(II,IJ) B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) C(IJ,NSE+II)=C(IJ,NSE+II)+ * C1*DRCHP(II,IJ)+C2*DRETP(II,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM/DTAU0-AS*(UN-CHIELM/ABSOM(IJ)) B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAU0*(UN/DTAUP+UN/DTAUM)- * BS*(UN-CHIEL0/ABSO0(IJ)) C(IJ,NFREQE)=0. C(IJ,IJ)=FKP(IJ)/DTAUP/DTAU0-CS*(UN-CHIELP/ABSOP(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=BET1+BET2+BS*(RAD0(IJ)-S0) c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO isplin=ispl go to 500 C C -------------------------------------- C For ID=ND - lower boundary condition C -------------------------------------- C 150 CONTINUE IF(IDISK.EQ.0.OR.IFZ0.LT.0) THEN T=TEMP(ID) TM=TEMP(ID-1) HKT=HK/T HKTM=HK/TM C C auxiliary quantites for both options C DO IJ=1,NFREQE IJT=IJFR(IJ) CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) OMEGM=ABSOM(IJ) OMEG0=ABSO0(IJ) DZM=OMEG0+OMEGM DTAUM=DZM*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAM1=FRD/DTAUM A1=GAM1/DZM AS=0. BS=0. A2=0. B2=0. A3=0. B3=0. ALF2=0. BET2=0. GAM2=0. C C second-order boundary condition C IF(IBC.GT.0.AND.IBC.LT.4) THEN BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C GAM2=BS*(RAD0(IJ)-S0) BET2=GAM2 X1=BET2/DZM A1=A1-X1 B2=BS/ABSO0(IJ) B3=B2*S0 END IF C C auxiliary parameters C FR=FREQ(IJT) FR15=FR*1.D-15 X=HKT*FR EX=EXP(X) XM=HKTM*FR EXM=EXP(XM) PLAN=BN*FR15*FR15*FR15/(EX-UN) IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN PLANM=BN*FR15*FR15*FR15/(EXM-UN) GAM3=(PLAN-PLANM)/DTAUM*THIRD A1=A1-GAM3/DZM GAM1=GAM1-GAM3 END IF C1=A1 B1=C1 A1=A1-A3 B1=B1-B3 C C *** elements of the IJ-th row of matrices A and B C IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN DPLANM=PLANM*XM/TM/(UN-UN/EXM) A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ))- * DPLANM/DTAUM*THIRD A(IJ,NPC)=A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ)) BB=HALF+THIRD/DTAUM DPLAN=PLAN*X/T/(UN-UN/EX) B(IJ,NRE)= B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ))+ * BB*DPLAN B(IJ,NPC)= B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ)) A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN DO II=1,NLVEXP A(IJ,NSE+II)=A(IJ,NSE+II)+ * A1*DRCHM(II,IJ)+A2*DRETM(II,IJ) B(IJ,NSE+II)=B(IJ,NSE+II)+ * B1*DRCH0(II,IJ)+B2*DRET0(II,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ)) B(IJ,NFREQE)=0. END IF C C *** the IJ-th element of the rhs vector C IF(IBC.EQ.0.OR.IBC.EQ.4) THEN B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM- * BS*(UN-CHIEL0/ABSO0(IJ))-HALF VECL(IJ)=GAM1+BET2-HALF*(PLAN-RAD0(IJ)) ELSE B(IJ,IJ)=B(IJ,IJ)-FK0(IJ)/DTAUM- * BS*(UN-CHIEL0/ABSO0(IJ))-FHD(IJT) VECL(IJ)=GAM1+BET2-HALF*PLAN+FHD(IJT)*RAD0(IJ) END IF c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO C ELSE C C -------------------------------------- C For ID=ND - lower boundary condition C -------------------------------------- C C for disks - C lower b.c. expresses just I(taumax,-mu,nu)=I(taumax,+mu,nu) C DO IJ=IJ1,NFREQE IJT=IJFR(IJ) CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) OMEGM=ABSOM(IJ) OMEG0=ABSO0(IJ) DZM=OMEG0+OMEGM DTAUM=DZM*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAM1=FRD/DTAUM A1=GAM1/DZM AS=0. A2=0. A3=0. ALF2=0. GAM2=0. BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C GAM2=BS*(RAD0(IJ)-S0) BET2=ALF2+GAM2 X1=BET2/DZM A1=A1-X1 B2=BS/ABSO0(IJ) B3=B2*S0 B1=A1 A1=A1-A3 B1=B1-B3 C C *** elements of the IJ-th row of matrix A C A(IJ,NRE)=A1*DABTM(IJ)+A2*(DEMTM(IJ)+DST*RADM(IJ)) A(IJ,NPC)=A1*DABNM(IJ)+ * A2*(DEMNM(IJ)+(DSN+SIGEC(IJT))*RADM(IJ)) A(IJ,NMP)= A1*DABMM(IJ)+A2*DEMMM(IJ)-GP*RTNA DO I=1,NLVEXP A(IJ,NSE+I)=A1*DRCHM(I,IJ)+A2*DRETM(I,IJ) END DO A(IJ,NFREQE)=0. A(IJ,IJ)=FKM(IJ)/DTAUM-AS*(UN-CHIELM/ABSOM(IJ)) C C *** elements of the IJ-th row of matrix B C B(IJ,NRE)=B1*DABT0(IJ)+B2*(DEMT0(IJ)+DST*RAD0(IJ)) B(IJ,NPC)=B1*DABN0(IJ)+ * B2*(DEMN0(IJ)+(DSN+SIGEC(IJT))*RAD0(IJ)) B(IJ,NMP)= B1*DABM0(IJ)+B2*DEMM0(IJ)-GP*RTN DO I=1,NLVEXP B(IJ,NSE+I)=B1*DRCH0(I,IJ)+B2*DRET0(I,IJ) END DO B(IJ,NFREQE)=0. B(IJ,IJ)=-FK0(IJ)/DTAUM-BS*(UN-CHIEL0/ABSO0(IJ)) C C *** the IJ-th element of the rhs vector C VECL(IJ)=GAM1+BET2 c c additional terms for Compton scattering c if(icompt.gt.4) then iji=nfreq-kij(ijt)+1 b(ij,ij)=b(ij,ij)+bs*(cmb+cme) if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) b(ij,ijm)=b(ij,ijm)+bs*cma end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) b(ij,ijp)=b(ij,ijp)+bs*cmc end if if(inre.gt.0) b(ij,nre)=b(ij,nre)+cmd*bs if(inpc.gt.0) b(ij,npc)=b(ij,npc)+cms*bs/elec(id) end if c END DO END IF isplin=ispl 500 CONTINUE c c zeroing radiation field for very low intensities (if required) c if(radzer.gt.0) then c C find the peak in nu*rad_nu: c radsum=0. DO IJ=IJ1,NFREQE radsum=max(freq(ij)*radex(ij,id),radsum) END DO C C if much smaller than peak in nu*rad_nu, then set to zero: C DO IJ=IJ1,NFREQE if(freq(ij)*radex(ij,id).lt.radzer*radsum) then do ii=1,nn0 a(ij,ii)=0. b(ij,ii)=0. c(ij,ii)=0. end do vecl(ij)=0. b(ij,ij)=un end if end do end if isplin=ispl c RETURN END C C **************************************************************** C C SUBROUTINE BHE(ID) C ================== C C The part of matrices A and B corresponding to the hydrostatic C equilibrium equation, C i.e. the (NFREQE+INHE)-th row; C and, if desired (INMP > 0), the part corresponding to the C definition equation for the fictitious massive particle density, C ie. the (NFREQE+INMP)-th row. C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' C NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NSE=NFREQE+INSE-1 c c the case of fixed mass density c if(ifixde.gt.0) then b(nhe,nhe)=un b(nhe,npc)=-un vecl(nhe)=dens(id)/wmm(id)+elec(id)-totn(id) return end if C C *********** Linearized equation for the fictitious massive particle C density C IF(INMP.GT.0) THEN NMP=NFREQE+INMP B(NMP,NMP)=-UN B(NMP,NHE)=UN IF(INPC.GT.0) B(NMP,NPC)=-UN END IF C C *********** Linearized hydrostatic equilibrium C HEXT=0. HEXN=0. GRD=0. FLUXW=0. IF(ID.GT.1) GO TO 50 C C *** Upper boundary condition (ID=1) C Basically, linearized eq. (7-10) of Mihalas (1978) C DO I=1,NLVEXP HEX(I)=0. END DO x1=0. IF(NFREQE.GT.0.AND.IFPRAD.GT.0) THEN X1=PCK/DENS(ID) DO IJ=1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) HEXN=HEXN+FLUXW*DABN0(IJ) HEXT=HEXT+FLUXW*DABT0(IJ) DO I=1,NLVEXP HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ) END DO C C Columns corresponding to mean intensities C B(NHE,IJ)=X1*W(IJT)*FH(IJT)*ABSO0(IJ) END IF END DO END IF C RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID)) VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID) C C columns corresponding to total particle density, fictitious C massive particle density, temperature, and electron density, C respectively C B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0) IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN) IF(INRE.GT.0) THEN B(NHE,NRE)=BOLK*TOTN(ID)/DM(1)+X1*(HEXT+HEIT(ID)) C(NHE,NRE)=X1*HEITP(ID) END IF IF(INPC.GT.0) THEN B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0) C(NHE,NPC)=X1*HEINP(ID) END IF C C Columns corresponding to populations C DO II=1,NLVEXP B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID)) C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID) END DO C C The rhs vector also accounts for the total radiation pressure in C the fixed-option transitions (array FPRD, generated by FIXLIN) C VECL(NHE)=GRAV-BOLK*TEMP(ID)*TOTN(ID)/DM(ID)- * X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID) RETURN C C *** Normal depth point (ID > 1) C C Columns (for matrices A and B) corresponding to mean intensities C 50 CONTINUE IF(NFREQE.GT.0.and.ifprad.gt.0) THEN DO IJ=1,NFREQE IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ)) A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ) B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ) END IF END DO END IF C VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID) VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID-1) C C columns corresponding to total particle density C A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*VTM B(NHE,NHE)=BOLK*TEMP(ID)+GN*VT0 C C columns corresponding to temperature C IF(INRE.GT.0) THEN A(NHE,NRE)=-BOLK*TOTN(ID-1)+PCK*HEITM(ID) B(NHE,NRE)=BOLK*TOTN(ID)+PCK*HEIT(ID) C(NHE,NRE)=PCK*HEITP(ID) END IF C C columns corresponding to electron density C IF(INPC.GT.0) THEN A(NHE,NPC)=GN*VTM+PCK*HEINM(ID) B(NHE,NPC)=-GN*VT0+PCK*HEIN(ID) C(NHE,NPC)=PCK*HEINP(ID) END IF C C columns corresponding to NMP C IF(INMP.GT.0) THEN A(NHE,NFREQE+INMP)=-GP*VTM B(NHE,NFREQE+INMP)=GP*VT0 END IF C C columns corresponding to populations C DO II=1,NLVEXP A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID) B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID) C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID) END DO C C the rhs vector C again, which accounts for the total radiation pressure in the C fixed-option transitions (array FPRD) C VECL(NHE)=GRAV*(DM(ID)-DM(ID-1))- * BOLK*(TEMP(ID)*TOTN(ID)-TEMP(ID-1)*TOTN(ID-1))- * PCK*(GRD+FPRD(ID))- * VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID-1)*DENS(ID-1) RETURN END C C C C **************************************************************** C C SUBROUTINE BHED(ID) C ================== C C The part of matrices A and B corresponding to the hydrostatic C equilibrium equation, C i.e. the (NFREQE+INHE)-th row; C ii) if desired (INMP > 0), the part corresponding to the C definition equation for the fictitious massive particle density, C ie. the (NFREQE+INMP)-th row; C iii) the part of matrices B and C corresponding to the C z-m (z-distance versus mass-depth coordinate) relation, C ie. the (NFREQE+INZD)-th row of matrices B and C, however, the C elements of C are treated separately C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ) COMMON/CMATZD/CZZ,CZN,CZE,CZM C NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NSE=NFREQE+INSE-1 c if(inhe.le.0) go to 100 IJ1=1 C C *********** Linearized equation for the fictitious massive particle C density C IF(INMP.GT.0) THEN NMP=NFREQE+INMP B(NMP,NMP)=-UN B(NMP,NHE)=UN IF(INPC.GT.0) B(NMP,NPC)=-UN END IF C C *********** Linearized hydrostatic equilibrium C HEXT=0. HEXN=0. GRD=0. FLUXW=0. DO I=1,NLVEXP HEX(I)=0. END DO C IF(ID.GT.1) GO TO 50 C C *** Upper boundary condition (ID=1) C C 1. possibility - the same as in stellar atmospheres C Basically, linearized eq. (7-10) of Mihalas (1978) C IF(IBCHE.LE.0) THEN X1=PCK/DENS(ID) IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) HEXN=HEXN+FLUXW*DABN0(IJ) HEXT=HEXT+FLUXW*DABT0(IJ) DO I=1,NLVEXP HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ) END DO C C Columns corresponding to mean intensities C B(NHE,IJ)=X1*WDEP0(IJ)*FH(IJT)*ABSO0(IJ) END IF END DO END IF C RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID)) VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID) C C columns corresponding to total particle density, fictitious C massive particle density, temperature, and electron density, C respectively C B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0) IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN) IF(INRE.GT.0) THEN B(NHE,NRE)=BOLK*PSI0(NHE)/DM(1)+X1*(HEXT+HEIT(ID)) C(NHE,NRE)=X1*HEITP(ID) END IF IF(INPC.GT.0) THEN B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0) C(NHE,NPC)=X1*HEINP(ID) END IF C C Columns corresponding to populations C DO II=1,NLVEXP B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID)) C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID) END DO C C The rhs vector also accounts for the total radiation pressure in C the fixed-option transitions (array FPRD) C GRAV=QGRAV*ZD(1) VECL(NHE)=GRAV-BOLK*TEMP(ID)*PSI0(NHE)/DM(ID)- * X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID) GO TO 100 ELSE IF(IBCHE.EQ.1) THEN C C 2. possibility - specifically disk - Hubeny (1990), Eq. (4.19) C newer variant C C IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) HEXN=HEXN+FLUXW*DABN0(IJ) HEXT=HEXT+FLUXW*DABT0(IJ) DO I=1,NLVEXP HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ) END DO END IF END DO END IF C CCC=PCK/QGRAV HR1=CCC*(GRD+FPRD(1))/DENS(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF X1=X*1.01 F1D=0. IF(X1.LT.3.) THEN F1D=8.86226925D-1*EXP(X1*X1)*ERFCX(X1) ELSE F1D=HALF*(UN-HALF/X1/X1)/X1 END IF IF(X.GT.0.) F1D=(F1D-F1)*100./X GGG=DENS(1)*HG1*F1 RF1=DENS(1)*F1D CCD=CCC*F1D C DO IJ=1,NFREQE B(NHE,IJ)=-CCD*WDEP0(IJ)*FH(IJFR(IJ))*ABSO0(IJ) END DO C C columns corresponding to total particle density and temperature C B(NHE,NHE)=B(NHE,NHE)+(GGG+HR1*RF1)/PSI0(NHE) IF(INRE.GT.0) B(NHE,NRE)= * (GGG-RF1*ZD(1)+RF1*HR1)*HALF/TEMP(1)-CCD*(HEXT+HEIT(ID)) IF(INZD.GT.0) B(NHE,NZD)=RF1 IF(INPC.GT.0) B(NHE,NPC)=-CCD*(HEXN+HEIN(ID)) DO II=1,NLVEXP B(NHE,NSE+II)=-CCD*(HEX(II)+HEIP(II,ID)) END DO C C The rhs vector C VECL(NHE)=DM(1)-GGG GO TO 100 ELSE IF(IBCHE.EQ.2) THEN C C 3. possibility - specifically disk - Hubeny (1990), Eq. (4.19) C older variant C IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) END IF END DO END IF CCC=PCK/QGRAV PR1=CCC*(GRD+FPRD(1))/DENS(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-PR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF GGG=HG1*QGRAV*HALF/F1 C C columns corresponding to total particle density and temperature C B(NHE,NHE)=BOLK*TEMP(1) IF(INRE.GT.0) B(NHE,NFREQE+INRE)=PG1/TEMP(1) C C The rhs vector C VECL(NHE)=DM(1)*GGG-PG1 GO TO 100 END IF C C *** Normal depth point (ID > 1) C C Columns (for matrices A and B) corresponding to mean intensities C 50 IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ)) A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ) B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ) END IF END DO END IF C VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID) VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID) C C columns corresponding to total particle density C A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*VTM B(NHE,NHE)=BOLK*TEMP(ID)+GN*VT0 C C columns corresponding to temperature C IF(INRE.GT.0) THEN A(NHE,NRE)=-BOLK*PSIM(NHE)+PCK*HEITM(ID) B(NHE,NRE)=BOLK*PSI0(NHE)+PCK*HEIT(ID) C(NHE,NRE)=PCK*HEITP(ID) END IF C C columns corresponding to electron density C IF(INPC.GT.0) THEN A(NHE,NPC)=GN*VTM+PCK*HEINM(ID) B(NHE,NPC)=-GN*VT0+PCK*HEIN(ID) C(NHE,NPC)=PCK*HEINP(ID) END IF C C columns corresponding to NMP C IF(INMP.GT.0) THEN A(NHE,NFREQE+INMP)=-GP*VTM B(NHE,NFREQE+INMP)=GP*VT0 END IF C C column corresponding to ZD (z-distance) C IF(INZD.GT.0) THEN A(NHE,NFREQE+INZD)=-QGRAV*(DM(ID)-DM(ID-1))*HALF B(NHE,NFREQE+INZD)=-QGRAV*(DM(ID)-DM(ID-1))*HALF END IF C C columns corresponding to populations C DO II=1,NLVEXP A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID) B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID) C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID) END DO C C the rhs vector C again, which accounts for the total radiation pressure in the C fixed-option transitions (array FPRD) C C Since ZD(ID) is in fact z-distance corresponding to a midpoint C between depth points ID and ID+1 (as follows from the numerical C representation of the relation between DM and ZD), and ZD(ID-1) C corresponds to a midpoint between ID and ID-1, z-distance for C the point ID is better approximated by the mean value of ZD(ID) C and ZD(ID-1) C GRAV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF VECL(NHE)=GRAV*(DM(ID)-DM(ID-1))- * BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))- * PCK*(GRD+FPRD(ID))- * VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID)*DENS(ID-1) C C *********** Linearized z-m (z-distance vers. mass-depth) relation C C Note: since there are only at most four non-zero elements of C matrix C, they are stored separately in CZZ,CZN,CZE,CZM; C when multiplying any matrix by matrix C, these terms must be C treated separately - see SOLVE C 100 IF(INZD.LE.0) RETURN NZD=NFREQE+INZD C C *** lower boundary condition [ie. z(ND)=0 ] C B(NZD,NZD)=UN IF(ID.EQ.ND) RETURN C C *** normal depth point C DDP=(DM(ID+1)-DM(ID))*HALF C C column corresponding to ZD C B(NZD,NZD)=UN CZZ=-UN C C column corresponding to total particle density C X1=GN*WMM(ID)*DDP IF(INHE.GT.0) THEN B(NZD,NFREQE+INHE)=X1/DENS(ID)/DENS(ID) CZN=X1/DENS(ID+1)/DENS(ID+1) END IF C C column corresponding to electron density C IF(INPC.GT.0) THEN B(NZD,NFREQE+INPC)=-X1/DENS(ID)/DENS(ID) CZE=-X1/DENS(ID+1)/DENS(ID+1) END IF C C column corresponding to NMP C IF(INMP.GT.0) THEN B(NZD,NFREQE+INMP)=DDP/DENS(ID)/PSI0(NFREQE+INMP) CZM=DDP/DENS(ID+1)/PSIP(NFREQE+INMP) END IF C C the element of the rhs vector C VECL(NZD)=ZD(ID+1)-ZD(ID)+DDP/DENS(ID)+DDP/DENS(ID+1) RETURN END C C C C **************************************************************** C C SUBROUTINE BHEZ(ID) C ================== C C The part of matrices A and B corresponding to the hydrostatic C equilibrium equation, C i.e. the (NFREQE+INHE)-th row; C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ) C NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NZD=NFREQE+INZD NSE=NFREQE+INSE-1 c if(inhe.le.0) return IJ1=1 C C *********** Linearized equation for the fictitious massive particle C density C IF(INMP.GT.0) THEN NMP=NFREQE+INMP B(NMP,NMP)=-UN B(NMP,NHE)=UN IF(INPC.GT.0) B(NMP,NPC)=-UN END IF C C *********** Linearized hydrostatic equilibrium C HEXT=0. HEXN=0. GRD=0. FLUXW=0. DO I=1,NLVEXP HEX(I)=0. END DO C IF(ID.GT.1) GO TO 50 C C *** Upper boundary condition (ID=1) C C 1. possibility - the same as in stellar atmospheres C Basically, linearized eq. (7-10) of Mihalas (1978) C IF(IBCHE.EQ.0) THEN X1=PCK/DENS(ID) IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) HEXN=HEXN+FLUXW*DABN0(IJ) HEXT=HEXT+FLUXW*DABT0(IJ) DO I=1,NLVEXP HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ) END DO C C Columns corresponding to mean intensities C B(NHE,IJ)=X1*WDEP0(IJ)*FH(IJT)*ABSO0(IJ) END IF END DO END IF C RTN=X1*WMM(ID)/DENS(ID)*(GRD+FPRD(ID)) VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID) C C columns corresponding to total particle density, fictitious C massive particle density, temperature, and electron density, C respectively C B(NHE,NHE)=BOLK*TEMP(ID)/DM(ID)-GN*(RTN-VT0) IF(INMP.GT.0) B(NHE,NFREQE+INMP)=GP*(VT0-RTN) IF(INRE.GT.0) THEN B(NHE,NRE)=BOLK*PSI0(NHE)/DM(1)+X1*(HEXT+HEIT(ID)) C(NHE,NRE)=X1*HEITP(ID) END IF IF(INPC.GT.0) THEN B(NHE,NPC)=X1*(HEXN+HEIN(ID))+GN*(RTN-VT0) C(NHE,NPC)=X1*HEINP(ID) END IF C C Columns corresponding to populations C DO II=1,NLVEXP B(NHE,NSE+II)=B(NHE,NSE+II)+X1*(HEX(II)+HEIP(II,ID)) C(NHE,NSE+II)=C(NHE,NSE+II)+X1*HEIPP(II,ID) END DO C C The rhs vector also accounts for the total radiation pressure in C the fixed-option transitions (array FPRD) C GRAV=QGRAV*ZD(1) VECL(NHE)=GRAV-BOLK*TEMP(ID)*PSI0(NHE)/DM(ID)- * X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID) C RETURN ELSE IF(IBCHE.EQ.1) THEN C C 2. possibility - specifically disk - Hubeny (1990), Eq. (4.19) C newer variant C IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) HEXN=HEXN+FLUXW*DABN0(IJ) HEXT=HEXT+FLUXW*DABT0(IJ) DO I=1,NLVEXP HEX(I)=HEX(I)+FLUXW*DRCH0(I,IJ) END DO END IF END DO END IF c CCC=PCK/QGRAV HR1=CCC*(GRD+FPRD(1))/DENS(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF X1=X*1.01 F1D=0. IF(X1.LT.3.) THEN F1D=8.86226925D-1*EXP(X1*X1)*ERFCX(X1) ELSE F1D=HALF*(UN-HALF/X1/X1)/X1 END IF IF(X.GT.0.) F1D=(F1D-F1)*100./X GGG=DENS(1)*HG1*F1 RF1=DENS(1)*F1D CCD=CCC*F1D C DO IJ=1,NFREQE B(NHE,IJ)=-CCD*WDEP0(IJ)*FH(IJFR(IJ))*ABSO0(IJ) END DO C C columns corresponding to total particle density and temperature C B(NHE,NHE)=B(NHE,NHE)+(GGG+HR1*RF1)/PSI0(NHE) IF(INRE.GT.0) B(NHE,NRE)= * (GGG-RF1*ZD(1)+RF1*HR1)*HALF/TEMP(1)-CCD*(HEXT+HEIT(ID)) IF(INZD.GT.0) B(NHE,NZD)=RF1 IF(INPC.GT.0) B(NHE,NPC)=-CCD*(HEXN+HEIN(ID)) DO II=1,NLVEXP B(NHE,NSE+II)=-CCD*(HEX(II)+HEIP(II,ID)) END DO C C The rhs vector C VECL(NHE)=DM(1)-GGG RETURN ELSE IF(IBCHE.EQ.2) THEN C C 3. possibility - specifically disk - Hubeny (1990), Eq. (4.19) C older variant C IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RAD0(IJ)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSO0(IJ) END IF END DO END IF CCC=PCK/QGRAV PR1=CCC*(GRD+FPRD(1))/DENS(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-PR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF GGG=HG1*QGRAV*HALF/F1 C C columns corresponding to total particle density and temperature C B(NHE,NHE)=BOLK*TEMP(1) IF(INRE.GT.0) B(NHE,NFREQE+INRE)=PG1/TEMP(1) C C The rhs vector C VECL(NHE)=DM(1)*GGG-PG1 RETURN ELSE C C 4. a simple form of the bounary condition P_gas(ID=1)=PGAS0, C where PGAS0 is an input parameter C B(NHE,NHE)=BOLK*TEMP(1) IF(INRE.GT.0) B(NHE,NRE)=BOLK*PSI0(NHE) VECL(NHE)=PGAS0-BOLK*TEMP(1)*PSI0(NHE) RETURN END IF C C *** Normal depth point (ID > 1) C C Columns (for matrices A and B) corresponding to mean intensities C 50 CONTINUE GRAV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF GRAVZ=GRAV*(ZD(ID)-ZD(ID-1)) DGRV=GRAVZ*HALF*WMM(ID) GRD=0. IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IF(.NOT.LSKIP(ID,IJFR(IJ))) THEN GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ)) A(NHE,IJ)=-PCK*W(IJFR(IJ))*FKM(IJ) B(NHE,IJ)=PCK*W(IJFR(IJ))*FK0(IJ) END IF END DO END IF C VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID) VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID) C C columns corresponding to total particle density C A(NHE,NHE)=-BOLK*TEMP(ID-1)-GN*(VTM+DGRV) B(NHE,NHE)=BOLK*TEMP(ID)+GN*(VT0+DGRV) C C columns corresponding to temperature C IF(INRE.GT.0) THEN A(NHE,NRE)=-BOLK*PSIM(NHE)+PCK*HEITM(ID) B(NHE,NRE)=BOLK*PSI0(NHE)+PCK*HEIT(ID) C(NHE,NRE)=PCK*HEITP(ID) END IF C C columns corresponding to electron density C IF(INPC.GT.0) THEN A(NHE,NPC)=GN*(VTM+DGRV)+PCK*HEINM(ID) B(NHE,NPC)=-GN*(VT0+DGRV)+PCK*HEIN(ID) C(NHE,NPC)=PCK*HEINP(ID) END IF C C columns corresponding to NMP C IF(INMP.GT.0) THEN A(NHE,NFREQE+INMP)=-GP*(VTM+DGRV) B(NHE,NFREQE+INMP)=GP*(VT0+DGRV) END IF C C columns corresponding to populations C DO II=1,NLVEXP A(NHE,NSE+II)=A(NHE,NSE+II)+PCK*HEIPM(II,ID) B(NHE,NSE+II)=B(NHE,NSE+II)+PCK*HEIP(II,ID) C(NHE,NSE+II)=C(NHE,NSE+II)+PCK*HEIPP(II,ID) END DO C C the rhs vector C VECL(NHE)=-GRAVZ*(DENS(ID)+DENS(ID-1))*HALF- * BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))- * PCK*(GRD+FPRD(ID))- * VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID)*DENS(ID-1) C RETURN END C C **************************************************************** C C SUBROUTINE BRE(ID) C ================== C C The part of matrices A and B corresponding to the radiative C equilibrium equation C i.e. the (NFREQE+INRE)-th row C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION REXB(MLEVEL) EQUIVALENCE (REX(1),REXB(1)) C NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NMP=NFREQE+INMP NSE=NFREQE+INSE-1 IJ1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) IJ1=2 C ittc=abs(nretc)/100 if(iter.gt.ittc) then if(id.le.mod(abs(nretc),100)) then b(nre,nre)=1. if(nretc.lt.0) then c(nre,nre)=-1. vecl(nre)=temp(id+1)-temp(id) end if return end if end if C C the rhs vector accounts for total net cooling in ALI C transitions (FCOOL) C VECL(NRE)=FCOOL(ID) IF(IDISK.EQ.1) VECL(NRE)=FCOOL(ID)-reint(id)*TVISC(ID) if(reint(id).le.0) go to 100 C C ********* integral equation part of the radiative C equilibrium equation C BREPC=0. BREMP=0. DO I=1,NLVEXP REXB(I)=0. END DO IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) BREPC=BREPC+((DABN0(IJ)-SIGEC(IJT))*RAD0(IJ)- * DEMN0(IJ))*WDEP0(IJ) BREMP=BREMP+(DABM0(IJ)*RAD0(IJ)-DEMM0(IJ))*WDEP0(IJ) DO I=1,NLVEXP REXB(I)=REXB(I)+(DRCH0(I,IJ)*RAD0(IJ)- * DRET0(I,IJ))*WDEP0(IJ) END DO B(NRE,NRE)=B(NRE,NRE)+(DABT0(IJ)*RAD0(IJ)- * DEMT0(IJ))*WDEP0(IJ)*reint(id) HEAT=ABSO0(IJ)-SCAT0(IJ) B(NRE,IJ)=WDEP0(IJ)*HEAT*reint(id) VECL(NRE)=VECL(NRE)-(HEAT*RAD0(IJ)-EMIS0(IJ))*WDEP0(IJ)* * reint(id) c c additional terms for Compton scattering c if(icompt.gt.5) then ijt=ijfr(ij) call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) vecl(nre)=vecl(nre)+abso0(ij)*cms*wdep0(ij)*reint(id) if(icompt.gt.6) then if(icmdra.gt.0) then b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*wdep0(ij)*reint(id) else b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*reint(id) end if iji=nfreq-kij(ijt)+1 if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) then if(icmdra.gt.0) then b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*wdep0(ij)*reint(id) else b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*reint(id) end if end if end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) then if(icmdra.gt.0) then b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*wdep0(ij)*reint(id) else b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*reint(id) end if end if end if b(nre,nre)=b(nre,nre)-cmd*abso0(ij)*wdep0(ij)*reint(id) b(nre,npc)=b(nre,npc)-cms*abso0(ij)/elec(id)*wdep0(ij)* * reint(id) end if end if C END DO END IF C C corrections for ALI frequency points C B(NRE,NRE)=B(NRE,NRE)+REIT(ID)*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id) IF(INMP.GT.0) B(NRE,NMP)=B(NRE,NMP)+(BREMP+REIM(ID))*reint(id) IF(INHE.GT.0) B(NRE,NHE)=REIX(ID)*reint(id) IF(IFALI.GT.5) THEN A(NRE,NRE)=AREIT(ID)*reint(id) IF(INPC.GT.0) A(NRE,NPC)=AREIN(ID)*reint(id) IF(INMP.GT.0) A(NRE,NMP)=AREIM(ID)*reint(id) C(NRE,NRE)=CREIT(ID)*reint(id) IF(INPC.GT.0) C(NRE,NPC)=CREIN(ID)*reint(id) IF(INMP.GT.0) C(NRE,NMP)=CREIM(ID)*reint(id) IF(INHE.GT.0) C(NRE,NHE)=CREIX(ID)*reint(id) END IF C C additional terms for disks because of viscosity C IF(IDISK.EQ.1) THEN B(NRE,NRE)=B(NRE,NRE)+DTVIST(ID)*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)-DTVISR(ID)*reint(id) IF(INHE.GT.0) B(NRE,NFREQE+INHE)= * (DTVISR(ID)+DTVISN(ID))*reint(id) IF(INMP.GT.0) B(NRE,NFREQE+INMP)= * DTVISR(ID)*HMASS/WMM(ID)*reint(id) END IF C DO II=1,NLVEXP B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REIP(II,ID))*reint(id) END DO IF(IFALI.GT.5.AND.ID.GT.1) THEN DO II=1,NLVEXP A(NRE,NSE+II)=A(NRE,NSE+II)+AREIP(II,ID)*reint(id) END DO END IF IF(IFALI.GT.5.AND.ID.LT.ND) THEN DO II=1,NLVEXP C(NRE,NSE+II)=C(NRE,NSE+II)+CREIP(II,ID)*reint(id) END DO END IF C C ********* differential equation part of the C radiative equilibrium equation C 100 CONTINUE if(redif(id).eq.0) return C TEFFD=TEFF**4 IF(IDISK.EQ.1) TEFFD=TEFF**4*(UN-THETAV(ID)) VECL(NRE)=VECL(NRE)+SIG4P*TEFFD*redif(id) c if(id.eq.1) go to 200 C DDM=(DM(ID)-DM(ID-1))*HALF AREN=0. BREN=0. AREPC=0. BREPC=0. C GP=0. GN=UN IF(INMP.GT.0) THEN GP=UN GN=0. END IF C DO I=1,NLVEXP REXB(I)=0. REXA(I)=0. END DO C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE OMEG0=ABSO0(IJ)*DENS1(ID) OMEGM=ABSOM(IJ)*DENS1(ID-1) DTAUM=(OMEG0+OMEGM)*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAMR=FRD/DTAUM A1=GAMR/(OMEG0+OMEGM) A3R=A1*DENS1(ID-1)*WDEP0(IJ) B3R=A1*DENS1(ID)*WDEP0(IJ) C C Corresponding elements of matrix A C A(NRE,IJ)=-WDEP0(IJ)*FKM(IJ)/DTAUM*redif(id) RTR=OMEGM*WMM(ID-1)*A3R AREN=AREN+RTR*GN AREPC=AREPC-A3R*DABNM(IJ)-RTR*GN IF(INMP.NE.0) A(NRE,NFREQE+INMP)=A(NRE,NFREQE+INMP)+RTR*GP* * redif(id) A(NRE,NRE)=A(NRE,NRE)-A3R*DABTM(IJ)*redif(id) C C Corresponding elements of matrix B C Columns corresponding to mean intensities C B(NRE,IJ)=B(NRE,IJ)+WDEP0(IJ)*FK0(IJ)/DTAUM*redif(id) RTR=OMEG0*WMM(ID)*B3R BREN=BREN+RTR*GN BREPC=BREPC-B3R*DABN0(IJ)-RTR*GN IF(INMP.NE.0) B(NRE,NFREQE+INMP)=B(NRE,NFREQE+INMP)+ * (RTR+REDX(ID))*GP*redif(id) C C Column corresponding to temperature C B(NRE,NRE)=B(NRE,NRE)-B3R*DABT0(IJ)*redif(id) C C auxiliary vectors for columns corresponding to populations C DO I=1,NLVEXP REXA(I)=REXA(I)-A3R*DRCHM(I,IJ) REXB(I)=REXB(I)-B3R*DRCH0(I,IJ) END DO C C The rhs vector C VECL(NRE)=VECL(NRE)-WDEP0(IJ)*GAMR*redif(id) END DO END IF C C Column corresponding to N (total particle number density) C for both A and B matrices C IF(INHE.NE.0) THEN A(NRE,NFREQE+INHE)=(AREN+REDXM(ID))*redif(id) B(NRE,NFREQE+INHE)=B(NRE,NFREQE+INHE)+(BREN+REDX(ID))*redif(id) END IF C C Column corresponding to temperature C A(NRE,NRE)=A(NRE,NRE)+REDTM(ID)*REDIF(ID) B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID) C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID) C C Column corresponding to electron density (for matrices A and B) C IF(INPC.NE.0) THEN A(NRE,NPC)=A(NRE,NPC)+(AREPC+REDNM(ID)-REDXM(ID))*redif(id) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REDN(ID)-REDX(ID))*redif(id) C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id) END IF C C Columns corresponding to populations (for matrices A and B) C Note that auxiliary arrays REXA and REX, which contain derivatives C of the absorption and emission coefficients wrt populations, have C been generated by BRTE C DO II=1,NLVEXP A(NRE,NSE+II)=A(NRE,NSE+II)+(REXA(II)+REDPM(II,ID))*redif(id) B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REDP(II,ID))*redif(id) C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id) END DO RETURN c C upper boundary condition for the differential form c 200 CONTINUE C C Columns corresponding to mean intensities; rhs vector C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) WF=WDEP0(IJ)*FH(IJT)*REDIF(ID) B(NRE,IJ)=B(NRE,IJ)+WF VECL(NRE)=VECL(NRE)-WF*RAD0(IJ)-WDEP0(IJ)*HEXTRD(IJT)* * REDIF(ID) END DO END IF C C Column corresponding to temperature C B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID) C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID) C C Column corresponding to N and electron density C IF(INHE.NE.0) B(NRE,NHE)=B(NRE,NHE)+REDX(ID)*redif(id) IF(INPC.NE.0) B(NRE,NPC)=B(NRE,NPC)+REDN(ID)*redif(id) IF(INHE.NE.0) C(NRE,NHE)=C(NRE,NHE)+REDXP(ID)*redif(id) IF(INPC.NE.0) C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id) C C Columns corresponding to populations C DO II=1,NLVEXP B(NRE,NSE+II)=B(NRE,NSE+II)+REDP(II,ID)*redif(id) C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id) END DO RETURN END C C C C **************************************************************** C C SUBROUTINE BREZ(ID) C =================== C C The part of matrices A and B corresponding to the radiative C equilibrium equation C i.e. the (NFREQE+INRE)-th row C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION REXB(MLEVEL) EQUIVALENCE (REX(1),REXB(1)) C NRE=NFREQE+INRE NHE=NFREQE+INHE NPC=NFREQE+INPC NMP=NFREQE+INMP NSE=NFREQE+INSE-1 IJ1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) IJ1=2 C ittc=abs(nretc)/100 if(iter.gt.ittc) then if(id.le.mod(abs(nretc),100)) then b(nre,nre)=1. if(nretc.lt.0) then c(nre,nre)=-1. vecl(nre)=temp(id+1)-temp(id) end if return end if end if C C the rhs vector accounts for total net cooling in ALI C transitions (FCOOL) C VECL(NRE)=FCOOL(ID)-reint(id)*TVISC(ID) if(reint(id).le.0) go to 100 C C ********* integral equation part of the radiative C equilibrium equation C BREPC=0. BREMP=0. DO I=1,NLVEXP REXB(I)=0. END DO IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) BREPC=BREPC+((DABN0(IJ)-SIGEC(IJT))*RAD0(IJ)- * DEMN0(IJ))*WDEP0(IJ) BREMP=BREMP+(DABM0(IJ)*RAD0(IJ)-DEMM0(IJ))*WDEP0(IJ) DO I=1,NLVEXP REXB(I)=REXB(I)+(DRCH0(I,IJ)*RAD0(IJ)- * DRET0(I,IJ))*WDEP0(IJ) END DO B(NRE,NRE)=B(NRE,NRE)+(DABT0(IJ)*RAD0(IJ)- * DEMT0(IJ))*WDEP0(IJ)*reint(id) HEAT=ABSO0(IJ)-SCAT0(IJ) B(NRE,IJ)=WDEP0(IJ)*HEAT*reint(id) VECL(NRE)=VECL(NRE)-(HEAT*RAD0(IJ)-EMIS0(IJ))*WDEP0(IJ)* * reint(id) c c additional terms for Compton scattering c if(icompt.gt.5) then ijt=ijfr(ij) call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) vecl(nre)=vecl(nre)+abso0(ij)*cms*wdep0(ij)*reint(id) if(icompt.gt.6) then if(icmdra.gt.0) then b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*wdep0(ij)*reint(id) else b(nre,ij)=b(nre,ij)-abso0(ij)*(cmb+cme)*reint(id) end if iji=nfreq-kij(ijt)+1 if(iji.gt.1) then ijm=ijex(ijorig(iji-1)) if(ijm.gt.0) then if(icmdra.gt.0) then b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*wdep0(ij)*reint(id) else b(nre,ijm)=b(nre,ijm)-abso0(ij)*cma*reint(id) end if end if end if if(iji.lt.nfreq) then ijp=ijex(ijorig(iji+1)) if(ijp.gt.0) then if(icmdra.gt.0) then b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*wdep0(ij)*reint(id) else b(nre,ijp)=b(nre,ijp)-abso0(ij)*cmc*reint(id) end if end if end if b(nre,nre)=b(nre,nre)-cmd*abso0(ij)*wdep0(ij)*reint(id) b(nre,npc)=b(nre,npc)-cms*abso0(ij)/elec(id)*wdep0(ij)* * reint(id) end if end if C END DO END IF C C corrections for ALI frequency points C B(NRE,NRE)=B(NRE,NRE)+REIT(ID)*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REIN(ID))*reint(id) IF(INMP.GT.0) B(NRE,NMP)=B(NRE,NMP)+(BREMP+REIM(ID))*reint(id) IF(INHE.GT.0) B(NRE,NHE)=REIX(ID)*reint(id) A(NRE,NRE)=AREIT(ID)*reint(id) IF(INPC.GT.0) A(NRE,NPC)=AREIN(ID)*reint(id) C(NRE,NRE)=CREIT(ID)*reint(id) IF(INPC.GT.0) C(NRE,NPC)=CREIN(ID)*reint(id) IF(INMP.GT.0) C(NRE,NMP)=CREIM(ID)*reint(id) IF(INHE.GT.0) C(NRE,NHE)=CREIX(ID)*reint(id) c END IF C C terms arising because of viscosity C B(NRE,NRE)=B(NRE,NRE)+DTVIST(ID)*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)-DTVISR(ID)*reint(id) IF(INHE.GT.0) B(NRE,NFREQE+INHE)= * (DTVISR(ID)+DTVISN(ID))*reint(id) IF(INMP.GT.0) B(NRE,NFREQE+INMP)= * DTVISR(ID)*HMASS/WMM(ID)*reint(id) C DO II=1,NLVEXP B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REIP(II,ID))*reint(id) END DO IF(IFALI.GT.5.AND.ID.GT.1) THEN DO II=1,NLVEXP A(NRE,NSE+II)=A(NRE,NSE+II)+AREIP(II,ID)*reint(id) END DO END IF IF(IFALI.GT.5.AND.ID.LT.ND) THEN DO II=1,NLVEXP C(NRE,NSE+II)=C(NRE,NSE+II)+CREIP(II,ID)*reint(id) END DO END IF C C ********* differential equation part of the C radiative equilibrium equation C 100 CONTINUE if(redif(id).eq.0) return C TEFFD=TEFF**4*(UN-THETAV(ID)) VECL(NRE)=VECL(NRE)+SIG4P*TEFFD*redif(id) if(id.eq.1) go to 200 C DDM=(ZD(ID-1)-ZD(ID))*HALF AREN=0. BREN=0. AREPC=0. BREPC=0. C GP=0. GN=UN IF(INMP.GT.0) THEN GP=UN GN=0. END IF C DO I=1,NLVEXP REXB(I)=0. REXA(I)=0. END DO C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE OMEG0=ABSO0(IJ) OMEGM=ABSOM(IJ) DTAUM=(OMEG0+OMEGM)*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAMR=FRD/DTAUM A1=GAMR/(OMEG0+OMEGM)*WDEP0(IJ) C C Corresponding elements of matrix A C A(NRE,IJ)=-WDEP0(IJ)*FKM(IJ)/DTAUM*redif(id) AREPC=AREPC-A1*DABNM(IJ) A(NRE,NRE)=A(NRE,NRE)-A1*DABTM(IJ)*redif(id) C C Corresponding elements of matrix B C Columns corresponding to mean intensities C B(NRE,IJ)=B(NRE,IJ)+WDEP0(IJ)*FK0(IJ)/DTAUM*redif(id) BREPC=BREPC-A1*DABN0(IJ) C C Column corresponding to temperature C B(NRE,NRE)=B(NRE,NRE)-A1*DABT0(IJ)*redif(id) C C auxiliary vectors for columns corresponding to populations C DO I=1,NLVEXP REXA(I)=REXA(I)-A1*DRCHM(I,IJ) REXB(I)=REXB(I)-A1*DRCH0(I,IJ) END DO C C The rhs vector C VECL(NRE)=VECL(NRE)-WDEP0(IJ)*GAMR*redif(id) END DO END IF C C Column corresponding to temperature C A(NRE,NRE)=A(NRE,NRE)+REDTM(ID)*REDIF(ID) B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID) C(NRE,NRE)=C(NRE,NRE)+REDTP(ID)*REDIF(ID) C C Column corresponding to electron density (for matrices A and B) C IF(INPC.NE.0) THEN A(NRE,NPC)=A(NRE,NPC)+(AREPC+REDNM(ID))*redif(id) B(NRE,NPC)=B(NRE,NPC)+(BREPC+REDN(ID))*redif(id) C(NRE,NPC)=C(NRE,NPC)+REDNP(ID)*redif(id) END IF C C Columns corresponding to populations (for matrices A and B) C Note that auxiliary arrays REXA and REX, which contain derivatives C of the absorption and emission coefficients wrt populations, have C been generated by BRTE C DO II=1,NLVEXP A(NRE,NSE+II)=A(NRE,NSE+II)+(REXA(II)+REDPM(II,ID))*redif(id) B(NRE,NSE+II)=B(NRE,NSE+II)+(REXB(II)+REDP(II,ID))*redif(id) C(NRE,NSE+II)=C(NRE,NSE+II)+REDPP(II,ID)*redif(id) END DO RETURN c C upper boundary condition for the differential form c 200 CONTINUE C C Columns corresponding to mean intensities; rhs vector C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) WF=WDEP0(IJ)*FH(IJT)*REDIF(ID) B(NRE,IJ)=B(NRE,IJ)+WF VECL(NRE)=VECL(NRE)-WF*RAD0(IJ) END DO END IF C C Column corresponding to temperature C B(NRE,NRE)=B(NRE,NRE)+REDT(ID)*REDIF(ID) C C Column corresponding to electron density C IF(INPC.NE.0) THEN B(NRE,NPC)=B(NRE,NPC)+REDN(ID)*redif(id) END IF C C Columns corresponding to populations C DO II=1,NLVEXP B(NRE,NSE+II)=B(NRE,NSE+II)+REDP(II,ID)*redif(id) END DO RETURN END C C C **************************************************************** C C SUBROUTINE BPOP(ID) C =================== C C The part of matrix B corresponding to the statistical C equilibrium equations C i.e. the (NFREQE+INSE)-th thru (NFREQE+INSE+NLVEXP-1)-th rows; C and to the charge conservation equation, ie. the (NFREQE+INPC)-th C row C C The formalism is similar to that described in Mihalas, Stellar C Atmospheres, 1978, pp. 143-145 C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ITERAT.FOR' dimension sbw(mlevel) dimension popp(mlevel) C if(ioptab.lt.0) return DO I=1,NLVEXP ATT(I)=0. ANN(I)=0. END DO C IF(.NOT.LTE .AND. IFPOPR.EQ.5.AND.IPSLTE.EQ.0) THEN CALL RATMAT(ID,IIFOR,0,ESEMAT,BESE) CALL LEVSOL(ESEMAT,BESE,POPP,IIFOR,NLVFOR,0) DO I=1,NLEVEL II=IIEXP(I) IF(II.EQ.0.AND.IMODL(I).EQ.6) THEN III=ILTREF(I,ID) SBPSI(I,ID)=POPP(I)/POPP(III) END IF END DO DO ION=1,NION DO I=NFIRST(ION),NLAST(ION) SBW(I)=ELEC(ID)*SBF(I)*WOP(I,ID) IF(POPUL(NNEXT(ION),ID).GT.0..AND.IPZERO(I,ID).EQ.0) * BFAC(I,ID)=POPP(I)/(POPP(NNEXT(ION))*SBW(I)) END DO END DO END IF C CALL LEVGRP(ID,IIEXP,0,POPP) CALL RATMAT(ID,IIEXP,0,ESEMAT,BESE) C IF(IFPOPR.LE.3) CALL MATINV(ESEMAT,NLVEXP,MLEVEL) C C Split BPOP in separate subroutines C if(ipslte.eq.0) then IF(.NOT.LTE.AND.IBPOPE.GT.0.AND.ID.LT.IDLTE) THEN CALL BPOPE(ID) CALL BPOPF(ID) END IF end if CALL BPOPT(ID) IF(INPC.GT.0) CALL BPOPC(ID) C C reset matrix elements for "small" populations C DO I=1,NLVEXP IF(IGZERO(I,ID).NE.0) THEN DO J=1,NLVEXP B(NFREQE+INSE-1+I,NFREQE+INSE-1+J)=0. END DO B(NFREQE+INSE-1+I,NFREQE+INSE-1+I)=1. VECL(NFREQE+INSE-1+I)=0. END IF END DO RETURN END C C C **************************************************************** C C SUBROUTINE BPOPE(ID) C ==================== C C the part of B-matrix corresponding to the population rows and C the explicit frequency columns C -- a variant for the full overlap case C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ARRAY1.FOR' DIMENSION AJIJ(MFREX,MLVEXP),EHKE(MFREX) C IF(NFREQE.LE.0) RETURN NSE=NFREQE+INSE-1 DO I=1,NLVEXP DO IJE=1,NFREQE AJIJ(IJE,I)=0. END DO END DO HKT=HK/TEMP(ID) DO IJE=1,NFREQE EHKE(IJE)=EXP(-HKT1(ID)*FREQ(IJFR(IJE))) END DO C DO 100 IJ=1,NFREQ IF(IJEX(IJ).LE.0) GO TO 100 IF(IJX(IJ).EQ.-1) GOTO 100 IJE=IJEX(IJ) FR=FREQ(IJ) FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV C C --------------------- C Continuum transitions C --------------------- C DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) IF(SG.LE.0.) GO TO 10 I=ILOW(ITR) IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 10 ICDW=MCDW(ITR) IMER=IMRG(I) II=IABS(IIEXP(I)) J=IUP(ITR) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 10 JJ=IABS(IIEXP(J)) NREFI=NREFS(IATM(I),ID) IF(IFWOP(I).GE.0) THEN IF(ICDW.GE.1) THEN IZZ=IZ(IEL(I)) CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) SG=SG*DW1 END IF ELSE CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SG=SGME1 ENDIF W0=W0E(IJ) SGW0=SG*W0 APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW0 IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0) * AJIJ(IJE,II)=AJIJ(IJE,II)+APFR IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0. * and.iabs(imodl(i)).ne.4) * AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR 10 CONTINUE C C ---------------- C Line transitions C ---------------- C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) IF(LINEXP(ITR)) GO TO 20 IF(.NOT.LEXP(ITR)) GO TO 20 I=ILOW(ITR) IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 20 J=IUP(ITR) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 20 II=IABS(IIEXP(I)) JJ=IABS(IIEXP(J)) IF(II.LE.0.AND.JJ.LE.0) GO TO 20 NREFI=NREFS(IATM(I),ID) SGW=PRFLIN(ID,IJ)*W0E(IJ) APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0) * AJIJ(IJE,II)=AJIJ(IJE,II)+APFR IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0. * and.iabs(imodl(i)).ne.4) * AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR END IF C C the "overlapping" lines at the given frequency C 20 IF(NLINES(IJ).LE.0) GO TO 100 DO 50 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) IF(LINEXP(ITR)) GO TO 50 I=ILOW(ITR) IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 50 J=IUP(ITR) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 50 II=IABS(IIEXP(I)) JJ=IABS(IIEXP(J)) IF(II.LE.0.AND.JJ.LE.0) GO TO 50 NREFI=NREFS(IATM(I),ID) IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 40 END IF END DO 40 IJ1=IJ0-1 X=W0E(IJ)/(FREQ(IJ1)-FREQ(IJ0)) A1=(FR-FREQ(IJ0))*X A2=(FREQ(IJ1)-FR)*X SGW=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0) * AJIJ(IJE,II)=AJIJ(IJE,II)+APFR IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0. * and.iabs(imodl(i)).ne.4) * AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR 50 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 100 DO 150 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) I=ILOW(ITR) IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 150 J=IUP(ITR) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 150 KJ=IJ-IFR0(ITR)+KFR0(ITR) II=IABS(IIEXP(I)) JJ=IABS(IIEXP(J)) IF(II.LE.0.AND.JJ.LE.0) GO TO 150 NREFI=NREFS(IATM(I),ID) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN SG=PRFLIN(ID,KJ) ELSE KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) END IF APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SG*W0E(IJ) IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0) * AJIJ(IJE,II)=AJIJ(IJE,II)+APFR IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0. * and.iabs(imodl(i)).ne.4) * AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR 150 CONTINUE END IF 100 CONTINUE C C elements of the B-matrix C DO I=1,NLVEXP DO IJE=1,NFREQE IF(IFPOPR.LE.3) THEN SUM=0. DO J=1,NLVEXP SUM=SUM-ESEMAT(I,J)*AJIJ(IJE,J) END DO ELSE SUM=AJIJ(IJE,I) END IF B(NSE+I,IJE)=SUM*CRSW(ID) END DO END DO RETURN END C C C **************************************************************** C C SUBROUTINE BPOPF(ID) C ===================== C C the part of B-matrix corresponding to the population rows and C populations - i.e. derivatives of the ALI points intensities C wrt. populations C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ODFPAR.FOR' C NSE=NFREQE+INSE-1 NRE=NFREQE+INRE NPC=NFREQE+INPC C C matrix B of complete linearization C DO I=1,NLVEXP SUMT=0. SUMN=0. DO II=1,NLVEXP IF(IFPOPR.LE.3) THEN SUMT=SUMT-ESEMAT(I,II)*APT(II,ID) SUMN=SUMN-ESEMAT(I,II)*APN(II,ID) SUM=0. DO J=1,NLVEXP SUM=SUM-ESEMAT(I,J)*APP(II,J,ID) END DO ELSE SUM=APP(II,I,ID) END IF B(NSE+I,NSE+II)=B(NSE+I,NSE+II)+SUM END DO IF(IFPOPR.GT.3) THEN SUMT=APT(I,ID) SUMN=APN(I,ID) END IF IF(INRE.NE.0) B(NSE+I,NRE)=B(NSE+I,NRE)+SUMT IF(INPC.NE.0) B(NSE+I,NPC)=B(NSE+I,NPC)+SUMN END DO IF(CRSW(ID).NE.UN) THEN DO I=1,NLVEXP DO II=1,NLVEXP B(NSE+I,NSE+II)=B(NSE+I,NSE+II)*CRSW(ID) END DO END DO END IF C C matrix A and C of complete linearization C IF(IFALI.GE.6) THEN DO I=1,NLVEXP ASUMT=0. ASUMN=0. CSUMT=0. CSUMN=0. DO II=1,NLVEXP IF(IFPOPR.LE.3) THEN ASUMT=ASUMT-ESEMAT(I,II)*AAPT(II,ID) ASUMN=ASUMN-ESEMAT(I,II)*AAPN(II,ID) CSUMT=CSUMT-ESEMAT(I,II)*CAPT(II,ID) CSUMN=CSUMN-ESEMAT(I,II)*CAPN(II,ID) ASUM=0. CSUM=0. DO J=1,NLVEXP ASUM=ASUM-ESEMAT(I,J)*AAPP(II,J,ID) CSUM=CSUM-ESEMAT(I,J)*CAPP(II,J,ID) END DO ELSE ASUM=AAPP(II,I,ID) CSUM=CAPP(II,I,ID) END IF A(NSE+I,NSE+II)=ASUM C(NSE+I,NSE+II)=CSUM END DO IF(IFPOPR.GT.3) THEN ASUMT=AAPT(I,ID) ASUMN=AAPN(I,ID) CSUMT=CAPT(I,ID) CSUMN=CAPN(I,ID) END IF IF(INRE.NE.0) THEN A(NSE+I,NRE)=A(NSE+I,NRE)+ASUMT C(NSE+I,NRE)=C(NSE+I,NRE)+CSUMT END IF IF(INPC.NE.0) THEN A(NSE+I,NPC)=A(NSE+I,NPC)+ASUMN C(NSE+I,NPC)=C(NSE+I,NPC)+CSUMN END IF END DO C IF(CRSW(ID).NE.UN) THEN DO I=1,NLVEXP DO II=1,NLVEXP A(NSE+I,NSE+II)=A(NSE+I,NSE+II)*CRSW(ID) C(NSE+I,NSE+II)=C(NSE+I,NSE+II)*CRSW(ID) END DO END DO END IF END IF RETURN END C C C **************************************************************** C C SUBROUTINE BPOPT(ID) C ==================== C C the part of B-matrix corresponding to the population rows C and T and ne columns C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (TRHA=1.5D0) PARAMETER (CCOR=0.09,SIXTH=UN/6.) DIMENSION DCOL(MTRANS),DLOC(MTRANS),AM(MLEVEL) C NSE=NFREQE+INSE-1 IF(INRE.EQ.0.AND.INPC.EQ.0) GO TO 400 IF(IELH.GT.0) N0HN=NFIRST(IELH) NKH=IABS(IIEXP(NREFS(IATREF,ID))) T=TEMP(ID) ANE=ELEC(ID) HKT=HK/T TK=HKT/H ANMNE1=WMM(ID)*DENS1(ID) DO I=1,NTRANS DCOL(I)=0. END DO DO I=1,NLEVEL AM(I)=0. END DO C C Derivatives of collisional rates wrt temperature - DCOL C Note that these derivatives are calculated numerically C IF(.NOT.LTE.AND.INRE.GT.0.AND.ID.LT.IDLTE) THEN DELTAT=T*1.D-4 CALL COLIS(ID,T+DELTAT,DCOL,DLOC) DO ITR=1,NTRANS DCOL(ITR)=(DCOL(ITR)-COLRAT(ITR,ID))/DELTAT end do END IF C C Column corresponding to temperature and electron density, ie. the C (NFREQE+INRE)-th and (NFREQE+INPC)-t resach columns C C ATT(I) - auxiliary vector = (derivative of rate matrix wrt C temperature) times (vector of populations) C C ANN(I) - auxiliary vector = (derivative of rate matrix wrt C electron density) times (vector of populations) C C C a) contribution to AT and AN from true statistical equilibrium C equations (arising due to dependence of transition rates on C temperature and electron density); C derivatives contain the collisional-radiative switching C parameter CRSW C IF(.NOT.LTE.AND.ID.LT.IDLTE) THEN DO 230 ITR=1,NTRANS I=ILOW(ITR) IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 230 J=IUP(ITR) IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 230 II=IABS(IIEXP(I)) JJ=IABS(IIEXP(J)) NREFI=NREFS(IATM(I),ID) IF(.NOT.LINE(ITR)) THEN DLGT=-(TRHA+HKT*FR0(ITR))/T DLGN=ELEC1(ID) ELSE DLGT=-HKT*FR0(ITR)/T DLGN=0. END IF POPI=ABTRA(ITR,ID) POPJ=EMTRA(ITR,ID) PJI=POPJ*(RRD(ITR,ID)+COLRAT(ITR,ID)) AVT=(POPI-POPJ)*DCOL(ITR)-PJI*DLGT- * POPJ*DRDT(ITR,ID) AVN=(POPI-POPJ)*COLRAT(ITR,ID)/ane-PJI*DLGN C IF(I.NE.NREFI.AND.II.GT.0.AND.ILTLEV(I).LE.0) THEN ATT(II)=ATT(II)+AVT ANN(II)=ANN(II)+AVN IF(JJ.EQ.0) THEN ATT(II)=ATT(II)-PJI*DSBPST(J,ID) ANN(II)=ANN(II)-PJI*DSBPSN(J,ID) END IF END IF IF(J.NE.NREFI.AND.JJ.GT.0.AND.ILTLEV(J).LE.0. * and.iabs(imodl(i)).ne.4) THEN ATT(JJ)=ATT(JJ)-AVT ANN(JJ)=ANN(JJ)-AVN IF(II.EQ.0) THEN PIJ=POPI*(RRU(ITR,ID)+COLRAT(ITR,ID)) ATT(JJ)=ATT(JJ)-PIJ*DSBPST(I,ID) ANN(JJ)=ANN(JJ)-PIJ*DSBPSN(I,ID) END IF END IF 230 CONTINUE END IF C C simple expressions in the case of LTE C LLT=LTE.OR.ID.GE.IDLTE DO IAT=1,NATOM DO I=N0A(IAT),NKA(IAT) II=IABS(IIEXP(I)) IF(II.NE.0.AND.I.NE.NREFS(IAT,ID)) THEN IF(LLT.OR.ILTION(IEL(I)).GE.1.OR.ILTLEV(I).GE.1) THEN ATT(II)=ATT(II)-POPUL(I,ID)*DSBPST(I,ID) ANN(II)=ANN(II)-POPUL(I,ID)*DSBPSN(I,ID) END IF END IF END DO END DO C C C b) contribution to AT and AN (and AM - for total particle density) C from the abundance definition equations C DO IAT=1,NATOM IF(IIFIX(IAT).NE.1) THEN NREFII=IABS(IIEXP(NREFS(IAT,ID))) IF(NREFII.NE.0) THEN DO I=N0A(IAT),NKA(IAT) IL=ILK(I) II=IIEXP(I) IF(IL.EQ.0) THEN IF(II.EQ.0) THEN ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DSBPST(I,ID) ANN(NREFII)=ANN(NREFII)+POPUL(I,ID)*DSBPSN(I,ID) END IF ELSE ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DUSUMT(IL)*ANE ANN(NREFII)=ANN(NREFII)+ * POPUL(I,ID)*(USUM(IL)+ANE*DUSUMN(IL)) END IF END DO if(ifmol.eq.0.or.t.gt.tmolim) then ANN(NREFII)=ANN(NREFII)+UN/YTOT(ID)*ABUND(IAT,ID) AM(NREFII)=AM(NREFII)-UN/YTOT(ID)*ABUND(IAT,ID) end if END IF END IF END DO C C ----------------------- C Having evaluated auxiliary vectors AT, AN, AM, we may now set up C the columns corresponding to temperature, el.density, and total C particle number density C DO I=1,NLVEXP IF(IFPOPR.LE.3) THEN AVT=0. AVN=0. AVM=0. DO J=1,NLVEXP AVT=AVT-ESEMAT(I,J)*ATT(J) AVN=AVN-ESEMAT(I,J)*ANN(J) AVM=AVM-ESEMAT(I,J)*AM(J) END DO ELSE AVT=ATT(I) AVN=ANN(I) AVM=AM(I) END IF IF(INHE.NE.0) B(NSE+I,NFREQE+INHE)=B(NSE+I,NFREQE+INHE)+AVM IF(INRE.NE.0) B(NSE+I,NFREQE+INRE)=B(NSE+I,NFREQE+INRE)+AVT IF(INPC.NE.0) B(NSE+I,NFREQE+INPC)=B(NSE+I,NFREQE+INPC)+AVN END DO C C Columns corresponding to populations C 400 CONTINUE IF(IFPOPR.LE.3) THEN DO I=1,NLVEXP B(NSE+I,NSE+I)=B(NSE+I,NSE+I)-UN IF(IABS(IFPOPR).GE.3) THEN SUM=0. DO J=1,NLVEXP SUM=SUM+ESEMAT(I,J)*BESE(J) END DO VECL(NSE+I)=POPGRP(I)-SUM END IF END DO ELSE IF(IFPOPR.LE.5) THEN DO I=1,NLVEXP SUM=0. DO J=1,NLVEXP SUM=SUM+ESEMAT(I,J)*POPGRP(J) B(NSE+I,NSE+J)=B(NSE+I,NSE+J)+ESEMAT(I,J) END DO VECL(NSE+I)=BESE(I)-SUM END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE BPOPC(ID) C ==================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ODFPAR.FOR' COMMON/ADCHAR/QADD(MDEPTH) DIMENSION AJ(MLEVEL) C NSE=NFREQE+INSE-1 NPC=NFREQE+INPC IF(IELH.GT.0) N0HN=NFIRST(IELH) NKH=NREFS(IATREF,ID) NKH=IABS(IIEXP(NKH)) T=TEMP(ID) ANE=ELEC(ID) HKT=HK/T TK=HKT/H ANMNE1=WMM(ID)*DENS1(ID) DO I=1,NLEVEL AJ(I)=0. END DO C C ************************* C remaining equation - (NFREQE+INPC)-th row C linearized charge conservation equation C ************************* C C This part is very similar to procedure ELCOR (obviously); C array AJ has the meaning of coefficients of the charge conserv. C ie. charge conservation is written C AJ * (vector of populations) = electron density C then C APTT = (vector of populations) * (derivative AJ wrt temp) C APNN = (vector of populations) * (derivative AJ wrt n(el)) C APM = (vector of populations) * (derivative AJ wrt N) C IF(INPC.EQ.0) RETURN QQ=0. if(ifmol.eq.0.or.t.gt.tmolim) then CALL STATE(3,ID,T,ANE) QQ=Q*ABUND(IATREF,ID)/YTOT(ID) if(ioptab.gt.0) QQ=Q/YTOT(ID) else qq=qadd(id)*anmne1 dqt=0. dqn=0. end if C APTT=0. APNN=0. APM=0. VPC=QFIX(ID)+QQ/ANMNE1 DO IAT=1,NATOM IF(IIFIX(IAT).NE.1) THEN DO I=N0A(IAT),NKA(IAT) IF(IPZERO(I,ID).EQ.0) THEN IL=ILK(I) II=IIEXP(I) IF(IL.EQ.0) THEN CH=IZ(IEL(I))-1 DCHT=0. DCHN=0. ELSE CH=IZ(IL)+(IZ(IL)-1)*USUM(IL)*ANE DCHT=(IZ(IL)-1)*ANE*DUSUMT(IL)*POPUL(I,ID) DCHN=(IZ(IL)-1)*(ANE*DUSUMN(IL)+USUM(IL))*POPUL(I,ID) END IF IF(IMODL(I).GE.0) VPC=VPC+CH*POPUL(I,ID) IF(II.GT.0) THEN AJ(II)=AJ(II)+CH APTT=APTT+DCHT APNN=APNN+DCHN ELSE IF(II.LT.0) THEN AJ(-II)=AJ(-II)+CH*SBPSI(I,ID) APTT=APTT+DCHT*SBPSI(I,ID) APNN=APNN+DCHN*SBPSI(I,ID) ELSE III=IIEXP(ILTREF(I,ID)) AJ(III)=AJ(III)+CH*SBPSI(I,ID) APTT=APTT+CH*POPUL(I,ID)*DSBPST(I,ID) APNN=APNN+CH*POPUL(I,ID)*DSBPSN(I,ID) END IF END IF END DO END IF END DO C C (NFREQE+INPC)-th row of matrix B C NPC=NFREQE+INPC QQQ=ABUND(IATREF,ID)/YTOT(ID)/ANMNE1 if(ioptab.gt.0) QQQ=UN/YTOT(ID)/ANMNE1 IF(INHE.NE.0) B(NPC,NFREQE+INHE)=APM+QQ IF(INRE.NE.0) B(NPC,NFREQE+INRE)=APTT+QQQ*DQT B(NPC,NPC)=APNN-QQ-UN+QQQ*DQN DO II=1,NLVEXP B(NPC,NSE+II)=AJ(II) END DO C C (NFREQE+INPC)-th element of the rhs vector VECL C VECL(NPC)=ANE-VPC RETURN END C C C **************************************************************** C C SUBROUTINE OPACFD(IJ) C ===================== C C Absorption and emission coefficients, and their derivatives C C This procedure is very similar to OPACF1, the only differences is C the evaluation of derivatives C C Input: C IJ - depth index C Output: C ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient C Dxxy - array of derivatives of xx (=AB for absorption, =EM for C emission) coefficient wrt y (=T for temperature, =N for C electron density) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (C14=2.99793D14, CFF1=1.3727D-25) PARAMETER (DELT=1.D-3, DELR=1.D-3) common/hmolab/anh2(mdepth),anhm(mdepth) DIMENSION DABP0(MLEVEL),DEMP0(MLEVEL) DIMENSION DABN1A(MDEPTH),DEMN1A(MDEPTH),DSCN1A(MDEPTH) common/dsctva/dsct1(mdepth),dscn1(mdepth) common/rhoder/drhodt(mdepth) c if(ioptab.lt.0) then call opactd(ij) return end if C C initialize c DO ID=1,ND ELSCAT(ID)=ELEC(ID)*SIGEC(IJ) END DO C DO ID=1,ND ABSO1(ID)=0. EMIS1(ID)=0. SCAT1(ID)=ELSCAT(ID) DABT1(ID)=0. DEMT1(ID)=0. DABN1(ID)=SIGEC(IJ) DEMN1(ID)=0. ABSFF(ID)=0. DABFT(ID)=0. DABFN(ID)=0. DO II=1,NLEVEL DABP1(II,ID)=0. DEMP1(II,ID)=0. END DO END DO C C basic frequency- and depth-dependent quantities C FR=FREQ(IJ) lfre=fr.gt.frtabm FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV DO ID=1,ND XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) END DO C C ******** 1a. bound-free contribution - without dielectronic rec. C if(ifdiel.eq.0) then DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) iad=iadop(iatm(ii)) lcomop=iad.eq.0.or.(lfre.and.iad.gt.0) SG=CROSS(IBFT,IJ) IF(SG.GT.0..and.lcomop) THEN II=ILOW(ITR) JJ=IUP(ITR) IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF if(iifix(iatm(ii)).le.0) then DEMT1(ID)=DEMT1(ID)+EMISBF*DEMLT(ITR,ID) DEMN1(ID)=DEMN1(ID)+EMISBF*ELEC1(ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+EMISBF*POPINV(JJ,ID) if(ipzero(ii,id).eq.0) DABP1(II,ID)=DABP1(II,ID)+SGD end if END DO END IF END DO C C ******** 1b. bound-free contribution - with dielectronic rec. C else DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) SG=CROSS(IBFT,IJ) iad=iadop(iatm(ii)) lcomop=iad.eq.0.or.(lfre.and.iad.gt.0) IF(SG.GT.0..and.lcomop) THEN JJ=IUP(ITR) IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SG=CROSSD(IBFT,IJ,ID) if(sg.gt.0.) then SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF if(iifix(iatm(ii)).le.0) then DEMT1(ID)=DEMT1(ID)+EMISBF*DEMLT(ITR,ID) DEMN1(ID)=DEMN1(ID)+EMISBF*ELEC1(ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+EMISBF*POPINV(JJ,ID) if(ipzero(ii,id).eq.0) DABP1(II,ID)=DABP1(II,ID)+SGD end if end if END DO END IF END DO end if C C ******** 2. free-free contribution C DO 40 ION=1,NION II=NNEXT(ION) IT=ITRA(II,II) C C hydrogenic (with Gaunt factor = 1 for IT=1; exact for IT=2) C (derivative of Gaunt factor wrt T is neglected) C iad=iadop(iatm(nnext(ion))) if(iad.gt.0.and..not.lfre) go to 40 IF(IT.LE.2) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) DSF2=DSFF(ION,ID) IF(FR.LT.FF(ION)) THEN SF2=UN/XKF(ID) DSF2=(HKT1(ID)*FR+HALF)*TEMP1(ID) END IF IF(IT.EQ.2) THEN X=C14*CHARG2(ION)/FR SF2=SF2-UN+GFREE1(ID,X) ELSE IF(IT.EQ.3) THEN CALL GFREED(ID,FR,CHARG2(ION),GFR,DGFR) SF2=SF2-UN+GFR DSF2=DSF2-(DGFR-(GFR-UN)*TEMP1(ID)*HALF)/SF2 END IF ABSOFF=SF1*SF2 ABSFF(ID)=ABSFF(ID)+ABSOFF if(iifix(iatm(ii)).eq.0) then DABFT(ID)=DABFT(ID)-ABSOFF*DSF2 DABFN(ID)=DABFN(ID)+ABSOFF*ELEC1(ID) DABPP=ABSOFF*POPINV(II,ID) DABP1(II,ID)=DABP1(II,ID)+DABPP DEMP1(II,ID)=DEMP1(II,ID)+DABPP end if END DO C C H minus free-free opacity C (all derivatives are neglected) C ELSE IF(IT.EQ.3) THEN DO ID=1,ND ABSOFF=SFFHMI(POPUL(NFIRST(IELH),ID),FR,TEMP(ID))* * ELEC(ID) ABSFF(ID)=ABSFF(ID)+ABSOFF END DO C C special evaluation of the cross-section C (all derivatives are neglected) C ELSE IF(IT.LT.0) THEN DO ID=1,ND ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)* * POPUL(NNEXT(ION),ID)*ELEC(ID) ABSFF(ID)=ABSFF(ID)+ABSOFF END DO END IF 40 CONTINUE C ******** 3. - additional opacity (OPADD) C IF(IOPADD.NE.0) THEN ICALL=1 DO ID=1,ND CALL OPADD(0,ICALL,IJ,ID) ABSO1(ID)=ABSO1(ID)+ABAD EMIS1(ID)=EMIS1(ID)+EMAD SCAT1(ID)=SCAT1(ID)+SCAD DABT1(ID)=DABT1(ID)+DAT DEMT1(ID)=DEMT1(ID)+DET DABN1(ID)=DABN1(ID)+DAN DEMN1(ID)=DEMN1(ID)+DEN END DO END IF C C ----------------------- C total continuum opacity C ----------------------- C DO ID=1,ND ABSO1(ID)=ABSO1(ID)+ABSFF(ID) DABT1(ID)=DABT1(ID)+DABFT(ID) DABN1(ID)=DABN1(ID)+DABFN(ID) EMIS1(ID)=EMIS1(ID)+ABSFF(ID) DEMT1(ID)=DEMT1(ID)+DABFT(ID) DEMN1(ID)=DEMN1(ID)+DABFN(ID) END DO C C ******** 4. - opacity and emissivity in lines C LASER=ITER.GT.ITLAS IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN ITR=IJLIN(IJ) iad=iadop(iatm(ilow(itr))) if(iad.eq.0.or.(lfre.and.iad.gt.0)) then C C the "primary" line at the given frequency C ITR=IJLIN(IJ) II=ILOW(ITR) JJ=IUP(ITR) DO 50 ID=1,ND SG=PRFLIN(ID,IJ) SGPI=SG*ABTRA(ITR,ID) IF(SGPI.LE.0.AND.LASER) GO TO 50 SGPJ=SG*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGPI EMIS1(ID)=EMIS1(ID)+SGPJ if(iifix(iatm(ii)).gt.0) go to 50 DEMT1(ID)=DEMT1(ID)+SGPJ*DEMLT(ITR,ID) DABP1(II,ID)=DABP1(II,ID)+SGPI*POPINV(II,ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+SGPJ*POPINV(JJ,ID) 50 CONTINUE end if ENDIF IF(NLINES(IJ).LE.0) GO TO 200 C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) if(linexp(itr)) goto 100 II=ILOW(ITR) JJ=IUP(ITR) IJ0=IFR0(ITR) iad=iadop(iatm(ii)) if(iad.gt.0.and..not.lfre) go to 100 DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 DO 80 ID=1,ND SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) SGPI=SG*ABTRA(ITR,ID) IF(SGPI.LE.0.AND.LASER) GO TO 80 SGPJ=SG*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGPI EMIS1(ID)=EMIS1(ID)+SGPJ if(iifix(iatm(ii)).gt.0) go to 80 DEMT1(ID)=DEMT1(ID)+SGPJ*DEMLT(ITR,ID) DABP1(II,ID)=DABP1(II,ID)+SGPI*POPINV(II,ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+SGPJ*POPINV(JJ,ID) 80 CONTINUE 100 CONTINUE 200 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 400 DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) II=ILOW(ITR) JJ=IUP(ITR) iad=iadop(iatm(ii)) if(iad.gt.0.and..not.lfre) go to 300 KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO 310 ID=1,ND SGPI=PRFLIN(ID,KJ)*ABTRA(ITR,ID) IF(SGPI.LE.0.AND.LASER) GO TO 310 SGPJ=PRFLIN(ID,KJ)*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGPI EMIS1(ID)=EMIS1(ID)+SGPJ if(iifix(iatm(ii)).gt.0) go to 310 DEMT1(ID)=DEMT1(ID)+SGPJ*DEMLT(ITR,ID) DABP1(II,ID)=DABP1(II,ID)+SGPI*POPINV(II,ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+SGPJ*POPINV(JJ,ID) 310 CONTINUE ELSE DO 320 ID=1,ND KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))* * SIGFE(KJD+1,KJ)) SGPI=SG*ABTRA(ITR,ID) IF(SGPI.LE.0.AND.LASER) GO TO 320 SGPJ=SG*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGPI EMIS1(ID)=EMIS1(ID)+SGPJ if(iifix(iatm(ii)).gt.0) go to 320 DEMT1(ID)=DEMT1(ID)+SGPJ*DEMLT(ITR,ID) DABP1(II,ID)=DABP1(II,ID)+SGPI*POPINV(II,ID) DEMP1(JJ,ID)=DEMP1(JJ,ID)+SGPJ*POPINV(JJ,ID) 320 CONTINUE END IF 300 CONTINUE 400 CONTINUE END IF C c Lyman alpha and beta quasimolecular opacity c call quasim(ij) C C ------------------------------------------ C total opacity, emissivity, and derivatives C ------------------------------------------ C DO ID=1,ND DEMT1(ID)=DEMT1(ID)+EMIS1(ID)*FR*HKT21(ID) ABSO1(ID)=ABSO1(ID)-EMIS1(ID)*XKF(ID)+SCAT1(ID) DABN1(ID)=DABN1(ID)-DEMN1(ID)*XKF(ID) DABT1(ID)=DABT1(ID)-DEMT1(ID)*XKF(ID) EMIS1(ID)=EMIS1(ID)*XKFB(ID) DEMN1(ID)=DEMN1(ID)*XKFB(ID) DEMT1(ID)=DEMT1(ID)*XKFB(ID) DO II=1,NLEVEL DABP1(II,ID)=DABP1(II,ID)-DEMP1(II,ID)*XKF(ID) DEMP1(II,ID)=DEMP1(II,ID)*XKFB(ID) END DO absot(id)=abso1(id) END DO c IF(IOPLYM.GT.0) CALL LYMLIN(IJ) if(ifprd.gt.0) call prd(ij) C C --------------------------------------------- C C derivatives in the linearized explicit levels C IF(NLVEXP.LT.NLEVEL) THEN DO ID=1,ND DO I=1,NLVEXP DABP0(I)=0. DEMP0(I)=0. END DO DO I=1,NLEVEL if(iifix(iatm(i)).eq.0) then II=IIEXP(I) IF(II.GT.0) THEN DABP0(II)=DABP0(II)+DABP1(I,ID) DEMP0(II)=DEMP0(II)+DEMP1(I,ID) ELSE IF(II.LT.0) THEN DABP0(-II)=DABP0(-II)+DABP1(I,ID)*PP(I,ID) DEMP0(-II)=DEMP0(-II)+DEMP1(I,ID)*PP(I,ID) ELSE JJ=IIEXP(ILTREF(I,ID)) if(jj.gt.0) then DABP0(JJ)=DABP0(JJ)+DABP1(I,ID)*PP(I,ID) DEMP0(JJ)=DEMP0(JJ)+DEMP1(I,ID)*PP(I,ID) endif IF(IABS(IMODL(I)).LE.5) THEN DABT1(ID)=DABT1(ID)+DABP1(I,ID)*PT(I,ID) DEMT1(ID)=DEMT1(ID)+DEMP1(I,ID)*PT(I,ID) DABN1(ID)=DABN1(ID)+DABP1(I,ID)*PN(I,ID) DEMN1(ID)=DEMN1(ID)+DEMP1(I,ID)*PN(I,ID) END IF END IF end if END DO DO II=1,NLVEXP DABP1(II,ID)=DABP0(II) DEMP1(II,ID)=DEMP0(II) END DO END DO END IF c c contribution from the background opacity table c if(ioptab.gt.0) then c imodf=0 FR=FREQ(IJ) if(fr.lt.frtabm) then DO ID=1,ND T=TEMP(ID) T1=T*(UN+DELT) RHO=DENS(ID) RHO1=RHO*(UN+DELR) PLAN=XKFB(ID)/XKF1(ID) DPLAN=PLAN/XKF1(ID)*HKT1(ID)*FR/T CALL OPCTAB(FR,IJ,ID,T,RHO,AB,SC,SCT,imodf) CALL OPCTAB(FR,IJ,ID,T1,RHO,AB1,SC1,SCT1,imodf) CALL OPCTAB(FR,IJ,ID,T,RHO1,AB2,SC2,SCT2,imodf) ABSO1(ID)=ABSO1(id)+AB EMIS1(ID)=EMIS1(ID)+AB*PLAN scat1(id)=scat1(id)+sct c c derivatives w.r.t. temperature c DABTAB=(AB1-AB)/T/DELT dabtab=0. DABT1(ID)=DABT1(ID)+DABTAB DEMT1(ID)=DEMT1(ID)+AB*DPLAN+DABTAB*PLAN DSCT1(ID)=DSCT1(ID)+(SCT1-SCT)/T/DELT dabt1(id)=dabt1(id)+dsct1(id) c c derivatives w.r.t. density c DABN1A(ID)=(AB2-AB)/RHO/DELR DEMN1A(ID)=DABN1(ID)*PLAN c DSCN1A(ID)=(SCT2-SCT)/RHO/DELR c dabn1A(id)=dabn1a(id)+dscn1a(id) DABN1A(ID)=0. DEMN1A(ID)=0. DSCN1A(ID)=0. c c modify derivatives in case density is not a state parameter c IF(INHE.LE.0) THEN DABT1(ID)=DABT1(ID)+DABN1A(ID)*DRHODT(ID) DEMT1(ID)=DEMT1(ID)+DEMN1A(ID)*DRHODT(ID) DSCT1(ID)=DSCT1(ID)+DSCN1A(ID)*DRHODT(ID) ELSE DABN1(ID)=DABN1(ID)+DABN1A(ID) DEMN1(ID)=DEMN1(ID)+DEMN1A(ID) DSCN1(ID)=DSCN1(ID)+DSCN1A(ID) END IF c if(ifryb.gt.5) then abso1(id)=abso1(id)/dens(id) emis1(id)=emis1(id)/dens(id) scat1(id)=scat1(id)/dens(id) dabt1(id)=dabt1(id)/dens(id) demt1(id)=demt1(id)/dens(id) dsct1(id)=dsct1(id)/dens(id) end if c END DO end if end if c c if needed, evaluate the opacity per gram c if(izscal.eq.0) then do id=1,nd absot(id)=abso1(id)/dens(id) end do id=1 c if(mod(ij,1000).le.3) c * write(*,*) '+++++++opacfd',ij,abso1(id),absot(id) end if C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0) RETURN IJE=IJEX(IJ) DO ID=1,ND ABSOEX(IJE,ID)=ABSO1(ID) EMISEX(IJE,ID)=EMIS1(ID) SCATEX(IJE,ID)=SCAT1(ID) DABTEX(IJE,ID)=DABT1(ID) DEMTEX(IJE,ID)=DEMT1(ID) DABNEX(IJE,ID)=DABN1(ID) DEMNEX(IJE,ID)=DEMN1(ID) DABMEX(IJE,ID)=DABM1(ID) DEMMEX(IJE,ID)=DEMM1(ID) DO II=1,NLVEXP DRCHEX(II,IJE,ID)=DABP1(II,ID) DRETEX(II,IJE,ID)=DEMP1(II,ID) END DO END DO C RETURN END C C C **************************************************************** C C SUBROUTINE ALIFR1(IJ) C ===================== C C hydrostatic and radiative equilibrium quantities - C derivatives of the total heating and cooling rates in the C ALI points with respect to the C temperature, electron density, and populations C a variant for consistent tridiagonal operator C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (T23=TWO/3.D0, T43=4.D0/3.D0) DIMENSION DSFP1(MLVEXP),DSFP1M(MLVEXP),DSFP1D(MLVEXP), * DSFP1P(MLVEXP),DSFPMM(MLVEXP) C IF(IFALI.LE.1) RETURN IF(IFALI.GT.5) THEN CALL ALIFR3(IJ) RETURN END IF WW=WC(IJ) C DSFT1M=0. DSFN1M=0. DSFM1M=0. DSFT1D=0. DSFN1D=0. DSFM1D=0. DSFX1=0. DSFX1D=0. DO II=1,NLVEXP DSFP1M(II)=0. DSFP1D(II)=0. END DO c Non-standard value of ILASCT & ILMCOR IF(ILMCOR.NE.3) GO TO 199 c c ****1. Special expressions for the first depth - id=1 c ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c if(emis1(id).lt.1.e-35) emis1(id)=1.e-35 EMISIV=UN/EMIS1(ID) ABST=UN/ABSO1(ID) S0=EMIS1(ID)*ABST c SC=ELEC(ID)*SIGEC(IJ) c c contribution from the improved boundary condition c dt=(abso1(id)/dens(id)+abso1(id+1)/dens(id+1))* * (dm(id+1)-dm(id))*half sa=s0*(un+4./dt*q0(ij)) s0=s0*(un+two/dt*q0(ij)) c sa=s0 sc=scat1(id) SCT=SC*ABST ST=S0+SCT*RAD1(ID) CORR=UN/(UN-ALI1(ID)*SCT) DSFT1=CORR*(S0*DEMT1(ID)*EMISIV-S0*DABT1(ID)*ABST) DSFN1=CORR*(S0*DEMN1(ID)*EMISIV c +SIGEC(IJ)*RAD1(ID)*ABST- * -S0*DABN1(ID)*ABST) DSFM1=CORR*(S0*DEMM1(ID)*EMISIV-S0*DABM1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=CORR*(S0*DEMP1(II,ID)*EMISIV-SA*DABP1(II,ID)*ABST) END DO if(emis1(id+1).lt.1.e-35) emis1(id+1)=1.e-35 EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP scp=scat1(id+1) SCTP=SCP*ABSTP STP=S0P+SCTP*RAD1(ID+1) CORRP=UN/(UN-ALI1(ID+1)*SCTP) DSFT1P=CORRP*(S0P*DEMT1(ID+1)*EMISIP-S0P*DABT1(ID+1)*ABSTP) DSFN1P=CORRP*(S0P*DEMN1(ID+1)*EMISIP * -S0P*DABN1(ID+1)*ABSTP) DSFM1P=CORRP*(S0P*DEMM1(ID+1)*EMISIP-S0P*DABM1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=CORRP*(S0P*DEMP1(II,ID+1)*EMISIP- * S0P*DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) DSFDM(ID)=DSFM1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) HEIM(ID)=HEIM(ID)+D0*DSFM1+E0*DABM1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) FLRD(ID)=FLRD(ID)+W(IJ)*FH(IJ)*RAD1(ID)-W(IJ)*HALF*EXTRAD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 REDM(ID)=REDM(ID)+WF*DSFM1 REDX(ID)=REDX(ID)+WF*DSFX1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) D0=ABST*ALI1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIT(ID)=REIT(ID)+WW*(D0*DSFT1+RAD1(ID)*DABT1(ID)-DEMT1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ & RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) REIM(ID)=REIM(ID)+WW*(D0*DSFM1+RAD1(ID)*DABM1(ID)-DEMM1(ID)) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ & RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DSFMMM=DSFM1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DSFM1M=DSFM1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DSFM1=DSFM1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO c if(emis1(id+1).lt.1.e-35) emis1(id+1)=1.e-35 EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP scp=scat1(id+1) SCTP=SCP*ABSTP STP=S0P+SCTP*RAD1(ID+1) CORRP=UN/(UN-ALI1(ID+1)*SCTP) DSFT1P=CORRP*(S0P*DEMT1(ID+1)*EMISIP-S0P*DABT1(ID+1)*ABSTP) DSFN1P=CORRP*(S0P*DEMN1(ID+1)*EMISIP * -S0P*DABN1(ID+1)*ABSTP) DSFM1P=CORRP*(S0P*DEMM1(ID+1)*EMISIP-STP*DABM1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=CORRP*(S0P*DEMP1(II,ID+1)*EMISIP- * S0P*DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) DSFDM(ID)=DSFM1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEIM(ID)=HEIM(ID)+D0*DSFM1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M HEIMM(ID)=HEIMM(ID)+E0*DSFM1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL FLRD(ID)=FLRD(ID)+W(IJ)*FL IF(REDIF(ID).GT.0) THEN if(ifalih.eq.0) then D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) REDM(ID)=REDM(ID)+D0*DSFM1-E0*DABM1(ID) REDMM(ID)=REDMM(ID)+D0M*DSFM1M-E0M*DABM1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO else d0=ww*alih1(id) REDT(ID)=REDT(ID)+D0*DSFT1 REDN(ID)=REDN(ID)+D0*DSFN1 REDM(ID)=REDM(ID)+D0*DSFM1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II) END DO end if END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) D0=ABST*ALI1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ * RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ * RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) END DO REIT(ID)=REIT(ID)+WW*(D0*DSFT1+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)) REIM(ID)=REIM(ID)+WW*(D0*DSFM1+ * RAD1(ID)*DABM1(ID)-DEMM1(ID)) END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DSFMMM=DSFM1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DSFM1M=DSFM1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DSFM1=DSFM1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO DSFT1D=0. DSFN1D=0. DSFM1D=0. DO II=1,NLVEXP DSFP1D(II)=0. END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) DSFDM(ID)=DSFM1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEIM(ID)=HEIM(ID)+D0*DSFM1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M HEIMM(ID)=HEIMM(ID)+E0*DSFM1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D HEIMM(ID)=HEIMM(ID)-D0*DSFM1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL FLRD(ID)=FLRD(ID)+W(IJ)*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) REDM(ID)=REDM(ID)+D0*DSFM1-E0*DABM1(ID) REDMM(ID)=REDMM(ID)+D0M*DSFM1M-E0M*DABM1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D REDMM(ID)=REDMM(ID)+D0*DSFM1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) D0=ABST*ALI1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ * RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) REIM(ID)=REIM(ID)+WW*(D0*DSFM1+RAD1(ID)*DABM1(ID)-DEMM1(ID)) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ * RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) END DO IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+WW*(D0*DSFT1+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)) ELSE REIT(ID)=REIT(ID)+WW*(D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)+ * ALI1(ID)/ABST*DBDT) END IF END IF RETURN c Non-standard value of ILASCT & ILMCOR 199 IF(ILASCT.NE.0) GO TO 299 c c ****1. Special expressions for the first depth - id=1 c ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) ABST=UN/(ABSO1(ID)-ELSCAT(ID)) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-(DABN1(ID)-SIGEC(IJ))*ABST) DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) FLRD(ID)=FLRD(ID)+W(IJ)*FH(IJ)*RAD1(ID)-W(IJ)*HALF*EXTRAD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) ELSE REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * ALI1(ID)/ABST*DBDT END IF DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF RETURN C Non-standard value of ILASCT (ILASCT != 0) c c ****1. Special expressions for the first depth - id=1 c 299 ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) ABST=UN/ABSO1(ID) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-DABN1(ID)*ABST) DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) FLRD(ID)=FLRD(ID)+W(IJ)*FH(IJ)*RAD1(ID)-W(IJ)*HALF*EXTRAD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) c F0=D0*ALIP1(ID) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) ELSE REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * ALI1(ID)/ABST*DBDT END IF DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE ALIFR3(IJ) C ===================== C C hydrostatic and radiative equilibrium quantities - C derivatives of the total heating and cooling rates in the C ALI points with respect to the C temperature, electron density, and populations C a variant for consistent tridiagonal operator C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (T23=TWO/3.D0, T43=4.D0/3.D0) DIMENSION DSFP1(MLVEXP),DSFP1M(MLVEXP),DSFP1D(MLVEXP), * DSFP1P(MLVEXP),DSFPMM(MLVEXP) C IF(IFALI.LE.1) RETURN WW=WC(IJ) C DSFT1M=0. DSFN1M=0. DSFT1D=0. DSFN1D=0. DO II=1,NLVEXP DSFP1M(II)=0. DSFP1D(II)=0. END DO c Non-standard value of ILASCT & ILMCOR IF(ILMCOR.NE.3) GO TO 199 c c ****1. Special expressions for the first depth - id=1 c ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) ABST=UN/ABSO1(ID) S0=EMIS1(ID)*ABST SC=ELEC(ID)*SIGEC(IJ) SCT=SC*ABST ST=S0+SCT*RAD1(ID) CORR=UN/(UN-ALI1(ID)*SCT) DSFT1=CORR*(S0*DEMT1(ID)*EMISIV-ST*DABT1(ID)*ABST) DSFN1=CORR*(S0*DEMN1(ID)*EMISIV+SIGEC(IJ)*RAD1(ID)*ABST- * ST*DABN1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=CORR*(S0*DEMP1(II,ID)*EMISIV-ST*DABP1(II,ID)*ABST) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP SCP=ELEC(ID+1)*SIGE SCTP=SCP*ABSTP STP=S0P+SCTP*RAD1(ID+1) CORRP=UN/(UN-ALI1(ID+1)*SCTP) DSFT1P=CORRP*(S0P*DEMT1(ID+1)*EMISIP-STP*DABT1(ID+1)*ABSTP) DSFN1P=CORRP*(S0P*DEMN1(ID+1)*EMISIP+SIGEC(IJ)*RAD1(ID+1)*ABSTP- * STP*DABN1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=CORRP*(S0P*DEMP1(II,ID+1)*EMISIP- * STP*DABP1(II,ID+1)*ABSTP) END DO C C C additional quantites in case of external irradiation C extd=extrad(ij) if(extd.gt.0) then DT=UN/(DELDMZ(ID)*(ABSOT(ID)+ABSOT(ID+1))) D0=TWO*HEXTRD(IJ)*DT*DT E0=D0*DELDMZ(ID)*DENSI(ID) E1=D0*DELDMZ(ID+1)*DENSI(ID+1) DSFT1=DSFT1-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DSFX1=E0*ABSO1(ID)*DENSIM(ID) DSFT1D=DSFT1D-E1*DABT1(ID+1) DSFN1D=DSFN1D-E1*(DABN1(ID+1)+ABSO1(ID+1)*DENSIM(ID+1)) DSFX1D=E1*ABSO1(ID+1)*DENSIM(ID+1) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) DSFP1D(II)=DSFP1D(II)-E0*DABP1(II,ID+1) END DO end if c IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) DSFDTM(ID)=DSFT1M*ALIM1(ID) DSFDNM(ID)=DSFN1M*ALIM1(ID) DSFDTP(ID)=DSFT1P*ALIP1(ID) DSFDNP(ID)=DSFN1P*ALIP1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID) DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO redtp(id)=redtp(id)+wf*dsft1d rednp(id)=rednp(id)+wf*dsfn1d END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) D0=ABST*ALI1(ID) WWKC=WW*ABST*ALIP1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ * RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) CREIT(ID)=CREIT(ID)+WWKC*DSFT1P CREIN(ID)=CREIN(ID)+WWKC*DSFN1P DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ * RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II) END DO REIT(ID)=REIT(ID)+WW*(D0*DSFT1+RAD1(ID)*DABT1(ID)-DEMT1(ID)) if(extd.gt.0.) then creit(id)=creit(id)+ww*d0*dsft1d crein(id)=crein(id)+ww*d0*dsfn1d end if END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP SCP=ELEC(ID+1)*SIGEC(IJ) SCTP=SCP*ABSTP STP=S0P+SCTP*RAD1(ID+1) CORRP=UN/(UN-ALI1(ID+1)*SCTP) DSFT1P=CORRP*(S0P*DEMT1(ID+1)*EMISIP-STP*DABT1(ID+1)*ABSTP) DSFN1P=CORRP*(S0P*DEMN1(ID+1)*EMISIP+SIGEC(IJ)*RAD1(ID+1)*ABSTP- & STP*DABN1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=CORRP*(S0P*DEMP1(II,ID+1)*EMISIP- & STP*DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN if(ifalih.eq.0) then D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO else d0=ww*alih1(id) REDT(ID)=REDT(ID)+D0*DSFT1 REDN(ID)=REDN(ID)+D0*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II) END DO end if END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN WWK=WW*ABST WWKA=WWK*ALIM1(ID) WWKC=WWK*ALIP1(ID) ABST=ABSO1(ID)-ELSCAT(ID) D0=ABST*ALI1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ * RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ * RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II) CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II) END DO REIT(ID)=REIT(ID)+WW*(D0*DSFT1+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)) AREIT(ID)=AREIT(ID)+WWKA*DSFT1M AREIN(ID)=AREIN(ID)+WWKA*DSFN1M CREIT(ID)=CREIT(ID)+WWKC*DSFT1P CREIN(ID)=CREIN(ID)+WWKC*DSFN1P END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) DSFDTM(ID)=DSFT1M*ALIM1(ID) DSFDNM(ID)=DSFN1M*ALIM1(ID) DSFDTP(ID)=DSFT1P*ALIP1(ID) DSFDNP(ID)=DSFN1P*ALIP1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID) DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWKA=WW*ABST*ALIM1(ID) D0=ABST*ALI1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) REIN(ID)=REIN(ID)+WW*(D0*DSFN1+ * RAD1(ID)*(DABN1(ID)-SIGEC(IJ))-DEMN1(ID)) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+WW*(D0*DSFP1(II)+ * RAD1(ID)*DABP1(II,ID)-DEMP1(II,ID)) AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II) END DO IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+WW*(D0*DSFT1+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)) ELSE REIT(ID)=REIT(ID)+WW*(D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * RAD1(ID)*DABT1(ID)-DEMT1(ID)+ * ALI1(ID)/ABST*DBDT) END IF AREIT(ID)=AREIT(ID)+WWKA*DSFT1M AREIN(ID)=AREIN(ID)+WWKA*DSFN1M END IF RETURN c Non-standard value of ILASCT & ILMCOR 199 IF(ILASCT.NE.0) GO TO 299 c c ****1. Special expressions for the first depth - id=1 c ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) ABST=UN/(ABSO1(ID)-ELSCAT(ID)) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-(DABN1(ID)-SIGEC(IJ))*ABST) DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) ELSE REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * ALI1(ID)/ABST*DBDT END IF DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF RETURN C Non-standard value of ILASCT (ILASCT != 0) c c ****1. Special expressions for the first depth - id=1 c 299 ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) ABST=UN/ABSO1(ID) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-DABN1(ID)*ABST) DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) ELSE REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * ALI1(ID)/ABST*DBDT END IF DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE ALIFR6(IJ) C ===================== C C hydrostatic and radiative equilibrium quantities - C derivatives of the total heating and cooling rates in the C ALI points with respect to the C temperature, electron density, and populations C a variant for consistent tridiagonal operator C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (T23=TWO/3.D0, T43=4.D0/3.D0) DIMENSION DSFP1(MLVEXP),DSFP1M(MLVEXP),DSFP1D(MLVEXP), * DSFP1P(MLVEXP),DSFPMM(MLVEXP) C WW=WC(IJ) C DSFT1M=0. DSFN1M=0. DO II=1,NLVEXP DSFP1M(II)=0. END DO c c ****1. Special expressions for the first depth - id=1 c ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) c c Basic auxliliary quantities - derivatives of the source function c EMISIV=UN/EMIS1(ID) if(ilmcor.ne.3) then if(ilasct.eq.0) then ABST=UN/(ABSO1(ID)-ELSCAT(ID)) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-(DABN1(ID)-SIGEC(IJ))*ABST) else ABST=UN/ABSO1(ID) S0=EMIS1(ID)*ABST DSFN1=S0*(DEMN1(ID)*EMISIV-DABN1(ID)*ABST) end if DSFT1=S0*(DEMT1(ID)*EMISIV-DABT1(ID)*ABST) DO II=1,NLVEXP DSFP1(II)=S0*(DEMP1(II,ID)*EMISIV-DABP1(II,ID)*ABST) END DO C c correction for electron scattering source function contribution c else abst=un/abso1(id) s0=emis1(id)*abst sc=elec(id)*sigeC(IJ) sct=sc*abst st=s0+sct*rad1(id) corr=un/(un-ali1(id)*sct) dsft1=corr*(s0*demt1(id)*emisiv-st*dabt1(id)*abst) dsfn1=corr*(s0*demn1(id)*emisiv+sigeC(IJ)*rad1(id)*abst- * st*dabn1(id)*abst) do ii=1,nlvexp dsfp1(ii)=corr*(s0*demp1(ii,id)*emisiv- * st*dabp1(ii,id)*abst) end do end if EMISIP=UN/EMIS1(ID+1) if(ilmcor.ne.3) then if(ilasct.eq.0) then ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) else ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) end if DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO else abstp=un/abso1(id+1) s0p=emis1(id+1)*abstp scp=elec(id+1)*sigeC(IJ) sctp=scp*abstp stp=s0p+sctp*rad1(id+1) corrp=un/(un-ali1(id+1)*sctp) dsft1p=corrp*(s0p*demt1(id+1)*emisip-stp*dabt1(id+1)*abstp) dsfn1p=corrp*(s0p*demn1(id+1)*emisip+sigeC(IJ)*rad1(id+1)*abstp- * stp*dabn1(id+1)*abstp) do ii=1,nlvexp dsfp1p(ii)=corrp*(s0p*demp1(ii,id+1)*emisip- * stp*dabp1(ii,id+1)*abstp) end do end if IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDTM(ID)=DSFT1M*ALIM1(ID) DSFDNM(ID)=DSFN1M*ALIM1(ID) DSFDTP(ID)=DSFT1P*ALIP1(ID) DSFDNP(ID)=DSFN1P*ALIP1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID) DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID) END DO END IF c c Hydrostatic equilibrium quantities c WF=WW*FH(IJ) IF(LNSKIP) THEN FPRD(ID)=FPRD(ID)+WF*ABSO1(ID)*RAD1(ID)- * WW*HEXTRD(IJ)*ABSO1(ID) E0=WF*RAD1(ID) D0=WF*ABSO1(ID)*ALI1(ID) HEIT(ID)=HEIT(ID)+D0*DSFT1+E0*DABT1(ID) HEIN(ID)=HEIN(ID)+D0*DSFN1+E0*DABN1(ID) DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO IF(IFALI.GE.7) THEN D0P=WF*ABSO1(ID)*ALIP1(ID) HEITP(ID)=HEITP(ID)+D0P*DSFT1P HEINP(ID)=HEINP(ID)+D0P*DSFN1P DO II=1,NLVEXP HEIPP(II,ID)=HEIPP(II,ID)+D0P*DSFP1P(II) END DO END IF END IF c c Differential equation part of radiative equilibrium c FLFIX(ID)=FLFIX(ID)+WF*RAD1(ID)-WW*HEXTRD(IJ) IF(REDIF(ID).GT.0.) THEN WF=WF*ALI1(ID) REDT(ID)=REDT(ID)+WF*DSFT1 REDN(ID)=REDN(ID)+WF*DSFN1 DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+WF*DSFP1(II) END DO END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN if(ilmcor.ne.3) then if(ilasct.eq.0) then ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) else SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) end if REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO else abst=abso1(id)-elscat(id) d0=abst*ali1(id) fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id)) rein(id)=rein(id)+ww*(d0*dsfn1+ * rad1(id)*(dabn1(id)-sigeC(IJ))-demn1(id)) do ii=1,nlvexp reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+ * rad1(id)*dabp1(ii,id)-demp1(ii,id)) end do reit(id)=reit(id)+ww*(d0*dsft1+ * rad1(id)*dabt1(id)-demt1(id)) end if c c the following are needed only for tridiagonal Lambda^star C C Upper sub-diagonal band C WWKC=WWK*ALIP1(ID) CREIT(ID)=CREIT(ID)+WWKC*DSFT1P CREIN(ID)=CREIN(ID)+WWKC*DSFN1P DO II=1,NLVEXP CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II) END DO END IF C c ****2. loop over depths c DO ID=2,ND-1 LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO EMISIP=UN/EMIS1(ID+1) if(ilmcor.ne.3) then if(ilasct.eq.0) then ABSTP=UN/(ABSO1(ID+1)-ELSCAT(ID+1)) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-(DABN1(ID+1)-SIGEC(IJ))*ABSTP) else ABSTP=UN/ABSO1(ID+1) S0P=EMIS1(ID+1)*ABSTP DSFN1P=S0P*(DEMN1(ID+1)*EMISIP-DABN1(ID+1)*ABSTP) end if DSFT1P=S0P*(DEMT1(ID+1)*EMISIP-DABT1(ID+1)*ABSTP) DO II=1,NLVEXP DSFP1P(II)=S0P*(DEMP1(II,ID+1)*EMISIP-DABP1(II,ID+1)*ABSTP) END DO else abstp=un/abso1(id+1) s0p=emis1(id+1)*abstp scp=elec(id+1)*sigeC(IJ) sctp=scp*abstp stp=s0p+sctp*rad1(id+1) corrp=un/(un-ali1(id+1)*sctp) dsft1p=corrp*(s0p*demt1(id+1)*emisip-stp*dabt1(id+1)*abstp) dsfn1p=corrp*(s0p*demn1(id+1)*emisip+sigeC(IJ)*rad1(id+1)*abstp- * stp*dabn1(id+1)*abstp) do ii=1,nlvexp dsfp1p(ii)=corrp*(s0p*demp1(ii,id+1)*emisip- * stp*dabp1(ii,id+1)*abstp) end do end if IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDTM(ID)=DSFT1M*ALIM1(ID) DSFDNM(ID)=DSFN1M*ALIM1(ID) DSFDTP(ID)=DSFT1P*ALIP1(ID) DSFDNP(ID)=DSFN1P*ALIP1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID) DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) F0=D0*ALIP1(ID) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IFALI.GE.7) THEN HEITP(ID)=HEITP(ID)+F0*DSFT1P HEINP(ID)=HEINP(ID)+F0*DSFN1P DO II=1,NLVEXP HEIPP(II,ID)=HEIPP(II,ID)+F0*DSFP1P(II) END DO A0M=A0*ALIM1(ID-1) EHET(ID)=EHET(ID)-A0M*DSFTMM EHEN(ID)=EHEN(ID)-A0M*DSFNMM DO II=1,NLVEXP EHEP(II,ID)=EHEP(II,ID)-A0M*DSFPMM(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IFALI.GE.7) THEN REDTP(ID)=REDTP(ID)+D0P*DSFT1M REDNP(ID)=REDNP(ID)+D0P*DSFN1M DO II=1,NLVEXP REDPP(II,ID)=REDPP(II,ID)+D0P*DSFP1P(II) END DO A0M=A0*ALIM1(ID-1) ERET(ID)=ERET(ID)-A0M*DSFTMM EREN(ID)=EREN(ID)-A0M*DSFNMM DO II=1,NLVEXP EREP(II,ID)=EREP(II,ID)-A0M*DSFPMM(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN if(ilmcor.ne.3) then if(ilasct.eq.0) then ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) else SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)- * WW*SIGE*RAD1(ID) end if REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO else abst=abso1(id)-elscat(id) d0=abst*ali1(id) fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id)) rein(id)=rein(id)+ww*(d0*dsfn1+ * rad1(id)*(dabn1(id)-sige)-demn1(id)) do ii=1,nlvexp reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+ * rad1(id)*dabp1(ii,id)-demp1(ii,id)) end do reit(id)=reit(id)+ww*(d0*dsft1+ * rad1(id)*dabt1(id)-demt1(id)) end if c c the following are needed only for tridiagonal Lambda^star C C Lower sub-diagonal band C WWKA=WWK*ALIM1(ID) AREIT(ID)=AREIT(ID)+WWKA*DSFT1M AREIN(ID)=AREIN(ID)+WWKA*DSFN1M DO II=1,NLVEXP AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II) END DO C C Upper sub-diagonal band C WWKC=WWK*ALIP1(ID) CREIT(ID)=CREIT(ID)+WWKC*DSFT1P CREIN(ID)=CREIN(ID)+WWKC*DSFN1P DO II=1,NLVEXP CREIP(II,ID)=CREIP(II,ID)+WWKC*DSFP1P(II) END DO END IF END DO C c ****3. deepest point - ID=ND c ID=ND LNSKIP=.NOT.LSKIP(ID,IJ) DSFTMM=DSFT1M DSFNMM=DSFN1M DO II=1,NLVEXP DSFPMM(II)=DSFP1M(II) END DO DSFT1M=DSFT1 DSFN1M=DSFN1 DO II=1,NLVEXP DSFP1M(II)=DSFP1(II) END DO S0=S0P DSFT1=DSFT1P DSFN1=DSFN1P DO II=1,NLVEXP DSFP1(II)=DSFP1P(II) END DO C C Improved lower boundary condition C IF(IBC.GT.0.AND.IDISK.EQ.0) THEN DT=UN/(DELDMZ(ID-1)*(ABSOT(ID)+ABSOT(ID-1))) PLAD=XKFB(ID)/XKF1(ID) DBDT=PLAD/XKF1(ID)*HKT21(ID)*FREQ(IJ)*DT IF(IBC.EQ.1) THEN DSFT1=DSFT1+DBDT ELSE IF(IBC.GE.2) THEN PLAM=XKFB(ID-1)/XKF1(ID-1) TAU23=T23*DT TAU43=T43*DT D0=(PLAD*(UN+TAU43)-T43*PLAM*DT)*DT*DT RHD=DELDMZ(ID-1)*DENSI(ID) E0=D0*RHD DSFT1=DSFT1+DBDT*(UN+TAU23)-E0*DABT1(ID) DSFN1=DSFN1-E0*(DABN1(ID)+ABSO1(ID)*DENSIM(ID)) DO II=1,NLVEXP DSFP1(II)=DSFP1(II)-E0*DABP1(II,ID) END DO IF(IBC.GE.3) THEN DBDTM=PLAM/XKF1(ID-1)*HKT21(ID-1)*FREQ(IJ)*DT RHD=DELDMZ(ID-1)*DENSI(ID-1) E0=D0*RHD DSFT1D=-DBDTM*DT*T23-E0*DABT1(ID-1) DSFN1D=-E0*(DABN1(ID-1)+ABSO1(ID-1)*DENSIM(ID-1)) DO II=1,NLVEXP DSFP1D(II)=-E0*DABP1(II,ID-1) END DO END IF END IF END IF C IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDT(ID)=DSFT1*ALI1(ID) DSFDN(ID)=DSFN1*ALI1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDP(II,ID)=DSFP1(II)*ALI1(ID) END DO END IF IF(IRDER.EQ.1.OR.IRDER.EQ.3) THEN DSFDTM(ID)=DSFT1M*ALIM1(ID) DSFDNM(ID)=DSFN1M*ALIM1(ID) DSFDTP(ID)=DSFT1P*ALIP1(ID) DSFDNP(ID)=DSFN1P*ALIP1(ID) END IF IF(IRDER.GT.1) THEN DO II=1,NLVEXP DSFDPM(II,ID)=DSFP1M(II)*ALIM1(ID) DSFDPP(II,ID)=DSFP1P(II)*ALIP1(ID) END DO END IF c c Hydrostatic equilibrium equation c IF(LNSKIP) THEN D0=WW*FAK1(ID) A0=WW*FAK1(ID-1) FPRD(ID)=FPRD(ID)+D0*RAD1(ID)-A0*RAD1(ID-1) F0=D0*ALIP1(ID) E0=D0*ALIM1(ID)-A0*ALI1(ID-1) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) HEIT(ID)=HEIT(ID)+D0*DSFT1 HEIN(ID)=HEIN(ID)+D0*DSFN1 HEITM(ID)=HEITM(ID)+E0*DSFT1M HEINM(ID)=HEINM(ID)+E0*DSFN1M DO II=1,NLVEXP HEIP(II,ID)=HEIP(II,ID)+D0*DSFP1(II) HEIPM(II,ID)=HEIPM(II,ID)+E0*DSFP1M(II) END DO IF(IFALI.GE.7) THEN HEITP(ID)=HEITP(ID)+F0*DSFT1P HEINP(ID)=HEINP(ID)+F0*DSFN1P DO II=1,NLVEXP HEIPP(II,ID)=HEIPP(II,ID)+F0*DSFP1P(II) END DO A0M=A0*ALIM1(ID-1) EHET(ID)=EHET(ID)-A0M*DSFTMM EHEN(ID)=EHEN(ID)-A0M*DSFNMM DO II=1,NLVEXP EHEP(II,ID)=EHEP(II,ID)-A0M*DSFPMM(II) END DO END IF IF(IBC.GE.3) THEN HEITM(ID)=HEITM(ID)-D0*DSFT1D HEINM(ID)=HEINM(ID)-D0*DSFN1D DO II=1,NLVEXP HEIPM(II,ID)=HEIPM(II,ID)-D0*DSFP1D(II) END DO END IF END IF C C Differential equation part of radiative equilibrium C DDT=UN/(ABSOT(ID)+ABSOT(ID-1)) DT=DDT/DELDMZ(ID-1) FL=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))*DT FLFIX(ID)=FLFIX(ID)+WW*FL IF(REDIF(ID).GT.0) THEN D0=WW*FAK1(ID)*DT A0=WW*FAK1(ID-1)*DT D0M=D0*ALIM1(ID)-A0*ALI1(ID-1) D0P=D0*ALIP1(ID) D0=D0*ALI1(ID)-A0*ALIP1(ID-1) E0=WW*FL*DDT REDX(ID)=REDX(ID)+E0*ABSO1(ID) REDXM(ID)=REDXM(ID)+E0*ABSO1(ID-1) E0M=E0*DENSI(ID-1) E0=E0*DENSI(ID) REDT(ID)=REDT(ID)+D0*DSFT1-E0*DABT1(ID) REDTM(ID)=REDTM(ID)+D0M*DSFT1M-E0M*DABT1(ID-1) REDN(ID)=REDN(ID)+D0*DSFN1-E0*DABN1(ID) REDNM(ID)=REDNM(ID)+D0M*DSFN1M-E0M*DABN1(ID-1) DO II=1,NLVEXP REDP(II,ID)=REDP(II,ID)+D0*DSFP1(II)-E0*DABP1(II,ID) REDPM(II,ID)=REDPM(II,ID)+D0M*DSFP1M(II)- * E0M*DABP1(II,ID-1) END DO IF(IFALI.GE.7) THEN REDTP(ID)=REDTP(ID)+D0P*DSFT1M REDNP(ID)=REDNP(ID)+D0P*DSFN1M DO II=1,NLVEXP REDPP(II,ID)=REDPP(II,ID)+D0P*DSFP1P(II) END DO A0M=A0*ALIM1(ID-1) ERET(ID)=ERET(ID)-A0M*DSFTMM EREN(ID)=EREN(ID)-A0M*DSFNMM DO II=1,NLVEXP EREP(II,ID)=EREP(II,ID)-A0M*DSFPMM(II) END DO END IF IF(IBC.GE.3) THEN REDTM(ID)=REDTM(ID)+D0*DSFT1D REDNM(ID)=REDNM(ID)+D0*DSFN1D DO II=1,NLVEXP REDPM(II,ID)=REDPM(II,ID)+D0*DSFP1D(II) END DO END IF END IF c C Integral equation part of the radiative equilibrium C IF(REINT(ID).GT.0) THEN if(ilmcor.ne.3) then if(ilasct.eq.0) then ABST=ABSO1(ID)-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) D0=WW*(ALI1(ID)-UN)*ABST E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*(DABN1(ID)-SIGEC(IJ)) else SRH=SIGE*DENS1(ID) ABST=ABSO1(ID) ABSTE=ABST-ELSCAT(ID) WWK=WW*ABST FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABSTE*RAD1(ID)) D0=WW*(ABSTE*ALI1(ID)-ABST) E0=WW*(RAD1(ID)-S0) REIN(ID)=REIN(ID)+D0*DSFN1+E0*DABN1(ID)-WW*SIGEC(IJ)*RAD1(ID) end if IF(IBC.EQ.0) THEN REIT(ID)=REIT(ID)+D0*DSFT1+E0*DABT1(ID) ELSE REIT(ID)=REIT(ID)+D0*(DSFT1-DBDT)+E0*DABT1(ID)+ * ALI1(ID)/ABST*DBDT END IF DO II=1,NLVEXP REIP(II,ID)=REIP(II,ID)+D0*DSFP1(II)+E0*DABP1(II,ID) END DO else abst=abso1(id)-elscat(id) d0=abst*ali1(id) fcooli(id)=fcooli(id)+ww*(emis1(id)-abst*rad1(id)) rein(id)=rein(id)+ww*(d0*dsfn1+ * rad1(id)*(dabn1(id)-sigeC(IJ))-demn1(id)) do ii=1,nlvexp reip(ii,id)=reip(ii,id)+ww*(d0*dsfp1(ii)+ * rad1(id)*dabp1(ii,id)-demp1(ii,id)) end do if(ibc.eq.0) then reit(id)=reit(id)+ww*(d0*dsft1+ * rad1(id)*dabt1(id)-demt1(id)) else reit(id)=reit(id)+ww*(d0*(dsft1-dbdt)+e0*dabt1(id)+ * rad1(id)*dabt1(id)-demt1(id)+ * ali1(id)/abst*dbdt) end if end if c c the following are needed only for tridiagonal Lambda^star C C Lower sub-diagonal band C WWKA=WWK*ALIM1(ID) AREIT(ID)=AREIT(ID)+WWKA*DSFT1M AREIN(ID)=AREIN(ID)+WWKA*DSFN1M DO II=1,NLVEXP AREIP(II,ID)=AREIP(II,ID)+WWKA*DSFP1M(II) END DO END IF RETURN END C C C C **************************************************************** C C SUBROUTINE ALIFRK(IJ) C ===================== C C Simplified routine ALIFR1 for a Kantorovich iteration C C hydrostatic and radiative equilibrium quantities - C derivatives of the total heating and cooling rates in the C ALI points with respect to the C temperature, electron density, and populations C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION WFL(MDEPTH) C if(ifali.le.1) return WW=WC(IJ) c **** Special expressions for the first depth - id=1 ID=1 LNSKIP=.NOT.LSKIP(ID,IJ) WF=WW*(FH(IJ)*RAD1(ID)-HEXTRD(IJ)) IF(LNSKIP) FPRD(ID)=FPRD(ID)+WF*ABSO1(ID) FLFIX(ID)=FLFIX(ID)+WF FLRD(ID)=FLRD(ID)+W(IJ)*(FH(IJ)*RAD1(ID)-HALF*EXTRAD(IJ)) IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-SCAT1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) END IF c Loop over depths DO ID=2,ND LNSKIP=.NOT.LSKIP(ID,IJ) DT=UN/((ABSOT(ID)+ABSOT(ID-1))*DELDMZ(ID-1)) FL=RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1) WFL(ID)=WW*FL IF(LNSKIP) FPRD(ID)=FPRD(ID)+WFL(ID) FLFIX(ID)=FLFIX(ID)+WFL(ID)*DT FLRD(ID)=FLRD(ID)+FL*W(IJ)*DT IF(REINT(ID).GT.0) THEN ABST=ABSO1(ID)-SCAT1(ID) FCOOLI(ID)=FCOOLI(ID)+WW*(EMIS1(ID)-ABST*RAD1(ID)) END IF END DO RETURN END C C C **************************************************************** C C SUBROUTINE EMAT(ID) C =================== C C Auxiliary procedure for SOLVE C C sub-sub-diagonal band matrix E C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' C IF(IFALI.LE.7) RETURN IF(ID.LE.2) RETURN NSE=NFREQE+INSE-1 IF(INHE.GT.0) THEN NHE=NFREQE+INHE IF(INRE.GT.0) E(NHE,NFREQE+INRE)=EHET(ID)*PCK IF(INPC.GT.0) E(NHE,NFREQE+INPC)=EHEN(ID)*PCK DO II=1,NLVEXP E(NHE,NSE+II)=EHEP(II,ID)*PCK END DO END IF C IF(INRE.GT.0.AND.REDIF(ID).GT.0.) THEN NRE=NFREQE+INRE IF(INRE.GT.0) E(NRE,NRE)=ERET(ID)*REDIF(ID) IF(INPC.GT.0) E(NRE,NFREQE+INPC)=EREN(ID)*REDIF(ID) DO II=1,NLVEXP E(NRE,NSE+II)=EREP(II,ID)*REDIF(ID) END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE RHSGEN(ID) C ===================== C C Auxiliary procedure for SOLVE C controls evaluation of rhs vector when C matrices A,B, and C are kept fixed. C C Input: ID - depth index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0) C DIMENSION AJ(MLEVEL) DIMENSION POPP(MLEVEL) COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD C ispl=isplin if(isplin.ge.5) isplin=isplin-5 IJ1=1 C C in the case of Compton scattering - boundary condition C for the highest frequency C if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) then IJ1=2 ij=1 iji=nfreq zj1=exp(-hk*freq(ij)/temp(id)) zj2=exp(-hk*freq(ij+1)/temp(id)) dlt=delj(iji-1,id) if(ichcoo.eq.0) then zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id)) zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2 combid=zj0/dlnfr(iji-1)+(un-dlt)*zxx comaid=-zj0/dlnfr(iji-1)+dlt*zxx else e2=ycon*temp(id) zxx0=xcon*freq(ij)*(un+zj1)-3.*e2 zxxm=xcon*freq(ij+1)*(un+zj2)-3.*e2 zxx=(un-dlt)*zxx0+dlt*zxxm combid=e2/dlnfr(iji-1)+(un-dlt)*zxx comaid=-e2/dlnfr(iji-1)+dlt*zxx end if vecl(ij)=-combid*rad(iji,id)-comaid*rad(iji-1,id) end if C C evaluation of the opacity, emissivity, scattering, and C their derivatives, at the current depth point ID; C DO I=1,NN PSI0(I)=PSY0(I,ID) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) WDEP0(IJ)=W(IJT) RAD0(IJ)=RADEX(IJ,ID) FK0(IJ)=FAKEX(IJ,ID) ABSO0(IJ)=ABSOEX(IJ,ID) EMIS0(IJ)=EMISEX(IJ,ID) SCAT0(IJ)=SCATEX(IJ,ID) END DO END IF C IF(ID.GT.1) THEN DO I=1,NN PSIM(I)=PSY0(I,ID-1) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) RADM(IJ)=RADEX(IJ,ID-1) FKM(IJ)=FAKEX(IJ,ID-1) ABSOM(IJ)=ABSOEX(IJ,ID-1) EMISM(IJ)=EMISEX(IJ,ID-1) SCATM(IJ)=SCATEX(IJ,ID-1) END DO END IF END IF C IF(ID.LT.ND) THEN DO I=1,NN PSIP(I)=PSY0(I,ID+1) END DO IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) RADP(IJ)=RADEX(IJ,ID+1) FKP(IJ)=FAKEX(IJ,ID+1) ABSOP(IJ)=ABSOEX(IJ,ID+1) EMISP(IJ)=EMISEX(IJ,ID+1) SCATP(IJ)=SCATEX(IJ,ID+1) END DO END IF END IF c C C ------------------------------------------------------------ C Actual evaluation of the rhs vector VECL C ------------------------------------------------------------ C DO I=1,NN VECL(I)=0. END DO C IF(NFREQE.LE.0) GO TO 100 C C ----------------------------------------------------------- C 1. Radiative transfer components C ----------------------------------------------------------- C C For ID = 1 - upper boundary condition C IF(ID.GT.1) GO TO 50 DDP=DELDMZ(1) DO IJ=1,NFREQE IJT=IJFR(IJ) IF(IZSCAL.EQ.0) THEN OMEG0=ABSO0(IJ)/DENS(ID) OMEGP=ABSOP(IJ)/DENS(ID+1) ELSE OMEG0=ABSO0(IJ) OMEGP=ABSOP(IJ) END IF DZP=OMEG0+OMEGP DTAUP=DZP*DDP ALF1=(FK0(IJ)*RAD0(IJ)-FKP(IJ)*RADP(IJ))/DTAUP CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) BS=HALF*DTAUP CS=0. C2=0. SP=0. BET2=0. GAM2=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(ISPLIN.GT.0) THEN C C Spline collocation and/or Hermitian method (ISPLIN=1 or 2) - C both give the same expression for the boundary conditions C BS=DTAUP*THIRD CS=HALF*BS SP=(EMISP(IJ)+CHIELP*RADP(IJ))/ABSOP(IJ) C2=CS/ABSOP(IJ) GAM2=CS*(RADP(IJ)-SP) END IF C C auxiliary quantities C ALF2=BS*(RAD0(IJ)-S0) BET2=ALF2+GAM2 C C *** the IJ-th element of the rhs vector C VECL(IJ)=ALF1+BET2+FH(IJT)*RAD0(IJ)-S0*Q0(IJT) IF(IWINBL.LT.0) VECL(IJ)=VECL(IJ)-HEXTRD(IJT) C END DO GO TO 100 C C For 1 < ID < ND - normal depth point C 50 DDM=DELDMZ(ID-1) IF(ID.EQ.ND) GO TO 80 DDP=DELDMZ(ID) DO IJ=1,NFREQE IF(IZSCAL.EQ.0) THEN OMEG0=ABSO0(IJ)/DENS(ID) OMEGP=ABSOP(IJ)/DENS(ID+1) OMEGM=ABSOM(IJ)/DENS(ID-1) ELSE OMEG0=ABSO0(IJ) OMEGP=ABSOP(IJ) OMEGM=ABSOM(IJ) END IF DZP=OMEG0+OMEGP DZM=OMEG0+OMEGM DTAUP=DZP*DDP DTAUM=DZM*DDM DTAU0=HALF*(DTAUP+DTAUM) FRD=FK0(IJ)*RAD0(IJ) ALF1=(FRD-FKP(IJ)*RADP(IJ))/DTAUP/DTAU0 GAM1=(FRD-FKM(IJ)*RADM(IJ))/DTAUM/DTAU0 BET1=ALF1+GAM1 BS=UN CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) CHIELP=SCATP(IJ) S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) BET2=0. c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C IF(ISPLIN.EQ.1) THEN C C spline collocation (ISPLIN=1) C AS=DTAUM/DTAU0*SIXTH CS=DTAUP/DTAU0*SIXTH BS=0.666666666666667D0 SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ) SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ) ALF2=AS*(RADM(IJ)-SM) GAM2=CS*(RADP(IJ)-SP) BET2=ALF2+GAM2 ELSE IF(ISPLIN.EQ.2) THEN C C Hermitian method (ISPLIN=2) C AS=DTAUP*DTAUP/DTAUM/DTAU0 CS=DTAUM*DTAUM/DTAUP/DTAU0 SM=(EMISM(IJ)+RADM(IJ)*CHIELM)/ABSOM(IJ) SP=(EMISP(IJ)+RADP(IJ)*CHIELP)/ABSOP(IJ) AS=(UN-HALF*AS)*SIXTH CS=(UN-HALF*CS)*SIXTH BS=UN-AS-CS BET2=AS*(RADM(IJ)-SM)+CS*(RADP(IJ)-SP) END IF C C *** the IJ-th element of the rhs vector C VECL(IJ)=BET1+BET2+BS*(RAD0(IJ)-S0) C END DO GO TO 100 C C For ID=ND - lower boundary condition C 80 T=TEMP(ID) IF(TEMPBD.GT.0.) T=TEMPBD HKT=HK/T C c the case of stellar atmospheres C IF(IDISK.EQ.0.OR.IFZ0.LT.0) THEN C C 1. the case NDRE.le.ND, ie. radiative equilibrium equation at this C depth is treated as differential equation. C C 2. the case NDRE > ND, ie. radiative equilibrium equation at this C depth is treated as integral equation. C Boundary condition of the transfer equation is then complex, C because it has to incorporate the constraint of the total flux C equal to SIG4P*Teff**4 (integral form of the radiative C equation does not fix the total flux) C C Details of this approach are presented in Mihalas, Heasley, Auer C NCAR-TN/STR-104 (1975). C C This option is presented here for the sake of continuity with C previous work; otherwise the first option (NDRE.le.ND) is C recommended due to its better numerical properties C C auxiliary quantities for the second option C IF(ID.LT.NDRE.AND.INRE.NE.0) THEN SUMB=0. SUMF=0. DO IJ=1,NFREQE IJT=IJFR(IJ) FR=FREQ(IJT) FR15=FR*1.D-15 WD=WDEP0(IJ) X=HKT*FR EX=EXP(X) PLAN=BN*FR15*FR15*FR15/(EX-UN)*RRDIL DPLAN=PLAN*X/T/(UN-UN/EX)*WD SUMB=SUMB+(PLAN-RAD0(IJ))*WD FI=DPLAN/ABSO0(IJ) SUMF=SUMF+FI END DO FL=SIG4P*TEFF*TEFF*TEFF*TEFF ZZ=(FL-HALF*SUMB)/SUMF END IF C C auxiliary quantities for both options C DO IJ=1,NFREQE IJT=IJFR(IJ) CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) IF(IZSCAL.EQ.0) THEN OMEG0=ABSO0(IJ)/DENS(ID) OMEGM=ABSOM(IJ)/DENS(ID-1) ELSE OMEG0=ABSO0(IJ) OMEGM=ABSOM(IJ) END IF DZM=OMEG0+OMEGM DTAUM=DZM*DDM GAM1=(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))/DTAUM BET2=0. C C second-order boundary condition C IF(IBC.GT.0.AND.IBC.LT.4) THEN BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) c c additional terms for Compton scattering c if(icompt.gt.0) then call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) s0=s0+cms end if C BET2=BS*(RAD0(IJ)-S0) END IF C FR=FREQ(IJT) X=HKT*FR EX=EXP(X) PLAN=BN*(FR*1.D-15)**3/(EX-UN)*RRDIL IF(INRE.EQ.0.OR.ID.GE.NDRE) THEN DPLAN=BN*(FR*1.D-15)**3/(EXP(HK*FR/TEMP(ID-1))-UN) GAM1=GAM1-(PLAN-DPLAN)/DTAUM*THIRD ELSE DPLAN=PLAN*X/T/(UN-UN/EX) FI=DPLAN/ABSO0(IJ) X1=FI*ZZ GAM1=GAM1-X1 END IF C C *** the IJ-th element of the rhs vector C IF(IBC.EQ.0.OR.IBC.EQ.4) THEN VECL(IJ)=GAM1+BET2-HALF*(PLAN-RAD0(IJ)) ELSE VECL(IJ)=GAM1+BET2-HALF*PLAN+FHD(IJT)*RAD0(IJ) END IF END DO C C the case of accretion disks C ELSE C DO IJ=IJ1,NFREQE CHIELM=SCATM(IJ) CHIEL0=SCAT0(IJ) IF(IZSCAL.EQ.0) THEN OMEG0=ABSO0(IJ)/DENS(ID) OMEGM=ABSOM(IJ)/DENS(ID-1) ELSE OMEG0=ABSO0(IJ) OMEGM=ABSOM(IJ) END IF DZM=OMEG0+OMEGM DTAUM=DZM*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAM1=FRD/DTAUM BS=DTAUM*HALF S0=(EMIS0(IJ)+CHIEL0*RAD0(IJ))/ABSO0(IJ) GAM2=BS*(RAD0(IJ)-S0) C C *** the IJ-th element of the rhs vector C VECL(IJ)=GAM1+GAM2 END DO END IF C C ----------------------------------------------------------- C 2. Hydrostatic equilibrium C ----------------------------------------------------------- C 100 isplin=ispl IF(INHE.EQ.0) GO TO 170 NHE=NFREQE+INHE GRD=0. C IF(ID.EQ.1) THEN C C Upper boundary condition (ID=1) C Basically, linearized eq. (7-10) of Mihalas (1978) C IF(IDISK.EQ.0.OR.IBCHE.EQ.0) THEN IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*FH(IJT)*RAD0(IJ) GRD=GRD+FLUXW*ABSO0(IJ) END IF END DO END IF C X1=PCK/DENS(ID) VT0=HALF*VTURB(ID)*VTURB(ID)/DM(ID)*WMM(ID) C C The rhs vector also accounts for the total radiation pressure in C the fixed-option transitions (array FPRD, generated by FIXLIN) C VECL(NHE)=GRAV-BOLK*TEMP(ID)*PSI0(NHE)/DM(ID)- * X1*(GRD+FPRD(ID))-VT0/WMM(ID)*DENS(ID) C ELSE IF(IBCHE.EQ.1) THEN C C specifically disk - newer variant C CCC=PCK/QGRAV HR1=CCC*SIG4P*TEFF**4*ABROSD(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-PR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF GGG=DENS(1)*HG1*F1 VECL(NHE)=DM(1)-GGG C C specifically disk - older variant C ELSE IF(IBCHE.EQ.2) THEN IF(NFREQE.GT.0) THEN DO IJ=IJ1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*FH(IJT)*RAD0(IJ) GRD=GRD+FLUXW*ABSO0(IJ) END IF END DO END IF C CCC=PCK/QGRAV PR1=CCC*(GRD+FPRD(1))/DENS(1) PG1=BOLK*PSI0(NHE)*TEMP(1) HG1=SQRT(TWO*PG1/DENS(1)/QGRAV) X=(ZD(1)-PR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF GGG=HG1*QGRAV*HALF/F1 C C The rhs vector C VECL(NHE)=DM(1)*GGG-PG1 ELSE VECL(NHE)=PGAS0-BOLK*TEMP(1)*PSI0(NHE) END IF END IF C ELSE C C Normal depth point (ID > 1) C C IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IF(.NOT.LSKIP(ID,IJFR(IJ))) * GRD=GRD+(FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ))*W(IJFR(IJ)) END DO END IF C VT0=HALF*VTURB(ID)*VTURB(ID)*WMM(ID) VTM=HALF*VTURB(ID-1)*VTURB(ID-1)*WMM(ID-1) C C the rhs vector C again, which accounts for the total radiation pressure in the C fixed-option transitions (array FPRD, generated by FIXLIN) C IF(IDISK.EQ.1) GRAV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF IF(IZSCAL.EQ.0) THEN VECL(NHE)=GRAV*(DM(ID)-DM(ID-1))- * BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))- * PCK*(GRD+FPRD(ID))- * VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID-1)*DENS(ID-1) ELSE GRAVZ=GRAV*(ZD(ID)-ZD(ID-1)) VECL(NHE)=-GRAVZ*(DENS(ID)+DENS(ID-1))*HALF- * BOLK*(TEMP(ID)*PSI0(NHE)-TEMP(ID-1)*PSIM(NHE))- * PCK*(GRD+FPRD(ID))- * VT0/WMM(ID)*DENS(ID)+VTM/WMM(ID-1)*DENS(ID-1) END IF END IF C C ----------------------------------------------------------- C 2a. z-m relation C ----------------------------------------------------------- C 170 IF(INZD.LE.0.OR.ID.EQ.ND.OR.IDISK.EQ.0) GO TO 200 NZD=NFREQE+INZD DDP=(DM(ID+1)-DM(ID))*HALF VECL(NZD)=ZD(ID+1)-ZD(ID)+DDP/DENS(ID)+DDP/DENS(ID+1) C C ----------------------------------------------------------- C 3. Radiative equilibrium C ----------------------------------------------------------- C 200 IF(INRE.EQ.0) GO TO 250 NRE=NFREQE+INRE c ittc=abs(nretc)/100 if(iter.gt.ittc) then if(id.le.mod(abs(nretc),100)) then if(nretc.lt.0) vecl(nre)=temp(id+1)-temp(id) go to 250 end if end if C C integral equation part of the radiative C equilibrium equation C C the rhs vector accounts for total net cooling in ALI transitions C VECL(NRE)=FCOOL(ID) IF(IDISK.EQ.1) VECL(NRE)=FCOOL(ID)-TVISC(ID)*reint(id) C IF(REINT(ID).GT.0.AND.NFREQE.GT.0) THEN DO IJ=1,NFREQE HEAT=ABSO0(IJ)-SCAT0(IJ) VECL(NRE)=VECL(NRE)- * (HEAT*RAD0(IJ)-EMIS0(IJ))*WDEP0(IJ)*reint(id) c c additional terms for Compton scattering c if(icompt.gt.5) then ijt=ijfr(ij) call compt0(ijt,id,abso0(ij),cma,cmb,cmc,cme,cms,cmd) vecl(nre)=vecl(nre)+abso0(ij)*cms*wdep0(ij)*reint(id) end if c END DO END IF C C C differential equation part of the C radiative equilibrium equation C if(redif(id).gt.0) then TEFFD=TEFF**4 IF(IDISK.EQ.1) TEFFD=TEFFD*(UN-THETAV(ID)) VECL(NRE)=vecl(nre)+SIG4P*TEFFD*redif(id) IF(ID.GT.1) THEN DDM=(DM(ID)-DM(ID-1))*HALF DDM=DELDMZ(ID-1) IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE OMEG0=ABSO0(IJ)*DENSI(ID) OMEGM=ABSOM(IJ)*DENSI(ID-1) DTAUM=(OMEG0+OMEGM)*DDM FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GAMR=FRD/DTAUM VECL(NRE)=VECL(NRE)-WDEP0(IJ)*GAMR*redif(id) END DO END IF ELSE IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) VECL(NRE)=VECL(NRE)- * WDEP0(IJ)*FH(IJT)*RAD0(IJ)*REDIF(ID) END DO END IF END IF end if C C ----------------------------------------------------------- C 4. Statistical equilibrium C ----------------------------------------------------------- C 250 IF(IABS(IFPOPR).GE.3.and.ifpopr.le.5) THEN if(inse.gt.0) then NSE=NFREQE+INSE-1 CALL SABOLF(ID) CALL LEVGRP(ID,IIEXP,0,POPP) CALL RATMAT(ID,IIEXP,0,ESEMAT,BESE) IF(IFPOPR.LE.3) THEN CALL MATINV(ESEMAT,NLVEXP,MLEVEL) DO I=1,NLVEXP SUM=0. DO J=1,NLVEXP SUM=SUM+ESEMAT(I,J)*BESE(J) END DO VECL(NSE+I)=POPGRP(I)-SUM IF(IGZERO(I,ID).GT.0) VECL(NFREQE+INSE-1+I)=0. END DO ELSE DO I=1,NLVEXP SUM=0. DO J=1,NLVEXP SUM=SUM+ESEMAT(I,J)*POPGRP(J) END DO VECL(NSE+I)=BESE(I)-SUM IF(IGZERO(I,ID).GT.0) VECL(NFREQE+INSE-1+I)=0. END DO END IF end if END IF C C ----------------------------------------------------------- C 5. charge conservation C ----------------------------------------------------------- C IF(INPC.EQ.0) GO TO 400 NPC=NFREQE+INPC C C This part is very similar to procedure ELCOR (obviously); C array AJ has the meaning of coefficients of the charge conserv. C ie. charge conservation is written C AJ * (vector of populations) = electron density C T=TEMP(ID) ANE=ELEC(ID) CALL STATE(2,ID,T,ANE) C VPC=QFIX(ID)+Q*DENS(ID)/WMM(ID)/YTOT(ID) IF(IOPTAB.EQ.0) VPC=VPC*ABUND(IATREF,ID) DO IAT=1,NATOM IF(IIFIX(IAT).NE.1) THEN DO I=N0A(IAT),NKA(IAT) IL=ILK(I) CH=IZ(IEL(I))-1 IF(IL.GT.0) CH=IZ(IL)+(IZ(IL)-1)*ANE*USUMS(IL,ID) IF(IMODL(I).GE.0) VPC=VPC+CH*POPUL(I,ID) END DO END IF END DO C VECL(NPC)=ANE-VPC C C ----------------------------------------------------------- C 6. Convection C ----------------------------------------------------------- C 400 IF(HMIX0.gt.0.) then NRE=NFREQE+INRE NDEL=NFREQE+INDL C C Upper boundary condition (ID=1) C ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) IF(ID.EQ.1) THEN DELTA(ID)=0. FLXC(ID)=0. ELSE C C Normal depth point 1 < ID < ND C T=TEMP(ID) P=PTOTAL(ID) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 TM=TEMP(ID-1) PM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 T0=HALF*(T+TM) P0=HALF*(P+PM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 DELTA(ID)=DLT IF(INDL.GT.0) VECL(NDEL)=DELTA(ID)-DLT IF(IDISK.EQ.1) GRAVD=ZD(ID)*QGRAV C C convective flux C CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON) FLXC(ID)=FLXCNV if(redif(id).gt.0) then VECL(NRE)=VECL(NRE)-FLXC(ID)*redif(id) end if C if(reint(id).gt.0.AND.ICONV.LE.2) then TP=TEMP(ID+1) PM=PTOTAL(ID+1) PGP=PGS(ID+1) PRADP=PM-PGP-HALF*DENS(ID+1)*VTURB(ID+1)**2 T0=HALF*(T+TP) P0=HALF*(P+PM) PG0=HALF*(PG+PGP) PR0=HALF*(PRAD+PRADP) AB0=HALF*(ABROSD(ID)+ABROSD(ID+1)) DLT=(TP-T)/(PM-P)*(PM+P)/(TP+T) CALL CONVEC(ID+1,T0,P0,PG0,PR0,AB0,DLT,FLXCP,VCON) DELM=(DM(ID+1)-DM(ID))*HALF RDELM=DENS(ID)/DELM VECL(NRE)=VECL(NRE)-RDELM*(FLXCP-FLXCNV)*reint(id) end if END IF END IF C C skip rows corresponding to fully-zeroed populations C NSE=NFREQE+INSE INONZ=NSE DO II=NSE,NN0 IF(IGZERT(II-NSE+1).EQ.0) THEN IF(INONZ.NE.II) VECL(INONZ)=VECL(II) INONZ=INONZ+1 END IF END DO C RETURN END C C C C **************************************************************** C C SUBROUTINE PRCHAN(CHANG,CHM,CHMT) C ================================= C C Diagnostic output of relative changes of vector PSI C C Input: C CHANG - array of relative changes of vector PSI at depth ID C ID - depth index C Output: C CHM - maximum relative change of all unknowns at all depths C CHMT - maximum relative change in temperature at all depths C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' DIMENSION CHANG(MTOT,MDEPTH),CHANM(MDEPTH) C C maximum relative change of all unknowns in depth ID C CHMT=0. I1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) i1=2 DO ID=ND,1,-1 CH=0. chrad=0. chpop=0. cht=0. che=0. DO 10 I=i1,NN IF(ITER.EQ.1.AND.I.EQ.NFREQE+INDL) GO TO 10 IF(I.GE.NFREQE+INSE) THEN II=INDLGZ(I-NFREQE-INSE+1) IF(RPOP0(II,ID).LT.POPZCH) GO TO 10 END IF IF(ABS(CHANG(I,ID)).LT.ABS(CH)) GO TO 10 CH=CHANG(I,ID) 10 CONTINUE CHANM(ID)=CH IF(NFREQE.GT.0) THEN DO 11 I=i1,NFREQE IF(ABS(CHANG(I,ID)).LT.ABS(CHRAD)) GO TO 11 CHRAD=CHANG(I,ID) jjr=i 11 CONTINUE END IF DO 12 I=NFREQE+INSE,NFREQE+INSE+NLVEXZ-1 II=INDLGZ(I-NFREQE-INSE+1) IF(RPOP0(II,ID).LT.POPZCH) GO TO 12 IF(ABS(CHANG(I,ID)).LT.ABS(CHPOP)) GO TO 12 CHpop=CHANG(I,ID) jjp=ii 12 CONTINUE if(inre.gt.0) then cht=chang(nfreqe+inre,id) if(abs(cht).ge.abs(chmt)) chmt=abs(cht) end if if(inpc.gt.0) che=chang(nfreqe+inpc,id) C C output onto file 9 C IF(ID.EQ.ND.AND.ITER.EQ.1) WRITE(9,800) WRITE(9,801) ITER,ID,cht,che,CHpop,CHrad,ch,jjp,jjr 800 FORMAT(' RELATIVE CHANGES OF VECTOR PSI'/ * ' ITER ID TEMP NE POP RAD MAXIMUM', * ' ilev ifr',/) 801 FORMAT(2I5,1P5e10.2,2i5) END DO C C determination of the maximum relative change of all unknowns C at all depths C CHM=0. DO I=1,ND IF(ABS(CHANM(I)).GE.ABS(CHM)) CHM=CHANM(I) END DO C if(chmt.lt.chmaxt) then do itl=iter,niter+1 nitlam(itl)=nlamt end do end if RETURN END C C C **************************************************************** C C SUBROUTINE OPADD(MODE,ICALL,IJ,ID) C ================================== C C Additional opacities C This is basically user-supplied procedure; here are some more C important non-standard opacity sources, namely C Rayleigh scattering, H- opacity, H2+ opacity, and additional C opacity of He I and He II. C Inclusion of these opacities is contolled by switches transmitted C by COMMON/OPCKEY - see description in START. C C Input parameters: C MODE - controls the nature and the amount of calculations C = -1 - (OPADD called from START) evaluation of relevant C depth-dependent quantities (usually photoionization C cross-sections, but also possibly other), which are C stored in array CROS C = 0 - evaluation of an additional opacity, emissivity, and C scattering - for procedure OPACF1 C = 1 - the same, but also derivatives wrt temperature, C electron density, and level populations C IJ - frequency index C ID - depth index C C Output: transmitted by COMMON/OPACAD: C C ABAD - absorption coefficient (at frequency point IJ and depth ID) C EMAD - emission coefficient (at frequency point IJ and depth ID) C SCAD - scattering coefficient (at frequency point IJ and depth ID) C Dxy - derivatives of x (=A for Absorption, =E for Emission, C =S for scattering) coefficient wrt y (=T for temperature, C =N for electron density) C DDN(I) - quantity proportional to a derivative of absorption (and C emission) coefficient wrt population of I-th level; ie. C d(abs)/d(pop) = DDN * [1-exp(-h*nu/kT)] C d(em)/d(pop) = DDN * (2h*nu**3/c**2)*exp(-h*nu/kT) C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) c PARAMETER (FRRAY = 2.463D15, * FRAYHe= 5.150E15, * FRAYH2= 2.922E15, * CLS = 2.997925e18, * C18 = 2.997925D18, * CR0 = 5.799D-13, * CR1 = 1.422D-6, * CR2 = 2.784D0, * TENM4 = 1.0D-4, * THM0 = 8.7629D3, * SBHM = 1.0353D-16, * TRHA = 1.5D0, * SFF0 = 1.3727D-25, * SFF1 = 4.3748D-10, * SFFM2 = -2.5993D-7, * F0HE1 = 3.29D15, * F0HE2 = 1.316D16, * SBH0 = 4.1412D-16, * SG01 = 2.815D-16, * SG02 = 4.504D-15) SAVE T,DELTAT,ANE,HKT,T32,XHM,POPI,SB00 C AB0=0. AB1=0. DAB0=0. DAB1=0. ABAD=0. EMAD=0. SCAD=0. DBF=0. DFF=0. DAT=0. DET=0. DAN=0. DEN=0. DST=0. DSN=0. DO I=1,NLEVEL DDN(I)=0. END DO C FR=FREQ(IJ) al=2.997925e18/fr lpri=al.gt.1579.0.and.al.lt.1579.5 if(ielh.gt.0) then N0HN=NFIRST(IELH) NKH=NKA(IATH) end if c IF(ICALL.GT.0) THEN T=TEMP(ID) DELTAT=TENM4*T ANE=ELEC(ID) HKT=HK/T T32=UN/T/SQRT(T) XHM=THM0/T if(ielh.gt.0) then ah=popul(n0hn,id) ahp=popul(nkh,id) else ah=anato(1,id) ahp=anion(1,id) end if popi=ah SB00=SBHM*T32*EXP(XHM)*POPI*ANE c if(iathe.gt.0) then ahe=popul(n0a(iathe),id) else ahe=anato(2,id) end if END IF C IT=NCON C C ----------------------- C HI Rayleigh scattering C ----------------------- C IF(IRSCT.NE.0) THEN IT=IT+1 SCAD=AH*CROSS(IT,IJ) END IF C C ----------------------- C He I Rayleigh scattering C ----------------------- C IF(IRSCHE.NE.0.AND.MODE.GE.0) THEN IT=IT+1 scad=scad+ahe*cross(it,ij) END IF C C ----------------------- C H2 Rayleigh scattering C ----------------------- C IF(IRSCH2.NE.0.AND.MODE.GE.0.AND.IFMOL.GT.0) THEN IT=IT+1 sg=cross(it,ij)*anmol(2,id) if(t.lt.tmolim) scad=scad+sg END IF C IF(IOPHMI.GT.0) THEN C C ---------------------------- C H- bound-free and free-free C ---------------------------- C IT=IT+1 if(t.lt.20000.) then SB=SB00*CROSS(IT,IJ) SF=SFFHMI(AH,FR,T)*ANE AB0=SB+SF end if END IF c END IF C IF(IOPH2P.GT.0) THEN C C ----------------------------- C H2+ bound-free and free-free C ----------------------------- C IT=IT+1 X2=-CROSS(IT,IJ)/T+CROSS(IT+1,IJ) IT=IT+1 SB=0. IF(X2.GT.-150..and.fr.lt.3.28e15.and.t.le.9000.) * SB=AH*EXP(X2)*AHP AB0=AB0+SB DAB1=SB*CROSS(IT-1,IJ)/T/T IF(N0HN.GT.0) DDN(N0HN)=DDN(N0HN)+SB/POPI IF(NKH.GT.0) DDN(NKH)=DDN(NKH)+SB/POPUL(NKH,ID) END IF C C ----------------------------- C He- free-free C ----------------------------- C IF(IOPHEM.GT.0) THEN IT=IT+1 sg=cross(it,ij)*t+cross(it+1,ij)+cross(it+2,ij)/t ab0=ab0+sg*ane*ahe END IF C C ----------------------------- C H2- free-free C ----------------------------- C IF(IOPH2M.NE.0.AND.MODE.GE.0.AND.IFMOL.GT.0.AND.T.LT.TMOLIM) THEN call h2minus(t,anmol(2,id),ane,fr,oph2) ab1=ab1+oph2 END IF C C ----------------------------- C CH and OH continuuum opacity C ----------------------------- C if(mode.ge.0.and.ifmol.gt.0.and.t.lt.tmolim) then if(iopch.gt.0) ab0=ab0+sbfch(fr,t)*anmol(5,id) if(iopoh.gt.0) ab0=ab0+sbfoh(fr,t)*anmol(4,id) C C --------------------------- C CIA H2-H2 opacity C --------------------------- C if(ioh2h2.gt.0) then call cia_h2h2(t,anmol(2,id),fr,oph2) ab1=ab1+oph2 end if C C --------------------------- C CIA H2-He opacity C --------------------------- C if(ioh2he.gt.0) then call cia_h2he(t,anmol(2,id),ahe,fr,oph2) ab1=ab1+oph2 end if C C --------------------------- C CIA H2-H opacity C --------------------------- C if(ioh2h.gt.0) then call cia_h2h(t,anmol(2,id),ah,fr,oph2) ab1=ab1+oph2 end if C C --------------------------- C CIA H-He opacity C --------------------------- C if(iohhe.gt.0) then call cia_hhe(t,ah,ahe,fr,oph2) ab1=ab1+oph2 end if end if C C C ---------------------------------------------- C The user may supply more opacity sources here: C ---------------------------------------------- C C Finally, actual absorption and emission coefficients and C their derivatives IF(MODE.LT.0) RETURN X=EXP(-HKT*FR) X1=UN-X FR15=FR*1.D-15 BNX=BN*FR15*FR15*FR15*X AB1=AB1/X1 ABAD=ABAD+AB0+AB1 EMAD=EMAD+AB0+AB1 IF(MODE.EQ.1) THEN HKFT=HKT*FR/T DB=HKFT*AB0 DAT=DAB1 DET=DAB1 DAN=AB0/ANE DEN=AB0/ANE END IF RETURN END C C C **************************************************************** C C C SUBROUTINE OPADD0(IJ) C ====================== C C setting cross secxtion for ondividual addiaopnal opacity sources c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C PARAMETER (FRRAY = 2.463D15, * FRAYHe= 5.150E15, * FRAYH2= 2.922E15, * CLS = 2.997925e18, * CR0 = 5.799D-13, * CR1 = 1.422D-6, * CR2 = 2.784D0) C FR=FREQ(IJ) IF(ISPODF.GE.1) FR=FREQ(IFREQB(IJ)) c IT=NCON C C ----------------------- C HI Rayleigh scattering C ----------------------- C IF(IRSCT.NE.0) THEN IT=IT+1 if(it.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) FRM=MIN(FR,FRRAY) X=(CLS/FRM)**2 BFCS(IT,IJ)=real((CR0+(CR1+CR2/X)/X)/X/X) END IF C C ----------------------- C He I Rayleigh scattering C ----------------------- C IF(IRSCHE.NE.0) THEN IT=IT+1 if(it.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) X=(CLS/MIN(FR,FRAYHe))**2 CS=5.484E-14/X/X*(1.+(2.44E5+5.94E10/(X-2.90E5))/X)**2 BFCS(IT,IJ)=real(CS) END IF C C ----------------------- C H2 Rayleigh scattering C ----------------------- C IF(IRSCH2.NE.0.AND.IFMOL.GT.0) THEN IT=IT+1 if(it.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) X=(CLS/MIN(FR,FRAYH2))**2 X2=1./X/X CS=(8.14E-13+1.28E-6/X+1.61*X2)*X2 BFCS(IT,IJ)=real(CS) END IF C C ---------------------------- C H- bound-free and free-free C ---------------------------- C IF(IOPHMI.GT.0) THEN IT=IT+1 if(it.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) BFCS(IT,IJ)=real(SBFHMI(FR)) END IF C C ----------------------------- C H2+ bound-free and free-free C ----------------------------- C IF(IOPH2P.GT.0) THEN IT=IT+1 if(it+1.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) X=FR*1.D-15 BFCS(IT,IJ)=real((-7.342D-3+(-2.409+(1.028+(-4.23D-1+ * (1.224D-1-1.351D-2*X)*X)*X)*X)*X)*1.602D-12/BOLK) IT=IT+1 X=LOG(FR) CS0=-3.0233D3+(3.7797D2+(-1.82496D1+(3.9207D-1- * 3.1672D-3*X)*X)*X)*X BFCS(IT,IJ)=real(cs0) END IF C C ----------------------------- C He- free-free C ----------------------------- C IF(IOPHEM.GT.0) THEN IT=IT+1 if(it+2.gt.mcross) * CALL QUIT('it.gt.mcross in opadd',it,mcross) A=3.397D-46+(-5.216D-31+7.039D-15/FR)/FR B=-4.116D-42+(1.067D-26+8.135D-11/FR)/FR C=5.081D-37+(-8.724D-23-5.659D-8/FR)/FR BFCS(IT,IJ)=real(A) BFCS(IT+1,IJ)=real(B) BFCS(IT+2,IJ)=real(C) END IF C RETURN END C C C **************************************************************** C C SUBROUTINE PARTF(IAT,IZI,T,ANE,XMAX,U,DUT,DUN) C ============================================== C C Partition functions C The standard evaluation is for hydrogen through zinc, for C neutrals and first four ionization degrees. C Basically after Traving, Baschek, and Holweger, Abhand. Hamburg. C Sternwarte. Band VIII, Nr. 1 (1966) C C For higher atomic numbers modified Kurucz routine PFSAHA, C called PFHEAV here is used. The routine was provided by C Charles Proffitt. C C The routine calls special procedures for Fe and Ni; or C the values based on the tabulated Opacity Project ionization C fractions C C Input: C IAT - atomic number C IZI - ionic charge (=1 for neutrals, =2 for once ionized, etc) C T - temperature C ANE - electron density C XMAX - principal quantum number of the last bound level C C Output: C U - partition function C DUT - derivative dU/dT C DUN - derivative dU/d(ANE) C C Quantities in COMMON/PFSTDS: C for MODPF(IAT) < 0 - non-standard, user supplied procedure C for evaluating partition functions PFSPEC C = 0 - standard expressions C After Traving, Baschek, and Holweger, Abhand. C Hamburg. Sternwarte, Band VIII, Nr. 1 (1966) C > 0 - partition functions evaluated from the C Opacity Project ionization fractions C (by routine OPFRAC) C PFSTD(IAT,IZI) - see above C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' COMMON/PFSTDS/PFSTD(matom,30),MODPF(matom) common/irwint/iirwin PARAMETER (NIONS=123, NSS=222) c PARAMETER (UN=1.D0, HALF=0.5D0, TWO=2.D0, TRHA=1.5D0, PARAMETER (TRHA=1.5D0, * THIRD=UN/3.D0, SIXTH=UN/6.D0) REAL*4 AHH( 6), ALB(12), AB (11), AC (19), AN (30), AO (49), * AF (34), ANN(23), ANA(19), AMG(15), AAL(17), ASI(23), * AP (19), AS (29), ACL(28), AAR(25), AK (30), ACA(17), * ASC(24), ATI(33), AV (33), ACR(29), AMN(28), AFE(35), * ACO(29), ANI(23), ACU(20), AZN(18) REAL*4 GHH( 6), GLB(12), GB (11), GC (19), GN (30), GO (49), * GF (34), GNN(23), GNA(19), GMG(15), GAL(17), GSI(23), * GP (19), GS (29), GCL(28), GAR(25), GK (30), GCA(17), * GSC(24), GTI(33), GV (33), GCR(29), GMN(28), GFE(35), * GCO(29), GNI(23), GCU(20), GZN(18) REAL*4 XL1(99), XL2(123), XL(222), * CH1(66), CH2(72), CH3(55), CH4(29), CHION(222) REAL*4 ALF(678), GAM(678) C INTEGER*2 II1(5,15),II2(5,15),INDEX0(5,30), INTEGER II1(5,15),II2(5,15),INDEX0(5,30), * IS1(53),IS2(70),IS(123),INDEXS(123), * IM1(99),IM2(123),IM(222),INDEXM(222), * IGP1(99),IGP2(123),IGPR(222), * IG01(53),IG02(70),IG0(123) DIMENSION IGLE(28) C EQUIVALENCE ( AHH(1), ALF( 1)),( ALB(1), ALF( 7)), * ( AB (1), ALF( 19)), * ( AC (1), ALF( 30)),( AN (1), ALF( 49)), * ( AO (1), ALF( 79)),( AF (1), ALF(128)), * ( ANN(1), ALF(162)),( ANA(1), ALF(185)), * ( AMG(1), ALF(204)),( AAL(1), ALF(219)), * ( ASI(1), ALF(236)),( AP (1), ALF(259)), * ( AS (1), ALF(278)),( ACL(1), ALF(307)), * ( AAR(1), ALF(335)),( AK (1), ALF(360)), * ( ACA(1), ALF(390)),( ASC(1), ALF(407)), * ( ATI(1), ALF(431)),( AV (1), ALF(464)), * ( ACR(1), ALF(497)),( AMN(1), ALF(526)), * ( AFE(1), ALF(554)),( ACO(1), ALF(589)), * ( ANI(1), ALF(618)),( ACU(1), ALF(641)), * ( AZN(1), ALF(661)) EQUIVALENCE ( GHH(1), GAM( 1)),( GLB(1), GAM( 7)), * ( GB (1), GAM( 19)), * ( GC (1), GAM( 30)),( GN (1), GAM( 49)), * ( GO (1), GAM( 79)),( GF (1), GAM(128)), * ( GNN(1), GAM(162)),( GNA(1), GAM(185)), * ( GMG(1), GAM(204)),( GAL(1), GAM(219)), * ( GSI(1), GAM(236)),( GP (1), GAM(259)), * ( GS (1), GAM(278)),( GCL(1), GAM(307)), * ( GAR(1), GAM(335)),( GK (1), GAM(360)), * ( GCA(1), GAM(390)),( GSC(1), GAM(407)), * ( GTI(1), GAM(431)),( GV (1), GAM(464)), * ( GCR(1), GAM(497)),( GMN(1), GAM(526)), * ( GFE(1), GAM(554)),( GCO(1), GAM(589)), * ( GNI(1), GAM(618)),( GCU(1), GAM(641)), * ( GZN(1), GAM(661)) EQUIVALENCE ( CH1(1), CHION( 1)), * ( CH2(1), CHION( 67)), * ( CH3(1), CHION(139)), * ( CH4(1), CHION(194)), * ( XL1(1), XL( 1)), * ( XL2(1), XL(100)) EQUIVALENCE ( IS1(1), IS(1)), ( IS2(1), IS( 54)), * ( IM1(1), IM(1)), ( IM2(1), IM(100)), * (IGP1(1),IGPR(1)), (IGP2(1),IGPR(100)), * (IG01(1), IG0(1)), (IG02(1), IG0( 54)), * (II1(1,1),INDEX0(1,1)),(II2(1,1),INDEX0(1,16)) C DATA IGLE/2,1,2,1,6,9,4,9,6,1,2,1,6,9,4,9,6,1, * 10,21,28,25,6,25,28,21,10,21/ C C Internal numbering of ions; each line corresponds to one species, C starting from hydrogen. C 0 means that the ion does not exist C negative number means that partition function is assumed constant C (ie even for MODPF=0) and equal to ABS(that value) C DATA II1 / 1, -1, 0, 0, 0, * 2, 3, -1, 0, 0, * 4, 5, -2, -1, 0, * 6, 7, -1, -2, -1, * 8, 9, 10, -1, -2, * 11, 12, 13, 14, -1, * 15, 16, 17, 18, 19, * 20, 21, 22, 23, 24, * 25, 26, 27, 28, -6, * 29, 30, 31, 32, -9, * 33, 34, 35, 36, -4, * 37, 38, 39, 40, -9, * 41, 42, 43, 44, -6, * 45, 46, 47, 48, -1, * 49, 50, 51, 52, 53 / DATA II2 / 54, 55, 56, 57, 58, * 59, 60, 61, 62, 63, * 64, 65, 66, 67, 68, * 69, 70, 71, 72, 73, * 74, 75, 76, 77, -9, * 78, 76, 80, 81, 82, * 83, 84, 85, 86, 87, * 88, 89, 90, 91, 92, * 93, 94, 95, 96, 97, * 98, 99, 100, 101, 102, * 103, 104, 105, 106, 107, * 108, 109, 110, 111, -25, * 112, 113, 114, 115, -1, * 116, 117, 118, 119, -1, * 120, 121, 122, 123, -1 / C C Statistical weights of the ground states C DATA IG01 / 2, * 1, 2, * 2, 1, * 1, 2, * 2, 1, 2, * 1, 2, 1, 2, * 4, 1, 2, 1, 2, * 5, 4, 1, 2, 1, * 4, 5, 4, 1, * 1, 4, 5, 4, * 2, 1, 4, 5, * 1, 2, 1, 4, * 2, 1, 2, 1, * 1, 2, 1, 2, * 4, 1, 2, 1, 2 / DATA IG02 / 5, 4, 1, 2, 1, * 4, 5, 4, 1, 2, * 1, 4, 5, 4, 1, * 2, 1, 4, 5, 4, * 1, 2, 1, 4, * 4, 3, 4, 1, 4, * 5, 4, 5, 4, 1, * 4, 1, 4, 5, 4, * 7, 6, 1, 4, 5, * 6, 7, 6, 1, 4, * 9, 10, 9, 6, 1, * 10, 9, 10, 20, * 9, 6, 9, 28, * 2, 1, 6, 21, * 1, 2, 1, 10 / C DATA IS1 / 1, * 1, 1, * 1, 1, * 2, 1, * 1, 2, 1, * 1, 2, 2, 1, * 2, 2, 3, 2, 1, * 3, 4, 3, 5, 2, * 2, 3, 4, 3, * 2, 2, 3, 2, * 1, 2, 2, 3, * 1, 1, 2, 2, * 2, 2, 1, 2, * 1, 2, 2, 1, * 2, 1, 1, 1, 1 / DATA IS2 / 3, 2, 1, 2, 2, * 2, 3, 2, 1, 1, * 2, 2, 3, 1, 1, * 1, 2, 3, 3, 2, * 2, 1, 2, 2, * 3, 1, 1, 1, 1, * 3, 2, 1, 1, 1, * 2, 3, 1, 1, 1, * 3, 2, 1, 1, 1, * 3, 2, 1, 1, 1, * 3, 2, 2, 1, 1, * 4, 2, 1, 1, * 2, 2, 1, 1, * 3, 2, 1, 1, * 3, 3, 1, 1 / C DATA IM1 / 2, * 2, 2, * 2, 2, * 3, 2, 3, * 3, 3, 2, 3, * 4, 3, 3, 3, 3, 3, * 3, 3, 4, 3, 3, 4, 2, 3, 2, 3, * 4, 2, 2, 4, 2, 3, 3, 4, 4, 2, * 3, 4, 2, 2, 2, 3, 3, * 3, 3, 4, 2, 2, * 4, 2, 3, 2, 5, 2, 2, * 2, 2, 3, 2, 4, 2, 2, 4, 2, * 2, 2, 2, 3, 2, 4, 2, 2, * 3, 3, 2, 2, 3, 2, * 3, 2, 3, 2, 3, 2, 2, * 5, 4, 4, 4, 3, 3, * 3, 2, 4, 4, 3, 3 / DATA IM2 / 4, 2, 2, 4, 2, 5, 4, 2, 3, 1, * 3, 2, 5, 2, 2, 4, 2, 4, 4, * 2, 2, 3, 2, 4, 2, 2, 4, 4, * 3, 2, 3, 3, 2, 3, * 4, 2, 2, 4, 2, * 3, 2, 3, 2, 2, 3, 2, * 4, 3, 3, 5, 4, 2, 3, * 6, 4, 3, 6, 3, 5, 4, 2, * 5, 3, 5, 4, 4, 4, 4, 4, * 3, 3, 3, 4, 4, 4, 4, 4, * 3, 2, 3, 4, 4, 4, 4, 4, * 4, 4, 3, 5, 3, 4, 4, 4, 4, * 5, 3, 3, 3, 5, 4, 5, 1, * 6, 3, 5, 3, 5, 1, * 2, 3, 3, 4, 3, 4, 1, * 2, 2, 2, 3, 3, 2, 3, 1 / C DATA IGP1 / 2, * 4, 2, * 2, 4, * 4, 12, 2, * 2, 4, 12, 2, * 12, 2, 18, 4, 12, 2, * 18, 10, 12, 24, 2, 18, 6, 4, 12, 2, * 8, 20, 12, 18, 10, 2, 10, 12, 24, 20, * 2, 18, 6, 18, 10, 4, 12, * 18, 10, 8, 20, 12, * 18, 10, 2, 10, 12, 24, 20, * 8, 4, 18, 10, 8, 20, 12, 18, 10, * 2, 8, 4, 18, 10, 8, 20, 12, * 4, 2, 8, 4, 18, 10, * 2, 18, 4, 12, 2, 8, 4, * 12, 2, 18, 4, 12, 2, * 18, 10, 12, 2, 4, 2 / DATA IGP2 / 8, 20, 12, 18, 10, 12, 2, 18, 4, 12, * 18, 10, 8, 20, 12, 18, 10, 12, 2, * 8, 4, 18, 10, 8, 20, 12, 18, 12, * 2, 8, 4, 18, 10, 2, * 8, 20, 12, 18, 10, * 4, 20, 2, 8, 4, 18, 10, * 30, 42, 18, 20, 2, 12, 18, * 56, 56, 28, 42, 10, 20, 2, 12, * 50, 70, 56, 72, 64, 42, 20, 2, * 12, 60, 40, 50, 18, 56, 42, 20, * 14, 10, 50, 12, 72, 50, 56, 42, * 60, 56, 40, 50, 18, 12, 72, 50, 56, * 42, 70, 42, 18, 56, 24, 50, 12, * 20, 56, 42, 18, 56, 50, * 2, 30, 10, 20, 56, 42, 56, * 4, 8, 12, 2, 30, 10, 20, 42 / C DATA XL1 /11.0, * 8.0,12.0, * 6.0, 6.0, * 6.0, 4.0, 8.0, * 9.0, 6.0, 4.0, 6.0, * 6.0, 6.0, 5.0, 6.1, 5.0, 6.0, * 6.1, 4.0, 5.0, 3.9, 6.0, 5.0, 4.0, 6.0, 6.3, 6.0, * 8.0, 6.0, 3.4, 6.0, 5.0, 3.9, 3.9, 6.0, 4.9, 4.0, * 5.9, 5.0, 4.9, 4.0, 4.0, 6.0, 6.0, * 4.0, 4.0, 5.0, 4.0, 4.0, * 5.0, 4.0, 3.9, 4.0, 5.0, 5.0, 4.0, * 6.0, 6.0, 5.0, 4.0, 3.9, 4.0, 4.0, 5.0, 5.0, * 7.0, 4.0, 4.0, 4.0, 4.0, 5.0, 5.0, 5.0, * 7.0, 7.0, 5.0, 5.0, 5.0, 5.0, * 7.0, 4.0, 7.0, 4.0, 7.0, 5.0, 5.0, * 6.1, 5.9, 5.0, 5.0, 5.0, 7.0, * 5.0, 5.0, 5.0, 7.0, 8.6, 8.0 / DATA XL2 / 6.0, 5.0, 5.0, 5.0, 5.0, 3.5, 5.0,14.4, 5.0, 4.0, * 6.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.2, * 6.0, 6.0, 5.1, 5.0, 5.0, 5.0, 5.0, 5.0, 4.0, * 7.0, 5.0, 5.0, 6.0, 6.0, 5.0, * 6.0, 5.0, 5.0, 3.6, 4.0, * 5.9, 6.0, 7.0, 5.0, 4.9, 5.0, 4.3, * 4.9, 4.9, 5.0, 5.0, 6.0, 4.6, 3.8, * 5.0, 4.7, 5.0, 5.0, 5.0, 5.0, 6.0, 4.8, * 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,11.2, * 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.2, * 6.0, 5.0, 6.0, 7.0, 5.0, 5.0, 5.0, 5.0, * 5.0, 5.0, 5.0, 5.0, 5.0, 6.0, 5.0, 3.6, 3.8, * 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 3.0, * 5.4, 5.0, 9.0, 5.0, 5.0, 3.0, * 8.0, 6.0, 5.0, 7.0, 5.0, 5.0, 2.9, * 8.0, 5.0, 5.0, 8.0, 5.0, 5.0, 5.0, 2.8 / C C DATA CH1 / 13.595 , * 24.580 , 54.403 , * 5.390 , 75.619 , * 9.320 , 13.278 , 18.206 , * 8.296 , 25.149 , 31.146 , 37.920 , * 11.256 , 24.376 , 30.868 , 47.871 , 55.873 , * 64.476 , * 14.529 , 16.428 , 29.593 , 36.693 , * 47.426 , 55.765 , 63.626 , 77.450 , 87.445 , * 97.863 , * 13.614 , 16.938 , 18.630 , * 35.108 , 37.621 , 40.461 , 42.584 , * 54.886 , 63.733 , 70.556 , * 77.394 , 87.609 , 97.077 , 103.911 , 106.116 , * 113.873 , 125.863 , * 17.418 , 20.009 , 34.977 , 39.204 , 41.368 , * 62.646 , 65.774 , 69.282 , 71.882 , * 87.139 , 97.852 , 106.089 , * 21.559 , 21.656 , 41.071 , 44.274 , * 63.729 , 68.806 , 71.434 , 97.162 , 100.917 / DATA CH2 / 5.138 , 47.290 , 47.459 , 71.647 , 75.504 , * 98.880 , 104.778 , 107.864 , * 7.644 , 15.031 , 80.117 , 80.393 , * 109.294 , 113.799 , * 5.984 , 10.634 , 18.823 , 25.496 , * 28.441 , 119.957 , 120.383 , * 8.149 , 16.339 , 22.894 , * 33.459 , 42.333 , 45.130 , * 10.474 , 11.585 , 19.720 , * 30.156 , 51.354 , 65.007 , * 10.357 , 12.200 , 13.401 , 23.405 , 24.807 , * 35.047 , 47.292 , 57.681 , 72.474 , 85.701 , * 13.014 , 14.458 , 23.798 , 26.041 , 27.501 , * 39.904 , 41.610 , 53.450 , 67.801 , * 15.755 , 15.933 , 27.619 , 29.355 , * 40.899 , 42.407 , 45.234 , 59.793 , 75.002 , * 4.339 , 31.810 , 32.079 , * 45.738 , 47.768 , 50.515 , * 60.897 , 63.890 , 65.849 , 82.799 , 85.150 / DATA CH3 / 6.111 , 7.808 , 11.868 , * 51.207 , 51.596 , 67.181 , 69.536 , * 6.538 , 7.147 , 8.042 , * 12.891 , 24.752 , 74.090 , 91.847 , * 6.818 , 6.953 , 7.411 , * 13.635 , 14.685 , 28.137 , 43.236 , 100.083 , * 6.738 , 7.101 , 14.205 , 15.670 , 16.277 , * 29.748 , 48.464 , 65.198 , * 6.763 , 8.285 , 9.221 , * 16.493 , 18.662 , 30.950 , 49.580 , 73.093 , * 7.432 , 8.606 , 9.240 , 15.636 , 18.963 , * 33.690 , 53.001 , 76.006 , * 7.896 , 8.195 , 8.927 , 16.178 , 18.662 , * 30.640 , 34.607 , 56.001 , 79.001 / DATA CH4 / 7.863 , 8.378 , 9.160 , 9.519 , * 17.052 , 18.958 , 33.491 , 53.001 , * 7.633 , 8.793 , 18.147 , 20.233 , 35.161 , * 56.025 , * 7.724 , 10.532 , 10.980 , * 20.286 , 27.985 , 36.826 , 61.975 , * 9.391 , 17.503 , 17.166 , * 17.959 , 27.757 , 28.310 , 39.701 , 65.074 / C C data for hydrogen and helium C DATA AHH / 20.4976, 747.5023, * 28.1703, 527.8296, 22.2809, 987.7189 / DATA GHH / 10.853 , 13.342 , * 21.170 , 24.125 , 43.708 , 53.542 / C C data for lithium and beryllium C DATA ALB / 8.4915, 97.5015, 23.3299, 192.6701, * 9.1849, 32.9263, 183.8887, 19.9563, 88.0437, * 6.0478, 35.9723, 233.9798 / DATA GLB / 2.022 , 4.604 , 62.032 , 72.624 , * 2.735 , 6.774 , 8.569 , 10.750 , 11.672 , * 3.967 , 12.758 , 16.692 / C C data for boron C DATA AB / 4.0086, 19.6741, 402.3110, * 9.7257, 30.9262, 186.3466, 44.1629, 60.8371, * 6.0084, 23.5767, 76.4149 / DATA GB / 0.002 , 3.971 , 7.882 , * 4.720 , 13.477 , 22.103 , 23.056 , 24.734 , * 6.000 , 24.540 , 32.300 / C C data for carbon C DATA AC / 8.0158, 5.8833, 33.7521, 595.3432, * 4.0003, 17.0841, 82.9154, * 15.9808, 48.2044, 435.8093, * 10.0281, 15.7574, 186.2109, * 15.4127, 55.9559, 243.6311, * 6.0057, 23.5757, 76.4185 / DATA GC / 0.004 , 1.359 , 6.454 , 10.376 , * 0.008 , 16.546 , 21.614 , * 5.688 , 15.801 , 26.269 , * 6.691 , 25.034 , 40.975 , * 17.604 , 36.180 , 47.133 , * 8.005 , 40.804 , 54.492 / C C data for nitrogen C DATA AN / 14.0499, 30.8008, 883.1443, * 10.0000, 16.0000, 64.0000, * 8.0462, 6.2669, 17.8696, 282.8084, * 7.3751, 33.1390, 215.4829, * 4.0003, 19.3533, 80.6462, * 13.0998, 19.6425, 94.3035, 370.9539, * 16.0000, 38.0000, * 10.3289, 14.5021, 187.1624, 108.1615, 191.8383, * 6.0044, 23.5612, 76.4344 / DATA GN / 2.554 , 9.169 , 13.651 , * 12.353 , 13.784 , 14.874 , * 0.014 , 2.131 , 15.745 , 24.949 , * 6.376 , 14.246 , 29.465 , * 0.022 , 31.259 , 41.428 , * 7.212 , 15.228 , 34.387 , 46.708 , * 46.475 , 49.468 , * 8.693 , 37.650 , 65.479 , 61.155 , 79.196 , * 9.999 , 60.991 , 82.262 / C C data for oxygen C DATA AO / 4.0029, 5.3656, 36.2853,1044.3447, * 131.0217, 868.9779, 14.8533, 93.1466, * 12.7843, 5.6828, 98.0919, 829.4396, * 50.9878, 199.0120, 2.0000, 6.0000, 10.0000, * 10.0000, 30.0000, 50.0000, * 8.0703, 5.7144, 84.1156, 529.0927, * 5.6609, 28.9355, 111.3620, 494.0413, * 45.5249, 134.4751, * 4.0003, 21.2937, 78.7058, * 12.8293, 16.2730, 123.6578, 327.2396, * 48.7883, 102.2117, 20.0060, 161.9903, * 28.4184, 61.5816, * 10.5563, 13.2950, 188.1390, * 14.6560, 129.4922, 470.8512 / DATA GO / 0.022 , 2.019 , 9.812 , 13.087 , * 13.804 , 16.061 , 14.293 , 16.114 , * 3.472 , 7.437 , 22.579 , 32.035 , * 27.774 , 33.678 , 28.118 , 31.019 , 34.204 , * 30.892 , 33.189 , 36.181 , * 0.032 , 2.760 , 35.328 , 48.277 , * 7.662 , 16.786 , 42.657 , 54.522 , * 50.204 , 56.044 , * 0.048 , 50.089 , 66.604 , * 8.954 , 18.031 , 57.755 , 72.594 , * 68.388 , 82.397 , 31.960 , 76.876 , * 75.686 , 80.388 , * 10.747 , 52.323 , 94.976 , * 27.405 , 86.350 , 109.917 / C C data for fluor C DATA AF / 2.0001, 39.9012, 122.0986, * 10.0000, 30.0000, 50.0000, * 4.0199, 5.5741, 22.1839, 190.2179, * 53.0383, 126.9616, 31.6894, 75.3105, * 13.5014, 7.9936, 55.7981, 298.7039, * 26.2496, 63.7503, 2.0000, 6.0000, 10.0000, * 28.7150, 71.2850, * 8.0153, 6.1931, 21.7287, 48.7780, 278.2782, * 178.5560, 421.4435, 51.7632, 95.2368 / DATA GF / 0.050 , 13.317 , 15.692 , * 15.361 , 17.128 , 18.498 , * 0.048 , 2.735 , 20.079 , 30.277 , * 27.548 , 32.532 , 30.391 , 34.707 , * 4.479 , 12.072 , 31.662 , 51.432 , * 44.283 , 50.964 , 46.193 , 50.436 , 54.880 , * 50.816 , 57.479 , * 0.058 , 3.434 , 14.892 , 37.472 , 69.883 , * 67.810 , 83.105 , 72.435 , 79.747 / C C data for neon C DATA ANN / 34.5080, 365.4919, 16.5768, 183.4231, * 2.0007, 89.5607, 380.4381, 26.4473, 63.5527, * 4.0342, 5.6162, 11.5176, 72.8273, * 48.5684, 131.4315, 31.1710, 76.8290, * 14.0482, 13.3077, 52.7897, 467.8487, * 54.2196, 195.7800 / DATA GNN / 17.796 , 20.730 , 17.879 , 20.855 , * 0.097 , 29.878 , 37.221 , 31.913 , 37.551 , * 0.092 , 3.424 , 24.806 , 46.616 , * 45.643 , 54.147 , 48.359 , 57.420 , * 5.453 , 18.560 , 46.583 , 80.101 , * 70.337 , 85.789 / C C data for sodium C DATA ANA / 11.6348, 158.3593, * 21.0453, 50.9546, 10.1389, 25.8611, * 2.0019, 38.0569, 137.9398, 28.3106, 61.6893, * 4.0334, 5.8560, 18.1786, 208.9142, * 93.6895, 406.3095, 60.4276, 239.5719 / DATA GNA / 2.400 , 4.552 , * 34.367 , 40.566 , 34.676 , 40.764 , * 0.170 , 44.554 , 57.142 , 51.689 , 60.576 , * 0.152 , 4.260 , 36.635 , 83.254 , * 72.561 , 89.475 , 75.839 , 92.582 / C C data for magnesium C DATA AMG / 10.7445, 291.5057, 53.7488, * 6.2270, 31.1291, 132.6438, * 40.4379, 159.5618, 20.3845, 79.6154, * 2.0007, 106.8977, 343.1010, 10.1326, 237.8581/ DATA GMG / 2.805 , 6.777 , 9.254 , * 4.459 , 9.789 , 13.137 , * 57.413 , 71.252 , 58.010 , 71.660 , * 0.276 , 74.440 , 94.447 , 54.472 , 95.858 / C C data for aluminium C DATA AAL / 4.0009, 11.7804, 142.2179, 13.6585, 96.3371, * 10.0807, 49.5843, 285.3343, 14.6872, 59.3122, * 6.3277, 29.5086, 134.1634, * 46.3164, 153.6833, 22.9896, 77.0103 / DATA GAL / 0.014 , 3.841 , 5.420 , 3.727 , 8.833 , * 4.749 , 11.902 , 16.719 , 11.310 , 18.268 , * 6.751 , 16.681 , 24.151 , * 83.551 , 104.787 , 84.293 , 105.171 / C C data for silicon C DATA ASI / 7.9658, 4.6762, 1.3512, 123.2267, 443.7797, * 4.0000, 7.4186, 24.1754, 60.4060, * 14.4695, 11.9721, 26.5062, 269.0521, * 9.1793, 4.8766, 29.1442, 52.7998, * 13.2674, 36.0417, 180.6910, * 6.4839, 27.6851, 135.8301 / DATA GSI / 0.020 , 0.752 , 1.614 , 5.831 , 7.431 , * 0.036 , 8.795 , 11.208 , 13.835 , * 5.418 , 7.825 , 14.440 , 19.412 , * 6.572 , 11.449 , 18.424 , 25.457 , * 15.682 , 27.010 , 34.599 , * 9.042 , 24.101 , 37.445 / C C data for phosphorus C DATA AP / 13.5211, 22.2130, 353.2583, 10.0000, 150.0000, * 8.0241, 5.8085, 51.7542, 252.4002, * 4.0021, 20.7985, 62.4194, 200.7786, * 11.7414, 63.5124, 179.7420, * 6.8835, 32.7777, 228.3366 / DATA GP / 1.514 , 5.575 , 9.247 , 8.076 , 10.735 , * 0.043 , 1.212 , 8.545 , 15.525 , * 0.074 , 7.674 , 16.639 , 25.118 , * 8.992 , 24.473 , 40.704 , * 11.464 , 33.732 , 55.455 / C C data for sulphur C DATA AS / 3.9615, 5.0780, 15.0944, 362.8588, * 51.5995, 268.4002, 12.0000, 276.0000, * 11.4377, 5.5126, 141.0009, 254.0478, * 33.0518, 126.9479, * 4.0707, 4.0637, 5.7245, 144.6376, 106.4909, * 4.0011, 19.2813, 27.5990, 35.1179, * 94.7454, 283.2486, * 10.5474, 28.7137, 65.7378, 24.0000 / DATA GS / 0.053 , 1.121 , 5.812 , 9.425 , * 8.936 , 11.277 , 9.600 , 12.551 , * 1.892 , 3.646 , 13.550 , 19.376 , * 16.253 , 21.062 , * 0.043 , 0.123 , 1.590 , 13.712 , 22.050 , * 0.118 , 9.545 , 18.179 , 31.441 , * 30.664 , 56.150 , * 10.704 , 27.075 , 50.599 , 43.034 / C C data for chlorine C DATA ACL / 2.0007, 62.5048, 669.4942, 29.0259, 130.9740, * 3.9064, 0.3993, 5.3570, 60.3424, 119.9913, * 138.1567, 278.8418, 102.3681, 158.6314, * 12.6089, 5.9527, 110.5635, 262.8715, * 69.2035, 100.7960, * 7.3458, 5.6638, 44.1256, 202.7846, * 4.0037, 21.8663, 40.5363, 57.5919 / DATA GCL / 0.110 , 9.919 , 12.280 , 11.017 , 13.532 , * 0.092 , 0.581 , 1.620 , 13.121 , 19.787 , * 16.365 , 21.988 , 18.065 , 23.594 , * 2.358 , 5.708 , 19.084 , 30.683 , * 24.880 , 33.229 , * 0.102 , 1.391 , 14.709 , 36.968 , * 0.185 , 11.783 , 25.653 , 44.698 / C C data for argon C DATA AAR / 43.6623, 324.3375, 20.8298, 163.1701, * 2.0026, 137.4515, 258.5445, 62.8129, 149.1867, * 4.0495, 14.4466, 46.8234, 124.6651, * 151.9828, 268.0157, 101.1302, 150.8691, * 13.3718, 8.6528, 60.4614, 285.5072, * 6.7655, 4.7684, 12.8631, 54.5260 / DATA GAR / 12.638 , 14.958 , 12.833 , 15.139 , * 0.178 , 17.522 , 23.584 , 20.464 , 25.150 , * 0.151 , 1.561 , 17.399 , 30.871 , * 24.684 , 33.978 , 27.091 , 36.481 , * 2.810 , 8.877 , 24.351 , 44.489 , * 0.144 , 1.160 , 10.210 , 27.178 / C C data for potassium C DATA AK / 12.9782, 148.6673, 6.3493, * 66.3444, 101.6553, 4.0001, 13.4465, 46.5534, * 2.0171, 116.4767, 713.4965, 63.5907, 396.4079, * 2.0000, 10.0000, 30.0000, * 4.0702, 5.7791, 52.6795, 327.4539, * 62.8604, 357.1331, 55.9337, 196.0646, * 10.9275, 5.5398, 43.2761, 76.2560, * 42.0000, 18.0000 / DATA GK / 1.871 , 3.713 , 18.172 , * 21.185 , 27.705 , 2.059 , 23.709 , 28.542 , * 0.273 , 26.709 , 39.640 , 31.220 , 41.865 , * 29.955 , 37.557 , 42.862 , * 0.228 , 2.274 , 21.703 , 50.191 , * 32.145 , 49.262 , 34.155 , 51.718 , * 3.043 , 5.479 , 20.547 , 30.680 , * 36.275 , 47.345 / C C data for calcium C DATA ACA / 18.2366, 27.5012, 149.2617, 94.5242, 705.4711, * 11.8706, 14.0710, 106.0547, * 57.2414, 110.7567, 29.8121, 54.1874, * 2.0184, 97.5784, 282.3939, 209.1871, 252.8129/ DATA GCA / 2.050 , 3.349 , 5.321 , 4.873 , 7.017 , * 1.769 , 5.109 , 9.524 , * 27.271 , 41.561 , 29.172 , 42.140 , * 0.394 , 28.930 , 52.618 , 38.593 , 49.646 / C C data for scandium C DATA ASC / 6.0014, 83.1958, 67.3666, 329.4354, * 44.0793, 169.9969, 533.9195, * 34.1642, 124.8475, 228.9879, * 11.9979, 16.9280, 28.4778, 82.0418, 234.5360, * 6.0042, 2.7101, 13.9801, 65.3039, * 12.0000, 12.0000, * 2.0051, 2.9621, 29.0306 / DATA GSC / 0.021 , 2.056 , 3.551 , 5.465 , * 1.535 , 3.797 , 6.203 , * 2.389 , 4.858 , 7.141 , * 0.011 , 0.430 , 1.156 , 3.711 , 8.863 , * 0.025 , 3.499 , 10.463 , 18.606 , * 41.779 , 57.217 , * 0.539 , 24.442 , 51.079 / C C data for titanium C DATA ATI / 7.0887, 8.9186, 17.5633, 206.6832, 438.5735, * 654.1721, * 38.0462, 69.6271, 364.2845, 832.0408, * 98.8562, 57.9934, 442.1498, * 19.7843, 32.0637, 37.0895, 110.6682, 288.4946, * 521.8837, * 10.0000, 34.0000, 120.0000, * 16.1691, 22.3550, 24.1646, 83.5128, 222.7963, * 6.0020, 4.6177, 25.2636, 52.1162, * 12.0000, 8.0000 / DATA GTI / 0.021 , 0.048 , 1.029 , 2.183 , 4.109 , * 5.785 , * 0.846 , 1.792 , 3.836 , 5.787 , * 2.561 , 4.869 , 6.340 , * 0.023 , 0.124 , 0.774 , 1.810 , 4.980 , * 9.585 , * 1.082 , 4.928 , 11.279 , * 0.041 , 1.375 , 4.768 , 10.985 , 19.769 , * 0.048 , 11.577 , 24.531 , 36.489 , * 54.436 , 75.373 / C C data for vanadium C DATA AV / 15.2627, 23.9869, 51.3053, 570.3384,1650.9417, * 162.2829, 298.8303, 908.8852, * 23.6736, 37.1624, 86.8011, 300.7440, 864.5880, * 57.8961, 79.4605, 214.9007, 864.7425, * 61.8508, 64.0845, 192.8298, 718.2349, * 23.8116, 68.2495, 135.0613, 536.7632, * 15.9543, 22.5542, 71.4921, 248.9544, * 6.0006, 5.8785, 50.5077, 97.6129 / DATA GV / 0.026 , 0.145 , 0.718 , 2.586 , 5.458 , * 2.171 , 4.153 , 6.097 , * 0.009 , 0.366 , 1.504 , 5.294 , 10.126 , * 1.796 , 2.353 , 6.068 , 12.269 , * 2.560 , 3.674 , 6.593 , 12.880 , * 0.045 , 1.684 , 8.162 , 21.262 , * 0.065 , 1.746 , 15.158 , 33.141 , * 0.077 , 21.229 , 44.134 , 60.203 / C C data for chromium C DATA ACR / 30.1842, 79.2847, 149.5293, * 215.3696, 119.1974, 741.4321, * 184.9946,1352.5038, 784.4937, * 46.6191, 160.1361, 488.0449, 657.1928, * 47.1742, 267.0275, 441.1324, 150.6650, * 24.3768, 122.8359, 285.5092, 794.1654, * 24.2296, 75.0258, 172.9452, 543.6511, * 15.9819, 17.6800, 95.2003, 225.0947 / DATA GCR / 0.993 , 3.070 , 5.673 , * 3.339 , 4.801 , 7.198 , * 2.829 , 4.990 , 7.643 , * 1.645 , 3.727 , 7.181 , 12.299 , * 2.902 , 4.273 , 8.569 , 14.912 , * 0.047 , 2.566 , 9.441 , 21.198 , * 0.078 , 2.242 , 15.638 , 32.725 , * 0.103 , 2.146 , 26.153 , 49.381 / C C data for manganese C DATA AMN / 53.9107, 81.3931, 546.6945 , * 144.1893, 407.8029, 45.6177, 298.4423,2410.9335, * 22.6382, 93.8419, 183.9367, 907.5765, * 137.0409, 168.6783, 329.0287, 773.2513, * 70.1925, 72.3372, 213.9512, 539.5165, * 24.2373, 93.5415, 456.6167, 506.5484, * 24.7687, 66.9896, 264.1853, 484.0161 / DATA GMN / 2.527 , 4.204 , 6.602 , * 4.155 , 7.321 , 2.285 , 5.631 , 8.448 , * 1.496 , 3.839 , 7.751 , 13.484 , * 3.681 , 6.054 , 9.934 , 14.936 , * 3.531 , 6.967 , 15.222 , 25.069 , * 0.071 , 2.896 , 20.725 , 37.383 , * 0.126 , 2.660 , 28.528 , 53.413 / C C data for iron C DATA AFE / 14.4102, 2.7050, 421.6612, 940.1484, * 36.2187, 22.8883, 239.5997, 825.2919, * 110.0242, 992.3040, 640.6715, * 17.0494, 32.3783, 34.3184, 420.9626,1067.2064, * 154.0059, 462.1117, 329.8618, * 15.7906, 47.1186, 279.9292, 692.1005, * 91.0206, 206.3082, 706.9927, 836.6689, * 40.0790, 27.6965, 28.2243, 18.0001, * 24.0899, 89.6340, 51.5756, 241.6980 / DATA GFE / 0.066 , 0.339 , 2.897 , 6.585 , * 0.923 , 1.679 , 4.620 , 7.053 , * 4.249 , 5.875 , 7.781 , * 0.062 , 0.283 , 1.504 , 5.430 , 11.210 , * 2.792 , 7.627 , 13.623 , * 0.077 , 3.723 , 12.137 , 23.700 , * 2.688 , 7.595 , 15.444 , 25.587 , * 3.982 , 4.677 , 6.453 , 23.561 , * 0.102 , 3.354 , 22.954 , 33.796 / C C data for cobalt C DATA ACO / 11.9120, 20.4424, 28.3863, 132.5038, 600.7461, * 33.3092, 237.4331, 977.2502, * 55.5396, 318.8169, 619.6366, * 32.6900, 83.8694, 107.4378, * 11.2593, 38.2239, 22.9964, 261.3486, 637.1485, * 23.0233, 41.6599, 264.6460, 181.6699, * 16.0356, 7.8633, 70.3158, 423.3512, 742.3553, * 0. / DATA GCO / 0.112 , 0.341 , 0.809 , 3.808 , 6.723 , * 2.057 , 3.484 , 7.210 , * 2.405 , 5.133 , 8.097 , * 2.084 , 5.291 , 8.426 , * 0.135 , 0.517 , 1.606 , 6.772 , 12.622 , * 2.512 , 4.348 , 8.253 , 15.377 , * 0.132 , 0.863 , 3.086 , 11.789 , 23.263 , * 0. / C C data for nickel C DATA ANI / 7.1268, 12.4486, 11.9953, 10.0546, 114.1658, * 391.2064, * 26.3908, 213.8081, 938.7927, * 4.1421, 37.3781, 25.9712, 333.3397, 311.1633, * 33.1031, 184.1854, 136.7072, * 11.1915, 5.4174, 53.6793, 460.6781, 380.0056, * 0. / DATA GNI / 0.026 , 0.137 , 0.315 , 1.778 , 4.029 , * 6.621 , * 2.249 , 4.042 , 7.621 , * 0.191 , 1.235 , 3.358 , 8.429 , 17.096 , * 3.472 , 9.065 , 16.556 , * 0.194 , 1.305 , 5.813 , 14.172 , 26.169 , * 0. / C C data for copper C DATA ACU / 11.0549, 238.9423, 10.3077, 126.2990,1073.3876, * 30.0000, 50.0000, 60.0000, * 19.2984, 50.5974, 240.2021,1216.9016, * 48.3048, 583.2011, 320.4931, * 4.0155, 70.3264, 313.1213, 536.5331, * 0. / DATA GCU / 4.212 , 7.227 , 1.493 , 5.859 , 9.709 , * 7.081 , 9.362 , 10.130 , * 2.865 , 8.260 , 14.431 , 18.292 , * 9.650 , 14.640 , 24.320 , * 0.337 , 8.520 , 16.925 , 28.342 , * 0. / C C data for zinc C DATA AZN / 15.9880, 484.0042, 18.5863, 123.4134, * 3.0000, 189.0000, * 6.1902, 38.9317, 204.8780, * 10.2588, 89.3771, 370.3640, 30.0000, 128.0000, * 24.6904, 106.7491, 439.5586, * 0. / DATA GZN / 4.546 , 8.840 , 10.247 , 16.620 , * 11.175 , 16.321 , * 6.113 , 12.964 , 16.444 , * 7.926 , 13.633 , 24.353 , 16.286 , 24.910 , * 10.291 , 20.689 , 32.077 , * 0. / C DATA ICOMP /0/ C c SAVE ALF,GAM,XL,CHION,INDEX0,INDEXS,INDEXM,IGPR,IG0,ICOMP C C Initialization of auxiliary arrays (executed only once) C IF(ICOMP.EQ.0) THEN IND=1 DO K=1,NIONS INDEXS(K)=IND IND=IND+IS(K) END DO IND=1 DO K=1,NSS INDEXM(K)=IND IND=IND+IM(K) END DO ICOMP=1 END IF C MODE=MODPF(IAT) IF(MODE.GT.0) GO TO 80 IF(IAT.EQ.26 .AND. IZI.GE.4 .AND. IZI.LE.9) GO TO 170 IF(IAT.EQ.28 .AND. IZI.GE.4 .AND. IZI.LE.9) GO TO 171 IF(IZI.LE.0.OR.IAT.LE.0) GO TO 70 IF(IZI.GT.5) THEN IF(IAT.LT.IZI) THEN U=1. DUT=0. DUN=0. RETURN END IF IF(IAT.GT.8) THEN U=IGLE(IAT-IZI+1) DUT=0. DUN=0. RETURN END IF CALL PFCNO(IAT,IZI,T,ANE,U) RETURN END IF c c Irwin partition functions by default c if(iirwin.gt.0.and.t.lt.16000.) then if(izi.le.2) then call mpartf(iat,izi,0,t,u0,du0) u=u0 dut=0. if(u0.gt.0..and.dut.gt.0.) dut=u0/t*du0 return end if else if(iat.gt.30.and.izi.le.3) then go to 90 end if c IF(MODE.LT.0) GO TO 70 I0=INDEX0(IZI,IAT) IF(I0.LE.0) GO TO 60 C C Traving, Baschek, Holweger formula C QZ=IZI THET=5.0404D3/T A=31.321*QZ*QZ*THET XMAX2=XMAX*XMAX QQ=XMAX/4.*(XMAX2+XMAX+SIXTH+A+A*A*HALF/XMAX2) QAS1=XMAX*THIRD*(XMAX2+TRHA*XMAX+HALF) IS0=INDEXS(I0) ISS=IS0+IS(I0)-1 SU1=0. SU2=0. SQA=0. SQQ=0. SQT=0. SQ2=0. DO K=IS0,ISS XXL=XL(K) GPR=IGPR(K) X=CHION(K)*THET EX=0. IF(X.LT.30) EX=EXP(-X*2.30258029299405) SQQ=SQQ+GPR*EX QAS=(QAS1-XXL*THIRD*(XXL*XXL+TRHA*XXL+HALF)+(XMAX-XXL)* * (UN+A*HALF/XXL/XMAX)*A)*GPR*EX SQA=SQA+QAS SQ2=SQ2+QAS*CHION(K) SQT=SQT+GPR*(XMAX-XXL)*(UN+A/XMAX/XXL)*EX M0=INDEXM(K) M1=M0+IM(K)-1 AL1=0. AL2=0. DO M=M0,M1 XG=GAM(M)*THET IF(XG.LE.20.) THEN XM=EXP(-XG*2.30258029299405)*ALF(M) AL1=AL1+XM AL2=AL2+GAM(M)*XM END IF END DO SU1=SU1+AL1 SU2=SU2+AL2 END DO U=IG0(I0) U=U+SU1+SQA IF(U.LT.0.) U=IG0(I0) DUT=(2.302580293*THET*(SU2+SQ2)+QQ*SQQ-A*SQT)/T DUN=-QQ*SQQ/ANE RETURN C C constant value of partition function for some ions (even if C MODPF = 0) C 60 U=-I0 DUT=0. DUN=0. RETURN C C non-standard, user supplied formula C 70 CALL PFSPEC(IAT,IZI,T,ANE,U,DUT,DUN) RETURN C C Partition functions for Iron (From Sparks and Fischel) C 170 CALL PFFE(IZI,T,ANE,U,DUT,DUN) RETURN C C Partition functions for Nickel (from Kurucz predicted levels) C 171 CALL PFNI(IZI,T,U,DUT,DUN) RETURN C C Opacity Project value C 80 call opfrac(iat,izi,t,ane,u,opfra) DUT=0. DUN=0. RETURN C C Modified Kurucz partition functions for IAT > 30 C 90 CALL PFHEAV(IAT,IZI,3,T,ANE,U) DUT=0. DUN=0. RETURN END C C ******************************************************************** C SUBROUTINE PFCNO(IAT,IZI,T,ANE,PF) c =================================== c Partition functions for the high ions of CNO: c (a) H-like ions: C VI, N VII, O VIII c (b) He-like ions: N VI, O VII c (c) O VI from Sparks & Fischel, 1971, NASA SP-3066 c Output: PF partition function INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' PARAMETER (P1=0.1402,P2=0.1285,P3=1.,P4=3.15,P5=4.) DIMENSION TT(35),PN(10) DIMENSION P6A(24),P6B(10,11) DATA TT / * 18.,19.,20.,21.,22.,23.,24.,25.,26.,27.,28.,29.,30., * 32.,34.,36.,38.,40.,42.,44.,46.,48., * 50.,55.,60.,65.,70.,75.,80.,85.,90.,95.,100.,125.,150./ DATA PN /-2.,-1.,0.,1.,2.,3.,4.,5.,6.,7./ c DATA P6A / * 0.302, 0.302, 0.302, 0.303, 0.303, 0.304, 0.305, 0.306, * 0.307, 0.308, 0.310, 0.312, 0.313, 0.318, 0.322, 0.327, * 0.333, 0.339, 0.346, 0.353, 0.360, 0.367, 0.375, 0.394/ c DATA P6B / * 0.414,9*0.413, * 0.436,0.433,0.433,7*0.432, * 0.472,0.458,0.453,7*0.451, * 0.560,0.499,0.478,0.471,0.469,5*0.468, * 0.762,0.593,0.522,0.497,0.489,0.486,4*0.485, * 1.090,0.782,0.611,0.539,0.513,0.505,0.502,3*0.501, * 1.478,1.070,0.775,0.615,0.550,0.527,0.519,0.517,0.516,0.516, * 1.867,1.408,1.018,0.749,0.612,0.557,0.539,0.533,0.531,0.530, * 2.233,1.752,1.306,0.944,0.713,0.604,0.564,0.550,0.545,0.544, * 3.665,3.166,2.668,2.176,1.700,1.269,0.934,0.735,0.648,0.616, * 4.633,4.133,3.633,3.134,2.636,2.146,1.674,1.254,0.942,0.763/ IF (IAT.LT.6 .OR. IAT.GT.8 .OR. IZI.LE.5) THEN PF=0. PRINT *,' Routine PFCNO does not provide U for this ion ' * ,IAT,IZI STOP END IF IF (IZI.GT.IAT) THEN PF=1. RETURN END IF TK = BOLK*T IZIT = IAT-IZI C 1. H-like case IF(IZIT.EQ.0) THEN ANEL = LOG(ANE) AA = 0.09*EXP(ANEL/6.)/SQRT(T) ANEL23 = EXP(-2./3.*ANEL) Z = FLOAT(IZI) Z2 = Z*Z CBZ = 2.*8.59D14*Z*Z*Z E0KT = EH*Z2/TK PF=0. DO II=1,NLMX XN = FLOAT(II) XN2 = XN*XN IF(XN.LE.3.01) THEN XKN = 1. ELSE XN1 = 1./(XN+1.) XKN = 16./3.*XN*XN1*XN1 END IF BETA = CBZ*XKN/XN2/XN2*ANEL23 X=EXP(P4*LOG(1.+P3*AA)) C1=P1*(X+P5*(Z-1.)*AA*AA*AA) C2=P2*X F=(C1*BETA*BETA*BETA)/(1.+C2*BETA*SQRT(BETA)) WI=F/(1.+F) EE = EXP(-E0KT/XN2) PF = PF+XN2*WI*EE END DO PF = 2.*PF END IF C 2. He-like case IF(IZIT.EQ.1) THEN PF=1. END IF C 3. O VI IF(IZIT.EQ.2) THEN IF(T.LT.18000.) THEN PF=2. ELSE NA = 24 NB = 11 PNE = LOG10(ANE*TK) T0 = 0.001*T J = 1 IF(PNE.LT.PN(1)) GO TO 15 IF(PNE.GT.PN(10)) THEN J1 = 10 J2 = 10 GO TO 16 END IF DO J=1,9 IF(PNE.GE.PN(J) .AND. PNE.LT.PN(J+1)) GO TO 15 END DO 15 J1 = J J2 = J+1 IF(PNE.LT.PN(1)) J2 = 1 16 DO I=1,34 IF(T0.GE.TT(I) .AND. T0.LT.TT(I+1)) GO TO 25 END DO 25 I1 = I I2 = I+1 IF(T0.GT.TT(35)) THEN I1 = 35 I2 = 35 END IF IF(I2.LE.24) THEN PX1=P6A(I1) PX2=P6A(I1) PY1=P6A(I2) PY2=P6A(I2) ELSE IF (I1.EQ.24) THEN PX1=P6A(I1) PX2=P6A(I1) PY1=P6B(J1,I2-24) PY2=P6B(J2,I2-24) ELSE PX1=P6B(J1,I1-24) PX2=P6B(J2,I1-24) PY1=P6B(J1,I2-24) PY2=P6B(J2,I2-24) END IF DLGUNX=PX2-PX1 PX=PX1+(PNE-PN(J1))*DLGUNX DLGUNY=PY2-PY1 PY=PY1+(PNE-PN(J1))*DLGUNY DELT=TT(I2)-TT(I1) IF(DELT.NE.0.) THEN DLGUT=(PY-PX)/DELT PF=PX+(T0-TT(I1))*DLGUT ELSE PF=PX ENDIF PF=EXP(2.302585093*PF) END IF END IF RETURN END C C C ******************************************************************* C C SUBROUTINE PFSPEC(IAT,IZI,T,ANE,U,DUT,DUN) C ========================================== C Non-standard evaluation of the partition function C user supplied procedure C C Input: C IAT - atomic number C IZI - ionic charge (=1 for neutrals, =1 for once ionized, etc) C T - temperature C ANE - electron density C XMAX - principal quantum number of the last bound level C C Output: C U - partition function C DUT - derivative dU/dT C DUN - derivative dU/d(ANE) C INCLUDE 'IMPLIC.FOR' C U=0. DUT=0. DUN=0. T1=T A1=ANE IF(IAT.EQ.10) THEN IF(IZI.EQ.5) U=9. IF(IZI.EQ.6) U=6. IF(IZI.EQ.7) U=12. IF(IZI.EQ.8) U=8. IF(IZI.EQ.9) U=1. RETURN END IF IF(IAT.EQ.16) THEN IF(IZI.EQ.5) U=1. IF(IZI.EQ.6) U=2. IF(IZI.EQ.7) U=1. IF(IZI.EQ.8) U=6. IF(IZI.EQ.9) U=9. RETURN END IF RETURN END C C C ******************************************************************** C C C subroutine pffe(ion,t,ane,pf,dut,dun) c ===================================== c c partition functions for Fe IV to Fe IX c after Fischel and Sparks, 1971, NASA SP-3066 c c Output: PF partition function c DUT d(PF)/dT c DUN d(PF)/d(ANE) c include 'IMPLIC.FOR' c dimension tt(50),pn(10),nca(9) dimension p4a(22),p4b(10,28), * p5a(30),p5b(10,20), * p6a(37),p6b(10,13), * p7a(40),p7b(10,10), * p8a(41),p8b(10,9), * p9a(45),p9b(10,5) c parameter (xen=2.302585093,xmil=0.001,xmilen=xmil*xen) parameter (xbtz=1.38054d-16) c data nca /3*0,22,30,37,40,41,45/ * nne /10/ c data tt / * 3.,4.,5.,6.,7.,8.,9.,10.,11.,12.,13.,14.,15.,16.,17.,18.,19., * 20.,21.,22.,23.,24.,25.,26.,27.,28.,29.,30., * 32.,34.,36.,38.,40.,42.,44.,46.,48., * 50.,55.,60.,65.,70.,75.,80.,85.,90.,95.,100.,125.,150./ c data pn /-2.,-1.,0.,1.,2.,3.,4.,5.,6.,7./ c data p4a / * 0.778, 0.778, 0.778, 0.779, 0.783, 0.789, 0.801, 0.818, * 0.842, 0.871, 0.906, 0.945, 0.987, 1.030, 1.074, 1.117, * 1.160, 1.201, 1.242, 1.280, 1.317, 1.353/ c data p4b / * 1.406,1.393,1.389,7*1.387, * 1.464,1.434,1.424,1.421,1.420,5*1.419, * 1.546,1.483,1.461,1.454,1.451,1.451,4*1.450, * 1.665,1.547,1.503,1.488,1.482,1.481,4*1.480, * 1.826,1.636,1.553,1.524,1.514,1.510,4*1.509, * 2.024,1.755,1.618,1.564,1.546,1.540,1.538,3*1.537, * 2.480,2.087,1.814,1.674,1.619,1.599,1.593,1.591,1.590,1.590, * 2.945,2.489,2.105,1.846,1.717,1.667,1.649,1.643,1.641,1.640, * 3.379,2.897,2.452,2.089,1.859,1.751,1.710,1.696,1.691,1.689, * 3.774,3.283,2.808,2.381,2.054,1.864,1.782,1.751,1.741,1.738, * 4.133,3.637,3.150,2.688,2.292,2.015,1.871,1.814,1.793,1.786, * 4.460,3.962,3.468,2.989,2.549,2.199,1.984,1.886,1.848,1.835, * 4.757,4.258,3.762,3.274,2.809,2.406,2.121,1.972,1.908,1.886, * 5.029,4.530,4.032,3.539,3.061,2.624,2.279,2.073,1.976,1.939, * 5.279,4.780,4.281,3.785,3.299,2.840,2.450,2.189,2.051,1.996, * 5.510,5.010,4.511,4.013,3.522,3.050,2.628,2.318,2.136,2.057, * 6.014,5.514,5.014,4.515,4.018,3.530,3.065,2.666,2.381,2.228, * 6.435,5.935,5.435,4.936,4.437,3.943,3.460,3.022,2.658,2.422, * 6.794,6.294,5.794,5.294,4.794,4.297,3.807,3.343,2.939,2.631, * 7.102,6.602,6.102,5.602,5.102,4.604,4.110,3.638,3.194,2.845, * 7.370,6.870,6.370,5.870,5.370,4.871,4.375,3.892,3.439,3.052, * 7.606,7.106,6.606,6.106,5.605,5.106,4.608,4.125,3.661,3.249, * 7.815,7.315,6.814,6.314,5.814,5.314,4.816,4.333,3.851,3.418, * 8.001,7.501,7.001,6.500,6.000,5.500,5.001,4.511,4.032,3.586, * 8.168,7.668,7.168,6.668,6.168,5.667,5.168,4.680,4.197,3.741, * 8.319,7.819,7.319,6.819,6.319,5.818,5.319,4.832,4.347,3.884, * 8.900,8.399,7.899,7.399,6.899,6.398,5.898,5.405,4.917,4.431, * 9.294,8.794,8.294,7.793,7.293,6.793,6.292,5.799,5.306,4.824/ c data p5a / * 1.235, 1.276, 1.301, 1.321, 1.339, 1.359, 1.381, 1.405, * 1.432, 1.460, 1.489, 1.518, 1.546, 1.574, 1.601, 1.627, * 1.652, 1.675, 1.697, 1.718, 1.738, 1.757, 1.775, 1.792, * 1.808, 1.823, 1.838, 1.851, 1.877, 1.900/ c data p5b / * 1.943,1.928,1.923,7*1.921, * 2.011,1.964,1.947,1.942,1.941,5*1.940, * 2.144,2.025,1.980,1.965,1.960,1.958,4*1.957, * 2.361,2.137,2.032,1.993,1.980,1.976,1.975,3*1.974, * 2.646,2.315,2.121,2.035,2.004,1.994,1.991,1.990,1.989,1.989, * 2.960,2.553,2.260,2.102,2.037,2.015,2.007,2.005,2.004,2.004, * 3.274,2.823,2.450,2.205,2.086,2.040,2.025,2.020,2.018,2.018, * 3.575,3.101,2.674,2.348,2.158,2.075,2.045,2.036,2.032,2.031, * 4.251,3.757,3.275,2.829,2.466,2.234,2.124,2.083,2.069,2.064, * 4.822,4.324,3.829,3.346,2.895,2.522,2.278,2.161,2.116,2.100, * 5.308,4.808,4.310,3.816,3.334,2.888,2.525,2.297,2.187,2.145, * 5.725,5.225,4.726,4.228,3.736,3.260,2.828,2.496,2.294,2.206, * 6.088,5.589,5.089,4.590,4.093,3.604,3.139,2.733,2.447,2.291, * 6.407,5.907,5.407,4.908,4.409,3.915,3.433,2.988,2.629,2.399, * 6.689,6.189,5.689,5.189,4.690,4.193,3.704,3.236,2.832,2.535, * 6.940,6.440,5.940,5.440,4.941,4.443,3.949,3.469,3.038,2.687, * 7.166,6.666,6.166,5.666,5.166,4.667,4.171,3.684,3.237,2.847, * 7.370,6.870,6.369,5.869,5.369,4.870,4.373,3.882,3.417,3.008, * 8.150,7.649,7.149,6.649,6.149,5.649,5.149,4.651,4.167,3.700, * 8.677,8.177,7.676,7.176,6.676,6.176,5.676,5.176,4.687,4.203/ c data p6a / * 1.218, 1.273, 1.309, 1.335, 1.358, 1.379, 1.400, 1.421, * 1.442, 1.463, 1.484, 1.504, 1.523, 1.542, 1.560, 1.577, * 1.594, 1.609, 1.624, 1.638, 1.652, 1.664, 1.677, 1.688, * 1.699, 1.709, 1.719, 1.729, 1.746, 1.762, 1.777, 1.790, * 1.803, 1.814, 1.825, 1.834, 1.843/ c data p6b / * 1.862,1.855,1.853,7*1.852, * 1.958,1.900,1.880,1.874,1.872,5*1.871, * 2.264,2.045,1.944,1.906,1.894,1.890,4*1.888, * 2.776,2.386,2.119,1.984,1.930,1.912,1.906,1.904,2*1.903, * 3.321,2.856,2.453,2.165,2.012,1.949,1.927,1.920,1.918,1.917, * 3.821,3.333,2.868,2.465,2.178,2.025,1.963,1.941,1.934,1.932, * 4.266,3.771,3.285,2.825,2.434,2.164,2.027,1.972,1.953,1.947, * 4.662,4.164,3.670,3.187,2.739,2.372,2.135,2.022,1.980,1.965, * 5.015,4.516,4.019,3.527,3.052,2.624,2.295,2.102,2.019,1.988, * 5.332,4.832,4.344,3.838,3.351,2.889,2.493,2.217,2.075,2.017, * 5.618,5.118,4.619,4.121,3.628,3.149,2.711,2.364,2.155,2.058, * 6.710,6.210,5.710,5.210,4.711,4.213,3.719,3.241,2.807,2.462, * 7.446,6.946,6.446,5.946,5.446,4.946,4.447,3.952,3.474,3.022/ c data p7a / * 1.074,1.130,1.167,1.194,1.215,1.234,1.250,1.266,1.280,1.293, * 1.306,1.318,1.329,1.340,1.350,1.360,1.369,1.378,1.386,1.394, * 1.401,1.408,1.415,1.421,1.427,1.433,1.439,1.444,1.454,1.463, * 1.471,1.479,1.486,1.492,1.498,1.504,1.509,1.514,1.525,1.534/ c data p7b / * 1.555,1.546,1.544,1.543,6*1.542, * 1.617,1.572,1.557,1.552,1.550,1.550,4*1.549, * 1.798,1.648,1.587,1.566,1.559,1.557,4*1.556, * 2.134,1.832,1.666,1.597,1.573,1.565,1.563,1.562,2*1.561, * 2.550,2.138,1.836,1.671,1.602,1.578,1.570,1.568,2*1.567, * 2.968,2.504,2.102,1.816,1.665,1.603,1.582,1.575,2*1.572, * 3.359,2.875,2.419,2.037,1.779,1.651,1.601,1.584,1.579,1.577, * 3.718,3.224,2.745,2.305,1.953,1.736,1.636,1.599,1.586,1.582, * 5.097,4.598,4.098,3.601,3.110,2.638,2.217,1.899,1.719,1.643, * 6.026,5.526,5.026,4.527,4.028,3.531,3.042,2.576,2.170,1.885/ c data p8a / * 0.809,0.849,0.875,0.894,0.908,0.918,0.927,0.934,0.939,0.944, * 0.948,0.952,0.955,0.958,0.960,0.962,0.964,0.966,0.967,0.969, * 0.970,0.971,0.973,0.974,0.975,0.975,0.976,0.977,0.978,0.980, * 0.981,0.982,0.983,0.984,0.984,0.985,0.986,0.986,0.987,0.988, * 0.989/ c data p8b / * 0.992,0.991,8*0.990, * 1.000,0.994,0.992,7*0.991, * 1.032,1.005,0.996,0.993,0.992,5*0.991, * 1.129,1.040,1.008,0.997,0.993,5*0.992, * 1.335,1.132,1.042,1.009,0.998,0.994,0.993,0.993,2*0.992, * 1.640,1.312,1.121,1.038,1.007,0.998,0.994,3*0.993, * 1.987,1.573,1.269,1.101,1.030,1.005,0.997,2*0.994,0.993, * 3.514,3.017,2.526,2.053,1.628,1.305,1.119,1.039,1.010,1.000, * 4.569,4.069,3.569,3.072,2.580,2.103,1.671,1.336,1.136,1.048/ c data p9a /39*0.000,0.001,0.002,0.005,0.008,0.014,0.021/ c data p9b / * 2*0.032,8*0.031, * 0.048,0.045,8*0.044, * 0.076,0.065,0.061,0.060,6*0.059, * 1.128,0.722,0.429,0.271,0.207,0.184,0.177,0.174,2*0.173, * 2.696,2.200,1.712,1.249,0.848,0.564,0.415,0.354,0.333,0.327/ c na=nca(ion) nb=50-na pne=log10(ane*xbtz*t) t0=xmil*t j=1 if(pne.lt.pn(1)) go to 15 if(pne.gt.pn(nne)) then j1=nne j2=nne goto 16 endif do j=1,nne-1 if(pne.ge.pn(j).and.pne.lt.pn(j+1)) go to 15 end do 15 j1=j j2=j1+1 if(pne.lt.pn(1)) j2=1 16 do i=1,49 if(t0.ge.tt(i).and.t0.lt.tt(i+1)) go to 25 end do 25 i1=i i2=i+1 if(t0.gt.tt(50)) then i1=50 i2=50 endif if(i2.le.na) then if(ion.eq.4) then px1=p4a(i1) px2=p4a(i1) py1=p4a(i2) py2=p4a(i2) else if(ion.eq.5) then px1=p5a(i1) px2=p5a(i1) py1=p5a(i2) py2=p5a(i2) else if(ion.eq.6) then px1=p6a(i1) px2=p6a(i1) py1=p6a(i2) py2=p6a(i2) else if(ion.eq.7) then px1=p7a(i1) px2=p7a(i1) py1=p7a(i2) py2=p7a(i2) else if(ion.eq.8) then px1=p8a(i1) px2=p8a(i1) py1=p8a(i2) py2=p8a(i2) else if(ion.eq.9) then px1=p9a(i1) px2=p9a(i1) py1=p9a(i2) py2=p9a(i2) endif else if(i1.eq.na) then if(ion.eq.4) then px1=p4a(i1) px2=p4a(i1) py1=p4b(j1,i2-na) py2=p4b(j2,i2-na) else if(ion.eq.5) then px1=p5a(i1) px2=p5a(i1) py1=p5b(j1,i2-na) py2=p5b(j2,i2-na) else if(ion.eq.6) then px1=p6a(i1) px2=p6a(i1) py1=p6b(j1,i2-na) py2=p6b(j2,i2-na) else if(ion.eq.7) then px1=p7a(i1) px2=p7a(i1) py1=p7b(j1,i2-na) py2=p7b(j2,i2-na) else if(ion.eq.8) then px1=p8a(i1) px2=p8a(i1) py1=p8b(j1,i2-na) py2=p8b(j2,i2-na) else if(ion.eq.9) then px1=p9a(i1) px2=p9a(i1) py1=p9b(j1,i2-na) py2=p9b(j2,i2-na) endif else if(ion.eq.4) then px1=p4b(j1,i1-na) px2=p4b(j2,i1-na) py1=p4b(j1,i2-na) py2=p4b(j2,i2-na) else if(ion.eq.5) then px1=p5b(j1,i1-na) px2=p5b(j2,i1-na) py1=p5b(j1,i2-na) py2=p5b(j2,i2-na) else if(ion.eq.6) then px1=p6b(j1,i1-na) px2=p6b(j2,i1-na) py1=p6b(j1,i2-na) py2=p6b(j2,i2-na) else if(ion.eq.7) then px1=p7b(j1,i1-na) px2=p7b(j2,i1-na) py1=p7b(j1,i2-na) py2=p7b(j2,i2-na) else if(ion.eq.8) then px1=p8b(j1,i1-na) px2=p8b(j2,i1-na) py1=p8b(j1,i2-na) py2=p8b(j2,i2-na) else if(ion.eq.9) then px1=p9b(j1,i1-na) px2=p9b(j2,i1-na) py1=p9b(j1,i2-na) py2=p9b(j2,i2-na) endif end if dlgunx=px2-px1 px=px1+(pne-pn(j1))*dlgunx dlguny=py2-py1 py=py1+(pne-pn(j1))*dlguny delt=tt(i2)-tt(i1) if(delt.ne.0.) then dlgut=(py-px)/delt pf=px+(t0-tt(i1))*dlgut dlgun=dlgunx+(t0-tt(i1))/delt*(dlguny-dlgunx) else dlgut=0. pf=px dlgun=dlgunx endif pf=exp(xen*pf) dut=xmilen*pf*dlgut dun=(dlgun*pf-t*dut)/ane return end C C C ******************************************************************** C C subroutine pfni(ion,t,pf,dut,dun) c ================================= c c partition functions for Ni IV to Ni IX c c this routine interpolates within a grid c calculated from all levels predicted by c Kurucz (1992), i.e. over 12,000 levels per ion. c the partition functions depend only on T ! c (i.e. no level dissolution with increasing density) c TL 27-DEC-1994, 23-JAN-1995 c c Output: PF partition function c DUT d(PF)/dT c DUN d(PF)/d(ANE) c include 'IMPLIC.FOR' c dimension g0(6) dimension p4a(190),p4b(170) dimension p5a(190),p5b(170) dimension p6a(190),p6b(170) dimension p7a(190),p7b(170) dimension p8a(190),p8b(170) dimension p9a(190),p9b(170) parameter (xen=2.302585093,xmil=0.001) c data g0/28.,25.,6.,25.,28.,21./ c data p4a/ . 1.447,1.464,1.482,1.501,1.518,1.535,1.551,1.567,1.582,1.596, . 1.610,1.623,1.636,1.648,1.659,1.671,1.681,1.692,1.702,1.711, . 1.721,1.730,1.739,1.748,1.757,1.765,1.774,1.782,1.791,1.799, . 1.808,1.816,1.824,1.833,1.841,1.850,1.859,1.868,1.877,1.886, . 1.895,1.905,1.914,1.924,1.934,1.945,1.955,1.966,1.977,1.989, . 2.000,2.012,2.025,2.037,2.050,2.063,2.077,2.091,2.105,2.119, . 2.134,2.149,2.164,2.179,2.195,2.211,2.227,2.243,2.260,2.276, . 2.293,2.310,2.327,2.344,2.362,2.379,2.397,2.414,2.432,2.449, . 2.467,2.484,2.502,2.519,2.537,2.554,2.571,2.588,2.606,2.623, . 2.640,2.657,2.674,2.690,2.707,2.723,2.740,2.756,2.772,2.788, . 2.804,2.819,2.835,2.850,2.866,2.881,2.896,2.911,2.925,2.940, . 2.954,2.969,2.983,2.997,3.010,3.024,3.038,3.051,3.064,3.077, . 3.090,3.103,3.116,3.128,3.141,3.153,3.165,3.177,3.189,3.201, . 3.213,3.224,3.235,3.247,3.258,3.269,3.280,3.291,3.301,3.312, . 3.322,3.332,3.343,3.353,3.363,3.373,3.382,3.392,3.402,3.411, . 3.421,3.430,3.439,3.448,3.457,3.466,3.475,3.484,3.492,3.501, . 3.509,3.518,3.526,3.534,3.542,3.550,3.558,3.566,3.574,3.582, . 3.589,3.597,3.604,3.612,3.619,3.626,3.634,3.641,3.648,3.655, . 3.662,3.669,3.676,3.682,3.689,3.696,3.702,3.709,3.715,3.722/ data p4b/ . 3.589,3.597,3.604,3.612,3.619,3.626,3.634,3.641,3.648,3.655, . 3.662,3.669,3.676,3.682,3.689,3.696,3.702,3.709,3.715,3.722, . 3.728,3.734,3.740,3.747,3.753,3.759,3.765,3.771,3.777,3.782, . 3.788,3.794,3.800,3.805,3.811,3.816,3.822,3.827,3.833,3.838, . 3.843,3.849,3.854,3.859,3.864,3.869,3.874,3.879,3.884,3.889, . 3.894,3.899,3.904,3.909,3.913,3.918,3.923,3.927,3.932,3.936, . 3.941,3.945,3.950,3.954,3.959,3.963,3.967,3.972,3.976,3.980, . 3.984,3.988,3.993,3.997,4.001,4.005,4.009,4.013,4.017,4.021, . 4.024,4.028,4.032,4.036,4.040,4.043,4.047,4.051,4.055,4.058, . 4.062,4.065,4.069,4.072,4.076,4.079,4.083,4.086,4.090,4.093, . 4.097,4.100,4.103,4.107,4.110,4.113,4.116,4.120,4.123,4.126, . 4.129,4.132,4.135,4.138,4.141,4.144,4.148,4.151,4.154,4.157, . 4.159,4.162,4.165,4.168,4.171,4.174,4.177,4.180,4.182,4.185, . 4.188,4.191,4.193,4.196,4.199,4.202,4.204,4.207,4.210,4.212, . 4.215,4.217,4.220,4.223,4.225,4.228,4.230,4.233,4.235,4.238, . 4.240,4.243,4.245,4.247,4.250,4.252,4.255,4.257,4.259,4.262, . 4.264,4.266,4.268,4.271,4.273,4.275,4.278,4.280,4.282,4.284/ data p5a/ . 1.398,1.408,1.427,1.446,1.466,1.486,1.506,1.526,1.545,1.564, . 1.583,1.601,1.619,1.636,1.652,1.668,1.683,1.698,1.712,1.725, . 1.738,1.751,1.763,1.775,1.786,1.797,1.808,1.818,1.828,1.837, . 1.846,1.855,1.864,1.873,1.881,1.889,1.897,1.904,1.912,1.919, . 1.926,1.933,1.940,1.946,1.953,1.960,1.966,1.972,1.979,1.985, . 1.991,1.997,2.003,2.009,2.016,2.022,2.028,2.034,2.040,2.046, . 2.052,2.058,2.065,2.071,2.077,2.084,2.090,2.097,2.103,2.110, . 2.117,2.124,2.131,2.138,2.145,2.152,2.160,2.167,2.175,2.183, . 2.191,2.199,2.207,2.216,2.224,2.233,2.241,2.250,2.259,2.268, . 2.278,2.287,2.297,2.306,2.316,2.326,2.336,2.346,2.356,2.367, . 2.377,2.387,2.398,2.409,2.419,2.430,2.441,2.452,2.463,2.474, . 2.485,2.497,2.508,2.519,2.530,2.542,2.553,2.564,2.576,2.587, . 2.599,2.610,2.621,2.633,2.644,2.655,2.667,2.678,2.689,2.701, . 2.712,2.723,2.734,2.745,2.757,2.768,2.779,2.790,2.801,2.812, . 2.822,2.833,2.844,2.855,2.865,2.876,2.886,2.897,2.907,2.918, . 2.928,2.938,2.948,2.958,2.968,2.978,2.988,2.998,3.008,3.018, . 3.027,3.037,3.046,3.056,3.065,3.075,3.084,3.093,3.102,3.111, . 3.120,3.129,3.138,3.147,3.156,3.164,3.173,3.182,3.190,3.198, . 3.207,3.215,3.223,3.232,3.240,3.248,3.256,3.264,3.272,3.279/ data p5b/ . 3.120,3.129,3.138,3.147,3.156,3.164,3.173,3.182,3.190,3.198, . 3.207,3.215,3.223,3.232,3.240,3.248,3.256,3.264,3.272,3.279, . 3.287,3.295,3.303,3.310,3.318,3.325,3.333,3.340,3.347,3.355, . 3.362,3.369,3.376,3.383,3.390,3.397,3.404,3.411,3.417,3.424, . 3.431,3.438,3.444,3.451,3.457,3.464,3.470,3.476,3.483,3.489, . 3.495,3.501,3.507,3.514,3.520,3.526,3.531,3.537,3.543,3.549, . 3.555,3.561,3.566,3.572,3.578,3.583,3.589,3.594,3.600,3.605, . 3.610,3.616,3.621,3.626,3.632,3.637,3.642,3.647,3.652,3.657, . 3.662,3.667,3.672,3.677,3.682,3.687,3.692,3.697,3.701,3.706, . 3.711,3.716,3.720,3.725,3.729,3.734,3.738,3.743,3.747,3.752, . 3.756,3.761,3.765,3.769,3.774,3.778,3.782,3.786,3.790,3.795, . 3.799,3.803,3.807,3.811,3.815,3.819,3.823,3.827,3.831,3.835, . 3.839,3.843,3.846,3.850,3.854,3.858,3.862,3.865,3.869,3.873, . 3.876,3.880,3.884,3.887,3.891,3.894,3.898,3.901,3.905,3.908, . 3.912,3.915,3.918,3.922,3.925,3.929,3.932,3.935,3.939,3.942, . 3.945,3.948,3.951,3.955,3.958,3.961,3.964,3.967,3.970,3.974, . 3.977,3.980,3.983,3.986,3.989,3.992,3.995,3.998,4.001,4.004/ data p6a/ . 0.778,0.804,0.817,0.834,0.854,0.876,0.901,0.928,0.957,0.987, . 1.017,1.048,1.079,1.109,1.139,1.169,1.197,1.225,1.253,1.279, . 1.304,1.329,1.353,1.376,1.398,1.419,1.440,1.459,1.478,1.497, . 1.515,1.532,1.548,1.564,1.580,1.594,1.609,1.623,1.636,1.649, . 1.662,1.674,1.686,1.698,1.709,1.720,1.730,1.740,1.750,1.760, . 1.769,1.779,1.788,1.796,1.805,1.813,1.821,1.829,1.837,1.845, . 1.852,1.860,1.867,1.874,1.881,1.888,1.894,1.901,1.907,1.914, . 1.920,1.926,1.932,1.938,1.944,1.950,1.956,1.962,1.968,1.974, . 1.979,1.985,1.991,1.996,2.002,2.007,2.013,2.018,2.024,2.029, . 2.035,2.041,2.046,2.052,2.057,2.063,2.068,2.074,2.080,2.086, . 2.091,2.097,2.103,2.109,2.115,2.121,2.127,2.133,2.139,2.145, . 2.152,2.158,2.164,2.171,2.177,2.184,2.190,2.197,2.204,2.211, . 2.218,2.225,2.232,2.239,2.246,2.253,2.261,2.268,2.276,2.283, . 2.291,2.298,2.306,2.314,2.322,2.330,2.338,2.346,2.354,2.362, . 2.370,2.379,2.387,2.395,2.404,2.412,2.420,2.429,2.438,2.446, . 2.455,2.463,2.472,2.481,2.489,2.498,2.507,2.516,2.524,2.533, . 2.542,2.551,2.560,2.569,2.577,2.586,2.595,2.604,2.613,2.622, . 2.631,2.639,2.648,2.657,2.666,2.675,2.683,2.692,2.701,2.710, . 2.718,2.727,2.736,2.744,2.753,2.761,2.770,2.779,2.787,2.796/ data p6b/ . 2.631,2.639,2.648,2.657,2.666,2.675,2.683,2.692,2.701,2.710, . 2.718,2.727,2.736,2.744,2.753,2.761,2.770,2.779,2.787,2.796, . 2.804,2.812,2.821,2.829,2.838,2.846,2.854,2.862,2.871,2.879, . 2.887,2.895,2.903,2.911,2.919,2.927,2.935,2.943,2.951,2.958, . 2.966,2.974,2.982,2.989,2.997,3.005,3.012,3.020,3.027,3.035, . 3.042,3.049,3.057,3.064,3.071,3.078,3.086,3.093,3.100,3.107, . 3.114,3.121,3.128,3.135,3.141,3.148,3.155,3.162,3.169,3.175, . 3.182,3.188,3.195,3.202,3.208,3.214,3.221,3.227,3.234,3.240, . 3.246,3.252,3.259,3.265,3.271,3.277,3.283,3.289,3.295,3.301, . 3.307,3.313,3.319,3.325,3.330,3.336,3.342,3.348,3.353,3.359, . 3.364,3.370,3.376,3.381,3.386,3.392,3.397,3.403,3.408,3.413, . 3.419,3.424,3.429,3.434,3.440,3.445,3.450,3.455,3.460,3.465, . 3.470,3.475,3.480,3.485,3.490,3.495,3.499,3.504,3.509,3.514, . 3.518,3.523,3.528,3.533,3.537,3.542,3.546,3.551,3.555,3.560, . 3.564,3.569,3.573,3.578,3.582,3.586,3.591,3.595,3.599,3.604, . 3.608,3.612,3.616,3.621,3.625,3.629,3.633,3.637,3.641,3.645, . 3.649,3.653,3.657,3.661,3.665,3.669,3.673,3.677,3.681,3.685/ data p7a/ . 1.398,1.398,1.398,1.398,1.406,1.425,1.443,1.461,1.480,1.498, . 1.516,1.534,1.551,1.568,1.585,1.601,1.616,1.631,1.646,1.660, . 1.674,1.687,1.700,1.712,1.724,1.736,1.747,1.758,1.768,1.778, . 1.788,1.797,1.806,1.815,1.824,1.832,1.840,1.848,1.855,1.863, . 1.870,1.877,1.883,1.890,1.896,1.902,1.908,1.914,1.920,1.925, . 1.931,1.936,1.941,1.946,1.951,1.956,1.960,1.965,1.969,1.974, . 1.978,1.982,1.986,1.990,1.994,1.998,2.001,2.005,2.009,2.012, . 2.016,2.019,2.022,2.026,2.029,2.032,2.035,2.038,2.041,2.044, . 2.047,2.050,2.053,2.056,2.059,2.061,2.064,2.067,2.069,2.072, . 2.075,2.077,2.080,2.082,2.085,2.088,2.090,2.093,2.095,2.098, . 2.100,2.103,2.105,2.107,2.110,2.112,2.115,2.117,2.120,2.122, . 2.125,2.127,2.130,2.132,2.135,2.137,2.140,2.142,2.145,2.148, . 2.150,2.153,2.155,2.158,2.161,2.163,2.166,2.169,2.172,2.175, . 2.178,2.180,2.183,2.186,2.189,2.192,2.195,2.198,2.202,2.205, . 2.208,2.211,2.215,2.218,2.221,2.225,2.228,2.232,2.235,2.239, . 2.243,2.246,2.250,2.254,2.258,2.261,2.265,2.269,2.273,2.277, . 2.282,2.286,2.290,2.294,2.299,2.303,2.307,2.312,2.316,2.321, . 2.325,2.330,2.335,2.339,2.344,2.349,2.354,2.359,2.364,2.369, . 2.374,2.379,2.384,2.389,2.394,2.399,2.405,2.410,2.415,2.420/ data p7b/ . 2.325,2.330,2.335,2.339,2.344,2.349,2.354,2.359,2.364,2.369, . 2.374,2.379,2.384,2.389,2.394,2.399,2.405,2.410,2.415,2.420, . 2.426,2.431,2.437,2.442,2.448,2.453,2.459,2.464,2.470,2.476, . 2.481,2.487,2.493,2.498,2.504,2.510,2.516,2.521,2.527,2.533, . 2.539,2.545,2.551,2.556,2.562,2.568,2.574,2.580,2.586,2.592, . 2.598,2.604,2.610,2.616,2.622,2.628,2.634,2.640,2.646,2.652, . 2.658,2.664,2.670,2.676,2.682,2.687,2.693,2.699,2.705,2.711, . 2.717,2.723,2.729,2.735,2.741,2.747,2.753,2.759,2.764,2.770, . 2.776,2.782,2.788,2.794,2.799,2.805,2.811,2.817,2.823,2.828, . 2.834,2.840,2.846,2.851,2.857,2.863,2.868,2.874,2.879,2.885, . 2.891,2.896,2.902,2.907,2.913,2.918,2.924,2.929,2.935,2.940, . 2.945,2.951,2.956,2.962,2.967,2.972,2.978,2.983,2.988,2.993, . 2.999,3.004,3.009,3.014,3.019,3.025,3.030,3.035,3.040,3.045, . 3.050,3.055,3.060,3.065,3.070,3.075,3.080,3.085,3.090,3.095, . 3.099,3.104,3.109,3.114,3.119,3.123,3.128,3.133,3.138,3.142, . 3.147,3.152,3.156,3.161,3.165,3.170,3.175,3.179,3.184,3.188, . 3.193,3.197,3.202,3.206,3.210,3.215,3.219,3.224,3.228,3.232/ data p8a/ . 1.447,1.447,1.447,1.447,1.447,1.447,1.459,1.475,1.489,1.504, . 1.518,1.531,1.544,1.556,1.568,1.580,1.591,1.602,1.612,1.622, . 1.631,1.640,1.649,1.658,1.666,1.674,1.682,1.689,1.696,1.703, . 1.710,1.716,1.722,1.728,1.734,1.740,1.745,1.751,1.756,1.761, . 1.766,1.770,1.775,1.779,1.784,1.788,1.792,1.796,1.800,1.804, . 1.807,1.811,1.814,1.818,1.821,1.824,1.827,1.831,1.834,1.836, . 1.839,1.842,1.845,1.848,1.850,1.853,1.855,1.858,1.860,1.863, . 1.865,1.867,1.870,1.872,1.874,1.876,1.878,1.880,1.882,1.884, . 1.886,1.888,1.890,1.892,1.894,1.896,1.898,1.900,1.902,1.903, . 1.905,1.907,1.909,1.911,1.912,1.914,1.916,1.917,1.919,1.921, . 1.923,1.924,1.926,1.928,1.929,1.931,1.933,1.934,1.936,1.938, . 1.939,1.941,1.943,1.945,1.946,1.948,1.950,1.951,1.953,1.955, . 1.957,1.959,1.960,1.962,1.964,1.966,1.968,1.970,1.971,1.973, . 1.975,1.977,1.979,1.981,1.983,1.985,1.987,1.989,1.991,1.993, . 1.995,1.998,2.000,2.002,2.004,2.006,2.009,2.011,2.013,2.015, . 2.018,2.020,2.023,2.025,2.027,2.030,2.032,2.035,2.037,2.040, . 2.043,2.045,2.048,2.051,2.053,2.056,2.059,2.062,2.064,2.067, . 2.070,2.073,2.076,2.079,2.082,2.085,2.088,2.091,2.094,2.097, . 2.100,2.103,2.107,2.110,2.113,2.116,2.120,2.123,2.126,2.130/ data p8b/ . 2.070,2.073,2.076,2.079,2.082,2.085,2.088,2.091,2.094,2.097, . 2.100,2.103,2.107,2.110,2.113,2.116,2.120,2.123,2.126,2.130, . 2.133,2.137,2.140,2.143,2.147,2.151,2.154,2.158,2.161,2.165, . 2.168,2.172,2.176,2.180,2.183,2.187,2.191,2.195,2.198,2.202, . 2.206,2.210,2.214,2.218,2.222,2.226,2.230,2.233,2.237,2.241, . 2.245,2.250,2.254,2.258,2.262,2.266,2.270,2.274,2.278,2.282, . 2.286,2.291,2.295,2.299,2.303,2.307,2.312,2.316,2.320,2.324, . 2.329,2.333,2.337,2.341,2.346,2.350,2.354,2.359,2.363,2.367, . 2.371,2.376,2.380,2.384,2.389,2.393,2.397,2.402,2.406,2.410, . 2.415,2.419,2.423,2.428,2.432,2.436,2.441,2.445,2.449,2.454, . 2.458,2.462,2.467,2.471,2.475,2.480,2.484,2.488,2.493,2.497, . 2.501,2.506,2.510,2.514,2.519,2.523,2.527,2.531,2.536,2.540, . 2.544,2.548,2.553,2.557,2.561,2.565,2.570,2.574,2.578,2.582, . 2.586,2.591,2.595,2.599,2.603,2.607,2.611,2.616,2.620,2.624, . 2.628,2.632,2.636,2.640,2.644,2.648,2.652,2.656,2.661,2.665, . 2.669,2.673,2.677,2.681,2.685,2.689,2.693,2.696,2.700,2.704, . 2.708,2.712,2.716,2.720,2.724,2.728,2.732,2.736,2.739,2.743/ data p9a/ . 1.322,1.322,1.322,1.322,1.322,1.322,1.322,1.322,1.322,1.325, . 1.334,1.342,1.351,1.358,1.366,1.373,1.380,1.386,1.392,1.398, . 1.404,1.409,1.415,1.420,1.425,1.429,1.434,1.438,1.442,1.446, . 1.450,1.454,1.457,1.461,1.464,1.467,1.470,1.473,1.476,1.479, . 1.482,1.485,1.487,1.490,1.492,1.495,1.497,1.499,1.501,1.503, . 1.505,1.507,1.509,1.511,1.513,1.515,1.517,1.519,1.520,1.522, . 1.524,1.525,1.527,1.528,1.530,1.531,1.533,1.534,1.535,1.537, . 1.538,1.539,1.541,1.542,1.543,1.545,1.546,1.547,1.548,1.549, . 1.551,1.552,1.553,1.554,1.555,1.556,1.558,1.559,1.560,1.561, . 1.562,1.563,1.565,1.566,1.567,1.568,1.569,1.570,1.571,1.573, . 1.574,1.575,1.576,1.577,1.579,1.580,1.581,1.582,1.584,1.585, . 1.586,1.588,1.589,1.590,1.592,1.593,1.594,1.596,1.597,1.599, . 1.600,1.602,1.603,1.605,1.606,1.608,1.609,1.611,1.612,1.614, . 1.616,1.617,1.619,1.621,1.622,1.624,1.626,1.628,1.630,1.631, . 1.633,1.635,1.637,1.639,1.641,1.643,1.645,1.647,1.649,1.651, . 1.653,1.655,1.657,1.659,1.661,1.664,1.666,1.668,1.670,1.673, . 1.675,1.677,1.679,1.682,1.684,1.686,1.689,1.691,1.694,1.696, . 1.699,1.701,1.704,1.706,1.709,1.711,1.714,1.716,1.719,1.722, . 1.724,1.727,1.729,1.732,1.735,1.738,1.740,1.743,1.746,1.749/ data p9b/ . 1.699,1.701,1.704,1.706,1.709,1.711,1.714,1.716,1.719,1.722, . 1.724,1.727,1.729,1.732,1.735,1.738,1.740,1.743,1.746,1.749, . 1.751,1.754,1.757,1.760,1.763,1.765,1.768,1.771,1.774,1.777, . 1.780,1.783,1.786,1.789,1.792,1.795,1.798,1.801,1.804,1.807, . 1.810,1.813,1.816,1.819,1.822,1.825,1.828,1.831,1.834,1.837, . 1.840,1.843,1.847,1.850,1.853,1.856,1.859,1.862,1.865,1.869, . 1.872,1.875,1.878,1.881,1.884,1.888,1.891,1.894,1.897,1.901, . 1.904,1.907,1.910,1.913,1.917,1.920,1.923,1.926,1.930,1.933, . 1.936,1.939,1.943,1.946,1.949,1.952,1.956,1.959,1.962,1.965, . 1.969,1.972,1.975,1.978,1.982,1.985,1.988,1.992,1.995,1.998, . 2.001,2.005,2.008,2.011,2.014,2.018,2.021,2.024,2.027,2.031, . 2.034,2.037,2.040,2.044,2.047,2.050,2.053,2.057,2.060,2.063, . 2.066,2.070,2.073,2.076,2.079,2.083,2.086,2.089,2.092,2.095, . 2.099,2.102,2.105,2.108,2.111,2.115,2.118,2.121,2.124,2.127, . 2.131,2.134,2.137,2.140,2.143,2.146,2.149,2.153,2.156,2.159, . 2.162,2.165,2.168,2.171,2.175,2.178,2.181,2.184,2.187,2.190, . 2.193,2.196,2.199,2.202,2.205,2.208,2.212,2.215,2.218,2.221/ c if(t.lt.12000.) then pf=g0(ion-3) dut=0. dun=0. return endif c it=int(t/1000.) if(it.ge.350) it=349 t1=1000.*it t2=t1+1000. if(ion.eq.4) then if(t.le.200000.) then xu1=p4a(it-10) xu2=p4a(it-9) else xu1=p4b(it-180) xu2=p4b(it-179) endif else if(ion.eq.5) then if(t.le.200000.) then xu1=p5a(it-10) xu2=p5a(it-9) else xu1=p5b(it-180) xu2=p5b(it-179) endif else if(ion.eq.6) then if(t.le.200000.) then xu1=p6a(it-10) xu2=p6a(it-9) else xu1=p6b(it-180) xu2=p6b(it-179) endif else if(ion.eq.7) then if(t.le.200000.) then xu1=p7a(it-10) xu2=p7a(it-9) else xu1=p7b(it-180) xu2=p7b(it-179) endif else if(ion.eq.8) then if(t.le.200000.) then xu1=p8a(it-10) xu2=p8a(it-9) else xu1=p8b(it-180) xu2=p8b(it-179) endif else if(ion.eq.9) then if(t.le.200000.) then xu1=p9a(it-10) xu2=p9a(it-9) else xu1=p9b(it-180) xu2=p9b(it-179) endif endif c dxt=xmil*(xu2-xu1) xu=xu1+(t-t1)*dxt pf=exp(xen*xu) dut=xen*pf*dxt dun=0. return end c c c ****************************************************************** c c subroutine opfrac(iat,ion,t,ane,pf,fra) c ======================================= c include 'IMPLIC.FOR' parameter (mtemp =100, * melec = 60, * mion1 = 30, * mion2 = 32, * mdat = 17, * mstag = 258) parameter (inp=71) dimension frac0(mion2),ioo(mion2),idat(mion1) dimension gg(mion1,mdat),g0(mion1),z0(mion2) dimension uu(mion1,mdat),u0(mion1) dimension indxat(mion1,mdat),indxa(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) common/pfoptb/pfop(mtemp,melec,mstag),pfophm(mtemp,melec), * frac(mtemp,melec,mstag), * frop(mtemp,melec,mstag),itemp(mtemp) 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)) 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 indxat /1,2,28*0, * 3,4,5,27*0, * 6,7,8,9,10,11,12,23*0, * 13,14,15,16,17,18,19,20,22*0, * 21,22,23,24,25,26,27,28,29,21*0, * 30,31,32,33,34,35,36,37,38,39,40,19*0, * 41,42,43,44,45,46,47,48,49,50,51,52,18*0, * 53,54,55,56,57,58,59,60,61,62,63,64,65,17*0, * 66,67,68,69,70,71,72,73,74,75,76,77,78,79,16*0, * 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,15*0, * 95,96,97,98,99,100,101,102,103,104,105,106,107, * 108,109,110,111,13*0, * 112,113,114,115,116,117,118,119,120,121,122,123, * 124,125,126,127,128,129,130,11*0, * 131,132,133,134,135,136,137,138,139,140,141,142, * 143,144,145,146,147,148,149,150,151,9*0, * 152,153,154,155,156,157,158,159,160,161,162,163, * 164,165,166,167,168,169,170,171,172,173,174,175, * 176,5*0, * 177,178,179,180,181,182,183,184,185,186,187,188, * 189,190,191,192,193,194,195,196,197,198,199,200, * 201,202,4*0, * 203,204,205,206,207,208,209,210,211,212,213,214, * 215,216,217,218,219,220,221,222,223,224,225,226, * 227,228,229,3*0, * 230,231,232,233,234,235,236,237,238,239,240,241, * 242,243,244,245,246,247,248,249,250,251,252,253, * 254,255,256,257,258,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 c If the routine is called with IAT=0, initialization: c read the ionization fractions form the Opacity Project tables, c and evaluate partition functions (assuming that the partition c function for the highest ion is eqaul to the statistical weight of c the ground state. c The table of partition functions, in the OP temperatures and c electron densities, are stored in the array PFOP c C Read is done in a loop over the OP species c fra=1. if(iat.gt.0) go to 50 do 40 iatnum=1,28 if(idat(iatnum).eq.0) go to 40 c g0(iatnum+1)=1. indxa(iatnum+1)=indxat(iatnum+1,idat(iatnum)) do i=1,iatnum ig0=iatnum-i+1 g0(ig0)=gg(i,idat(iatnum)) indxa(i)=indxat(i,idat(iatnum)) u0(i)=uu(i,idat(iatnum))*1000. enddo c c initializion of partition functions by the statistical weights of c the ground state c do i=1,iatnum+1 indx=indxa(i) pf0=g0(i) do it=1,mtemp do ieind=1,melec pfop(it,ieind,indx)=pf0 enddo enddo enddo c if(iatnum.eq.1) open(inp,file='./data/ioniz.dat',status='old') 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+2,min(ion1,ion0+3)+2) 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+2,min(ion1,ion0+4*ilin+3)+2) end do end if ieind=iee/2 ion0=ion0+2 ion1=ion1+2 do ionn=ion0,ion1 iation=iatnum+2-ionn if(ionn.lt.iatnum+2) then if(ionn.eq.ion0) then z0(ionn)=g0(iation) else z0(ionn)=frac0(ionn)/frac0(ionn-1)*safac*z0(ionn-1) z0(ionn)=z0(ionn)*exp(-u0(iation)/tkcm) endif pfop(it,ieind,indxa(iation))=z0(ionn) frac(it,ieind,indxa(iation))=frac0(ionn) else u0hm=6090.5 z0hm=frac0(ionn)/frac0(ionn-1)*safac z0hm=z0hm*exp(-u0hm/tkcm) pfophm(it,ieind)=z0hm end if end do end do end do 40 continue 601 format(3i4,2x,4(i4,1x,e9.3)) 602 format(14x,4(i4,1x,e9.3)) return C C ---------------------------------------------------------- C C If the routine is called with IAT>0, evaluate the partition C function of atom IAT, ion ION, C for temperature T and electron density ANE C Evaluation is done by interpolation from previously computed C Opacity Project values C 50 continue c xt=log10(t) kt0=2*int(20.*xt) xne=log10(ane) kn0=int(2.*xne) c iatnum=iat if(idat(iatnum).eq.0) then write(6,600) iatnum iatnum=-1 600 format(' data for element no. ',i3,' do not exist') return end if indx=indxat(ion,idat(iatnum)) if(kt0.lt.itemp(1)) then kt1=1 write(6,611) t 611 format(' (FRACOP) Extrapol. in T (low)',f7.0) go to 120 endif if(kt0.ge.itemp(ntt)) then kt1=ntt-1 write(6,612) t 612 format(' (FRACOP) Extrapol. in T (high)',f12.0) go to 120 endif do it=1,ntt if(kt0.eq.itemp(it)) then kt1=it go to 120 endif end do 120 continue if(kn0.lt.1) then kn1=1 go to 130 endif if(kn0.ge.60) then kn1=59 write(6,614) xne 614 format(' (FRACOP) Extrapol. in Ne (high)',f9.4) go to 130 endif kn1=kn0 130 continue xt1=0.025*itemp(kt1) dxt=0.05 at1=(xt-xt1)/dxt xn1=0.5*kn1 dxn=0.5 an1=(xne-xn1)/dxn x11=pfop(kt1,kn1,indx) x21=pfop(kt1+1,kn1,indx) x12=pfop(kt1,kn1+1,indx) x22=pfop(kt1+1,kn1+1,indx) 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=log10(x11) x21=log10(x21) x12=log10(x12) x22=log10(x22) xx1=x11+at1*(x21-x11) xx2=x12+at1*(x22-x12) rrx=xx1+an1*(xx2-xx1) rrx=exp(2.3025851*rrx) endif pf=rrx c return end c c ****************************************************************** c C SUBROUTINE PFHEAV(IIZ,JNION,MODE,t,ane,u) C ========================================= C c subset of kurucz's pfsaha for Z>28. c removed code for Z<28; crp- 28 aug, 1995 C EDITED 27 JULY 1994 BY GMW - REPLACED PT III PF COEFF. AND IP C MODE 3 RETURNS PARTITION FUNCTION C INCLUDE 'IMPLIC.FOR' REAL*8 IP PARAMETER (DEBCON=1./2.8965E-18, * TVCON=8.6171E-5, * HIONEV=13.595, * ONE=1., * HALF=0.5, * THIRD=1./3., * X18=1./18., * X120=1./120., * T211=2000./11.) c DIMENSION IP(6),PART(6),POTLO(6) DIMENSION SCALE(4) DIMENSION NNN(6*218) DIMENSION NNN16(54),NNN17(54),NNN18(54),NNN19(54),NNN20(54) DIMENSION NNN21(54),NNN22(54),NNN23(54),NNN24(54),NNN25(54) DIMENSION NNN26(54),NNN27(54),NNN28(54),NNN29(54),NNN30(54) DIMENSION NNN31(54),NNN32(54),NNN33(54),NNN34(54),NNN35(54) DIMENSION NNN36(54),NNN37(54),NNN38(54),NNN39(54),NNN40(12) EQUIVALENCE (NNN( 811-810),NNN16(1)) EQUIVALENCE (NNN( 865-810),NNN17(1)),(NNN( 919-810),NNN18(1)) EQUIVALENCE (NNN( 973-810),NNN19(1)),(NNN(1027-810),NNN20(1)) EQUIVALENCE (NNN(1081-810),NNN21(1)),(NNN(1135-810),NNN22(1)) EQUIVALENCE (NNN(1189-810),NNN23(1)),(NNN(1243-810),NNN24(1)) EQUIVALENCE (NNN(1297-810),NNN25(1)),(NNN(1351-810),NNN26(1)) EQUIVALENCE (NNN(1405-810),NNN27(1)),(NNN(1459-810),NNN28(1)) EQUIVALENCE (NNN(1513-810),NNN29(1)),(NNN(1567-810),NNN30(1)) EQUIVALENCE (NNN(1621-810),NNN31(1)),(NNN(1675-810),NNN32(1)) EQUIVALENCE (NNN(1729-810),NNN33(1)),(NNN(1783-810),NNN34(1)) EQUIVALENCE (NNN(1837-810),NNN35(1)),(NNN(1891-810),NNN36(1)) EQUIVALENCE (NNN(1945-810),NNN37(1)),(NNN(1999-810),NNN38(1)) EQUIVALENCE (NNN(2053-810),NNN39(1)),(NNN(2107-810),NNN40(1)) C ( 1)( 2) ( 3)( 4) ( 5)( 6) ( 7)( 8) ( 9)(10) ( IP ) G REF DATA NNN16/ 1 227027622, 306233052, 356839222, 446052912, 652382292, 763314, 2 108416342, 222428472, 353944332, 577378932, 110314303, 1814900, 3 198724282, 293236452, 468362702, 86511123, 136016073, 3516000, 4 279836622, 461857562, 720693022, 124915873, 192522633, 5600000, 5 262136422, 501167232, 87911303, 138916483, 190721673, 7900000, 6 201620781, 231026761, 314737361, 450555381, 692386911, 772301, 7 109415761, 247938311, 58910042, 190937022, 68311693, 2028903, 8 897195961, 107212972, 165021182, 260230862, 356940532, 3682900, 9 100010001, 100410231, 108712611, 167124841, 388460411, 939102/ DATA NNN17/ 1 200020021, 201620761, 223726341, 351352061, 80812472, 1796001, 2 100610471, 122617301, 300566361, 149924112, 332342352, 3970000, 3 403245601, 493151431, 529654331, 559358091, 611065171, 600000, 4 99710051, 104511541, 135016501, 208226431, 321837921, 2050900, 5 199820071, 204521391, 229124761, 266028451, 302932131, 3070000, 6 502665261, 755183501, 901496201, 102410942, 117912812, 787900, 7 422848161, 512153401, 557458941, 636270361, 794489061, 1593000, 8 100010261, 114613921, 175221251, 249828711, 324436181, 3421000, 9 403143241, 491856701, 649173781, 840396751, 113013392, 981000/ DATA NNN18/ 1 593676641, 884697521, 105911572, 129515012, 180322212, 1858700, 2 484470541, 91510972, 125614082, 157017612, 199722912, 2829900, 3 630172361, 799686381, 919797221, 102810942, 117712832, 975000, 4 438055511, 691582151, 94510732, 121413672, 152016732, 2150000, 5 651982921, 94610382, 113212492, 139515462, 169718482, 3200000, 6 437347431, 498951671, 538559501, 74710812, 169126672, 1183910, 7 705183611, 93510092, 111614162, 222932532, 427652992, 2160000, 8 510869921, 87410312, 123116552, 236530712, 377744832, 3590000, 9 100010001, 100010051, 105012781, 198535971, 65911422, 1399507/ DATA NNN19/ 1 461049811, 522254261, 609088131, 168935052, 68612253, 2455908, 2 759990901, 101911142, 129017782, 302856642, 99414333, 3690000, 3 200020011, 200720361, 211523021, 269434141, 459163351, 417502, 4 100010001, 100110321, 129524961, 61014202, 291753192, 2750004, 5 473650891, 533156051, 66810932, 232950852, 99915303, 4000000, 6 100110041, 104111741, 146019721, 281941411, 607785251, 569202, 7 202621931, 255331271, 384347931, 624085761, 122417632, 1102600, 8 100010001, 100110321, 129524961, 61014202, 291753192, 4300000, 9 791587851, 100012192, 155119942, 254031782, 389946932, 637900/ DATA NNN20/ 1 118217102, 220827002, 319036792, 416646512, 513256072, 1223000, 2 92510012, 104710862, 112311612, 120212472, 132814282, 2050000, 3 141320802, 291439702, 531170262, 92712273, 162521053, 684000, 4 354454352, 724689652, 107212643, 148517093, 193321573, 1312900, 5 209727032, 324537052, 415446282, 510255752, 604965222, 2298000, 6 256636022, 465759302, 749693962, 116514243, 171520333, 687900, 7 335157222, 84511463, 147718363, 221826083, 299933893, 1431900, 8 223725352, 280830972, 340937362, 406844002, 473150632, 2503900, 9 703972941, 82610822, 154822682, 327244912, 571469372, 709900/ DATA NNN21/ 1 75714552, 274347322, 718897632, 123414913, 174920063, 1614900, 2 267645462, 669890262, 115514323, 173620673, 242528083, 2714900, 3 90613732, 184823562, 291735332, 419949102, 565764332, 728000, 4 131318312, 227126932, 311735452, 397644072, 483852692, 1525900, 5 204721673, 234725733, 284031463, 348738613, 426546943, 3000000, 6 176824122, 318941082, 515263202, 761790472, 106112303, 736400, 7 221934642, 501968372, 88911173, 136316243, 189221613, 1675900, 8 210622722, 241025422, 267928262, 297731272, 327834282, 2846000, 9 148520202, 255230902, 364942462, 489656082, 638872352, 746000/ DATA NNN22/ 1 153421292, 288137912, 484660322, 720187062, 101011483, 1807000, 2 254537212, 492362292, 770592182, 107312243, 137615273, 3104900, 3 115919651, 320746011, 607576761, 95011642, 141817172, 832900, 4 755087211, 105913442, 173122222, 282034722, 412247732, 1941900, 5 180223462, 289735212, 414247632, 538460052, 662672472, 3292000, 6 200020001, 200220141, 206422141, 257633021, 455164681, 757403, 7 100810581, 125817401, 260641031, 66210072, 135316982, 2148000, 8 795887491, 97711762, 156620252, 248329422, 340038582, 3481900, 9 100010001, 100410241, 109212891, 176827421, 444268771, 899003/ DATA NNN23/ 1 200020021, 201720921, 233329881, 451475371, 127520782, 1690301, 2 100310281, 114815371, 246138311, 519265531, 791492761, 3747000, 3 252431921, 368440461, 433746521, 512259221, 723389021, 578400, 4 100110071, 104611651, 146118581, 225426511, 304734431, 1886000, 5 200120111, 205021611, 243628031, 317035371, 390442701, 2802900, 6 232637101, 488058571, 669074381, 816189091, 97210632, 734200, 7 286335941, 408144471, 479351961, 571862901, 686274341, 1462700, 8 100010251, 114013811, 175321601, 256829751, 338337901, 3049000, 9 404043481, 494656811, 646772781, 813490751, 101411372, 863900/ DATA NNN24/ 1 303147981, 618472951, 827392621, 103711702, 131214532, 1650000, 2 313037601, 429347901, 536260591, 689477591, 862494881, 2529900, 3 526258801, 657372351, 784284071, 897095741, 102711082, 900900, 4 440855541, 686481251, 93810792, 125414792, 176321132, 1860000, 5 349054751, 699883081, 96611302, 134216202, 197724212, 2800000, 6 405342041, 438645621, 475751071, 587974491, 102214572, 1045404, 7 568567471, 773485861, 94510362, 112712182, 130914002, 1909000, 8 514269581, 86910562, 130716652, 215327742, 351843662, 3200000, 9 100010001, 100010091, 109515351, 291060661, 119621482, 1212716/ DATA NNN25/ 1 414844131, 465649111, 538464651, 87112232, 158019362, 2120000, 2 615475101, 867797531, 112213462, 157618062, 203622662, 3209900, 3 200020001, 201020501, 215623871, 283536181, 462756261, 389300, 4 100010001, 100310371, 119016501, 269146361, 77912412, 2510000, 5 424445601, 481750061, 516953311, 549356551, 581759791, 3500000, 6 101210791, 135119351, 282340571, 574580391, 111015062, 521002, 7 262638611, 504160621, 698579371, 91010692, 129115952, 1000000, 8 100010001, 100310351, 118416321, 264945521, 76512182, 3700000, 9 71111992, 172323592, 312540402, 510763182, 765791012, 558000/ DATA NNN26/ 1 204529582, 383647882, 582469262, 807992692, 104911723, 1106000, 2 94712552, 148416582, 179819212, 203621522, 227424042, 1916900, 3 295959132, 103515693, 215527593, 335939413, 449650223, 565000, 4 79718153, 289639443, 495159253, 686877533, 863794813, 1085000, 5 298640242, 475053692, 596965912, 725379692, 872094692, 2008000, 6 460693672, 158523823, 327242303, 519661563, 709379783, 541900, 7 455480232, 114014653, 178521013, 240927073, 299232633, 1055000, 8 46410533, 183826893, 354443773, 518459633, 674375243, 2320000, 9 139623042, 364860002, 96114603, 209828633, 373446973, 549000/ DATA NNN27/ 1 460493692, 158523823, 327142303, 519661563, 709279783, 1073000, 2 455480232, 114014653, 178521013, 240927073, 299232633, 2000000, 3 131720482, 280535692, 441254492, 676583972, 103412583, 555000, 4 139623042, 364860002, 96114603, 209828633, 373446973, 1089900, 5 460493682, 158523823, 327142303, 519661563, 709279783, 2000000, 6 92915672, 222431062, 444763802, 89612173, 159520253, 562900, 7 315059662, 97114563, 204627093, 342541693, 490556383, 1106900, 8 269037812, 520270372, 91111273, 133915483, 172719093, 2000000, 9 800080571, 851699301, 127617362, 240433032, 444958442, 568000/ DATA NNN28/ 1 125416052, 211828182, 375549622, 644381732, 101112213, 1125000, 2 800080571, 851699301, 127617362, 240433032, 444958442, 2000000, 3 240432982, 427555202, 708489962, 112613853, 167319843, 615900, 4 534793262, 139219123, 247730843, 371043333, 495055893, 1210000, 5 364145232, 514756362, 604864112, 673870372, 732276072, 2000000, 6 480767202, 89011393, 144118243, 230028753, 354142883, 584900, 7 480767192, 89011393, 144118243, 230028753, 354142883, 1151900, 8 480767202, 89011393, 144118243, 230028753, 354142883, 2000000, 9 343147532, 645887152, 115314793, 183322063, 257729373, 593000/ DATA NNN29/ 1 343147532, 645887142, 115314793, 183322063, 257729373, 1167000, 2 343147532, 645887142, 115314793, 183322063, 257729373, 2000000, 3 222635002, 542276772, 100312353, 145716713, 187020703, 602000, 4 222635002, 542276772, 100312353, 145716713, 187020703, 1180000, 5 222635002, 542276772, 100312353, 145716713, 187020703, 2000000, 6 133715382, 209130152, 429859382, 79410293, 129815983, 609900, 7 265934782, 497877532, 120517733, 245032063, 400448073, 1193000, 8 265934782, 497877532, 120517733, 245032063, 400448073, 2000000, 9 800381111, 87510702, 147621462, 310343462, 585475982, 618000/ DATA NNN30/ 1 156718872, 279244452, 678196342, 128316243, 197823443, 1205000, 2 93517192, 364666132, 103414613, 192624193, 293334613, 2370000, 3 100010011, 101310651, 118613951, 169120661, 250629971, 625000, 4 200120901, 270345231, 81714042, 223533112, 461959862, 1217000, 5 100312561, 250851931, 91914182, 198626022, 323638692, 2000000, 6 514664441, 759086851, 99211442, 133315612, 182721252, 609900, 7 125924831, 438667801, 98714112, 199727872, 380850742, 1389900, 8 323948621, 661297271, 158626482, 426865032, 93712843, 1900000, 9 659294081, 128016962, 222528952, 372047062, 585171462, 700000/ DATA NNN31/ 1 99117882, 274638812, 520867322, 84410313, 123314453, 1489900, 2 187427702, 343739872, 448049452, 539358282, 625266642, 2329900, 3 65210892, 171325762, 373552252, 705192012, 116414343, 787900, 4 192837842, 600784802, 111113823, 165419233, 218524383, 1620000, 5 99117872, 274638812, 520867312, 84410313, 123314453, 2400000, 6 398981651, 130019172, 273438022, 516168382, 88411163, 797900, 7 131429482, 523279952, 111414623, 183422233, 262130233, 1770000, 8 192837842, 600784792, 111113823, 165419233, 218524383, 2500000, 9 600963001, 75910412, 150121572, 301940972, 539168952, 787000/ DATA NNN32/ 1 73710852, 190731262, 464964142, 83810503, 127315053, 1660000, 2 131429482, 523279952, 111414623, 183422233, 262130233, 2600000, 3 110815502, 216829732, 398752322, 672484682, 104612673, 850000, 4 168225972, 362046562, 566766422, 757484612, 93010103, 1700000, 5 73710852, 190731262, 464964142, 83810503, 127315053, 2700000, 6 129117892, 239430882, 388748292, 596173252, 89510843, 910000, 7 110815502, 216829732, 398752322, 672484682, 104612673, 2000000, 8 168225972, 362046562, 566766422, 757484612, 93010103, 2800000, 9 158918512, 207523002, 254328242, 316335762, 407246582, 900000/ DATA NNN33/ 1 98115462, 224930742, 401150612, 623475412, 89910583, 1855900, C 2 110815502, 216829732, 398752322, 672484682, 104612673, 2900000, 2 146323292, 354651802, 74810923, 161723953, 348749363, 3322700, 3 203222611, 265731251, 364042301, 494958601, 702084731, 922000, 4 120521331, 357753801, 75310062, 130516572, 206925452, 2050000, 5 651780821, 108814772, 195925252, 316338622, 460853882, 3000000, 6 100010001, 100110111, 105211851, 152122101, 341552811, 1043002, 7 200320211, 210023021, 268834231, 480472341, 111416912, 1875000, 8 104012871, 186129471, 458664151, 82410072, 119013732, 3420000, 9 200420711, 222424271, 265429161, 325637371, 442853911, 610500/ DATA NNN34/ 1 100010021, 101910801, 121414641, 189525811, 358949721, 2041900, 2 200020311, 216624611, 296337451, 489064791, 85711212, 2979900, 3 103411711, 147819101, 244331781, 434862751, 93113762, 741404, 4 204122231, 248227841, 311535621, 429153941, 651976431, 1502800, 5 100210131, 106812201, 154522671, 381665951, 95512512, 3192900, 6 400140351, 416944121, 474851591, 564362181, 690477231, 728700, 7 106814451, 204427341, 350744811, 586879131, 108314772, 1667900, 8 205523051, 264830231, 345439921, 469156001, 675281671, 2555900, 9 500950661, 518153561, 559058941, 628968071, 748483501, 843000/ DATA NNN35/ 1 443756241, 696282451, 95411012, 128615262, 182922012, 1900000, 2 336953201, 682481011, 93810882, 127915272, 184622442, 2700000, 3 402841621, 431544771, 463148311, 520059491, 734896851, 930000, 4 576168741, 788387631, 96910642, 116012552, 135014462, 2000000, 5 490265341, 812797201, 116614322, 179622692, 285035302, 2900000, 6 100010001, 100010031, 102311051, 133018071, 264539391, 1074500, 7 402841621, 431544771, 463148311, 520059491, 734996851, 2000000, 8 576168741, 788387631, 96910642, 116012552, 135014462, 3000000, 9 200020011, 201220591, 218124481, 296538611, 488859141, 400000/ DATA NNN36/ 1 100010001, 100010031, 102311051, 133018071, 264539401, 2200000, 2 421645151, 477449611, 511852711, 542455761, 572958821, 3300000, 3 100010041, 105212131, 153220271, 270435641, 460258111, 527600, 4 201221791, 258131471, 381645781, 546365131, 777592781, 1014400, 5 100010001, 100010031, 102311051, 133018071, 264539391, 3400000, 6 510064491, 82710872, 142718412, 232328712, 348341572, 690000, 7 228951571, 88513232, 183324132, 305537492, 448152402, 1210000, 8 723989131, 103511752, 130814352, 155416652, 177018682, 2000000, 9 620099241, 162725772, 391457072, 80110833, 141818023, 600000/ DATA NNN37/ 1 620099241, 162725772, 391457072, 80110833, 141818023, 1200000, 2 620099251, 162725772, 391457072, 80110833, 141818023, 2000000, 3 347877992, 129318323, 240730533, 380546863, 570368573, 600000, 4 347877992, 129318323, 240730533, 380546863, 570368573, 1200000, 5 347777992, 129318323, 240730533, 380546863, 570368573, 2000000, 6 209530092, 450866762, 96613623, 186524763, 318839893, 600000, 7 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 8 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 9 209530092, 450866762, 96613623, 186524763, 318839893, 600000/ DATA NNN38/ 1 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 2 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 3 209530092, 450866762, 96613623, 186524763, 318839893, 600000, 4 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 5 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 6 209530092, 450866762, 96613623, 186524763, 318839893, 600000, 7 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 8 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 9 209530092, 450866762, 96613623, 186524763, 318839893, 600000/ DATA NNN39/ 1 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 2 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 3 209530092, 450866762, 96613623, 186524763, 318839893, 600000, 4 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 5 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 6 209530092, 450866762, 96613623, 186524763, 318839893, 600000, 7 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 8 209530092, 450866762, 96613623, 186524763, 318839893, 2000000, 9 209530092, 450866762, 96613623, 186524763, 318839893, 600000/ DATA NNN40/ 1 209530092, 450866762, 96613623, 186524763, 318839893, 1200000, 2 209530092, 450866762, 96613623, 186524763, 318839893, 2000000/ DATA SCALE/.001,.01,.1,1./ C if(mode.lt.0) return tk=1.38054d-16*t tv=8.6171d-5*t C LOWERING OF THE IONIZATION POTENTIAL IN VOLTS FOR UNIT ZEFF CHARGE=ANE*2. DEBYE=SQRT(TK*DEBCON/CHARGE) C DEBYE=SQRT(TK/12.5664/4.801E-10**2/CHARGE) POTLOW=MIN(1.D0,1.44E-7/DEBYE) IF(IIZ.LE.28)then write(6,*) 'Error, routine PFHEAV for Z.GE.28 only' stop23 endif c removed elements with z<28 if(iiz.eq.28) n=1 IF(IIZ.GT.28) N=3*IIZ+54-135 IF(IIZ.eq.28) NIONS=4 IF(IIZ.GT.28) NIONS=3 NION2=MIN0(JNION+2,NIONS) N=N-1 C DO 18 ION=1,NION2 Z=ION POTLO(ION)=POTLOW*Z N=N+1 nnn6n=nnn(6+6*(N-1)) c nnn6n=nnn(6,n) NNN100=NNN6N/100 XN1= NNN100 IP(ION)=XN1*1.e-3 IG=NNN6N-NNN100*100 GGG=IG T2000=IP(ION)*T211 IT=MAX0(1,MIN0(9, INT(T/T2000-HALF))) XIT=IT DT=T/T2000-XIT-HALF PMIN=ONE I=(IT+1)/2 nnnin=nnn(i+6*(N-1)) c nnnin=nnn(i,n) K1=NNNIN/100000 K2=NNNIN-K1*100000 K3=K2/10 xk1=k1 xk3=k3 KSCALE=K2-K3*10 IF(MOD(IT,2).EQ.0) GO TO 12 P1=XK1*SCALE(KSCALE) P2=XK3*SCALE(KSCALE) IF(DT.GE.0.)GO TO 13 IF(KSCALE.GT.1)GO TO 13 KP1=int(P1) IF(KP1.NE. INT(P2+.5)) GO TO 13 PMIN=KP1 GO TO 13 12 continue xk3=k3 P1=XK3*SCALE(KSCALE) nnni1n=nnn(i+1+6*(N-1)) c nnni1n=nnn(i+1,n) K1=NNNI1N/100000 KSCALE=MOD(NNNI1N,10) xk1=k1 P2=XK1*SCALE(KSCALE) 13 PART(ION)= MAX (PMIN,P1+(P2-P1)*DT) IF(GGG.EQ.0..OR.POTLO(ION).LT..1.OR.T.LT.T2000*4.) GO TO 18 IF(T.GT.(T2000*11.)) TV=(T2000*11.)*TVCON D1=.1/TV D2=POTLO(ION)/TV DX=SQRT(HIONEV*Z*Z/TV/D2)**3 PART(ION)=PART(ION)+GGG*EXP(-IP(ION)/TV)* * (DX*(THIRD+(ONE-(HALF+(X18+D2*X120)*D2)*D2)*D2)- * DX*(THIRD+(ONE-(HALF+(X18+D1*X120)*D1)*D1)*D1)) 18 CONTINUE u=part(jnion) RETURN END C C C ******************************************************************** C C FUNCTION XK2DOP(TAU) C ==================== C C KERNEL FUNCTION K2 C AFTER HUMMER, 1981, J.Q.S.R.T. 26, 187 C INCLUDE 'IMPLIC.FOR' PARAMETER (PI2SQ=2.506628275D0, PISQ=1.772453851D0, UN=1.D0, * A1= -1.117897000D-1, A2= -1.249099917D-1, * A3= -9.136358767D-3, A4= -3.370280896D-4, * B1= 1.566124168D-1, B2= 9.013261660D-3, * B3= 1.908481163D-4, B4= -1.547417750D-7, * B5= -6.657439727D-9, * C1= 1.915049608D01, C2= 1.007986843D02, * C3= 1.295307533D02, C4= -3.143372468D01, * D1= 1.968910391D01, D2= 1.102576321D02, * D3= 1.694911399D02, D4= -1.669969409D01, * D5= -3.666448000D01) XK2DOP=UN IF(TAU.LE.0.) RETURN IF(TAU.LE.11.) THEN P=UN+TAU*(A1+TAU*(A2+TAU*(A3+TAU*A4))) Q=UN+TAU*(B1+TAU*(B2+TAU*(B3+TAU*(B4+TAU*B5)))) XK2DOP=TAU/PI2SQ*LOG(TAU/PISQ)+P/Q ELSE X=UN/LOG(TAU/PISQ) P=UN+X*(C1+X*(C2+X*(C3+X*C4))) Q=UN+X*(D1+X*(D2+X*(D3+X*(D4+X*D5)))) XK2DOP=P/Q/2.D0/TAU/SQRT(LOG(TAU/PISQ)) END IF RETURN END C C C ******************************************************************** C C SUBROUTINE LTEGR C ================ C C Driving procedure for computing the initial LTE-grey model C atmosphere C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C COMMON ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * DEPTH(MDEPTH),DEPTH0(MDEPTH),TAU(MDEPTH),TAU0(MDEPTH), * TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),DM0(MDEPTH) C C ---------------- C Input parameters C ---------------- C C NDEPTH - number of depth points for evaluating LTE-grey model C = 0 - NDEPTH is taken to be ND-1 C TAUFIR - Rosseland optical depth in the first depth point C TAULAS - Rosseland optical depth in the last depth point C ABROS0 - an estimate of the Rosseland opacity (per gram) at the C first depth point C TSURF = 0 - surface temperature and the Hopf function are C evaluated exactly C > 0 - value of surface temperature is set to TSURF, and C the Hopf function is assumed to be constant, C corresponding to TSURF C ALBAVE = 0 - wind blanketing is not considered C > 0 - wind blanketing is considered; the averaged value C of albedo [precisely the quantity (1+rho)/(1-rho) C in the notation of Hummer (Ap.J. 257, 724, 1982) C see his Eq. (3.1)] is ALBAVE C DION0 - initial estimate of the degree of ionization at C the first depth point (=1 for completely ionized; C =1/2 for completely neutral) C C -------------------------------------------------------------------- C IDEPTH - mode of determining the mass-depth scale to be used C in linearization C = 0 - depth scale DM (in g*cm**-2) is evaluated as mass C corresponding to Rosseland optical depths which C are equidistantly spaced in logarithms between C the first point TAUFIR and the last point TAULAS C the last-but-one point is, however, set to C TAULAS-1. C = 2 - depth scale DM is evaluated as that corresponding C to input values of Rosseland optical depth - C array TAU0(ID), ID=1,ND C = 1 - similar, but now DM is evaluated as mass C corresponding to Rosseland optical depths which C are equidistantly spaced in logarithms between C the first point TAU1 and the last-but-one point C TAU2; the last point is TAUL C (i.e. similar to option 0, now TAU1 and TAUL may C be different from TAUFIR nad TAULAS) C = 3 - depth scale DM has already been read in START C NCONIT - number of internal iterations for calculating the C gray model with convection C = 0 - and HMIX0>0, then NCONIT is set to 10 C IPRING - controls diagnostic output of the LTE-gray model C calculations C = 0 - no output C = 1 - only final LTE-gray model C = 2 - results of all internal iterations C IHM > 0 - negative hydrogen ion considered in particle and C charge conservation in ELDENS C IH2 > 0 - hydrogen molecule considered in particle C conservation in ELDENS C IH2P > 0 - ionized hydrogen molecule considered in particle C and charge conservation in ELDENS C IF(NDGREY.EQ.0) THEN NDEPTH=ND ELSE NDEPTH=NDGREY END IF IF(NDEPTH.GT.MDEPTH) * CALL QUIT('ndepth.gt.mdepth in LTEGR',ndepth,mdepth) IDEPTH=IDGREY IF(ALBAVE.GT.0.AND.TSURF.EQ.0.) TSURF=(0.433*ALBAVE)**0.25 HOPF0=0. IF(TSURF.NE.0.) HOPF0=4.D0*TSURF**4/3.D0 T4=TEFF**4 ANEREL=(DION0-HALF )/DION0 IF(NCONIT.EQ.0.AND.HMIX0.GT.0.) NCONIT=10 IF(ANEREL.LT.1.D-3) ANEREL=1.D-3 LTE0=LTE LTE=.TRUE. IF(NDEPTH.EQ.0) NDEPTH=ND-1 ND0=ND ND=NDEPTH DO I=1,ND0 DM0(I)=DM(I) END DO C C tau(ross) scale - logarithmically equidistant points between C input TAUFIR and TAULAS C DML0=LOG(TAUFIR) DLGM=(LOG(TAULAS)-DML0)/(NDEPTH-1) DO I=1,NDEPTH TAU0(I)=DML0+(I-1)*DLGM TAU(I)=EXP(TAU0(I)) TAUROS(I)=TAU(I) END DO C DPRAD=1.891204931D-15*T4 if(ifprad.eq.0) dprad=0. C PRAD0=DPRAD/1.732D0 ABROS=ABROS0 PLOG1=0. PLOG2=0. PLOG3=0. DPLOG1=0. DPLOG2=0. IF(IPRING.GT.0) WRITE(6,601) C C ------------------------------------------------------------------- C C 1.part C Integration of the hydrostatic equilibrium equation on the C tau(ross) scale; C basically by a predictor-corrector method C (similar to Kurucz's ATLAS code) C DO I=1,NDEPTH J=0 TAUR=TAU(I) C C predictor step C IF(I.EQ.1) PLOG=LOG(GRAV/ABROS*TAUR+prad0) IF(I.GT.1.AND.I.LE.4) PLOG=PLOG1+DPLOG1 IF(I.GT.4) PLOG=(3.*PLOG4+8.*DPLOG1-4.*DPLOG2+8.*DPLOG3)/3. ERROR=1. GO TO 40 C C corrector step C ------ iterate between hydrostatic equilibrium (which determines an C increment of the total pressure) and state equations (which C determine relevant number densities and then the Rosseland C opacity) C 30 IF(I.EQ.1) PNEW=LOG(GRAV/ABROS*TAUR+prad0) IF(I.GT.1.AND.I.LE.4) PNEW=(PLOG+2.*PLOG1+DPLOG+DPLOG1)/3. IF(I.GT.4) PNEW=(126.*PLOG1-14.*PLOG3+9.*PLOG4+42.*DPLOG+ * 108.*DPLOG1-54.*DPLOG2+24.*DPLOG3)/121. ERROR=ABS(PNEW-PLOG) PLOG=PNEW 40 PTOT=EXP(PLOG) P=PTOT-TAUR*DPRAD-prad0 J=J+1 CALL ROSSOP(I,P,TAUR,HOPF0,T4,T,ANE,ABROS) DPLOG=GRAV/ABROS*TAUR/PTOT*DLGM IF(ERROR.GT.1.D-4.AND.J.LT.10) GO TO 30 C C ------ end of the iteration loop; C set up necessary quantities for the next depth step of the C hydrostatic equilibrium C PLOG4=PLOG3 PLOG3=PLOG2 PLOG2=PLOG1 PLOG1=PLOG DPLOG3=DPLOG2 DPLOG2=DPLOG1 DPLOG1=DPLOG TEMP0(I)=T ELEC0(I)=ANE AN=P/T/BOLK DEPTH(I)=(PTOT-prad0)/GRAV DM(I)=DEPTH(I) DENS0(I)=WMM(I)*(AN-ANE) IF(IPRING.GT.0) WRITE(6,602) I,TAU(I),DEPTH(I),T, * AN,ANE,P,ABROS PTOTAL(I)=PTOT PGS(I)=P END DO C C ------------------------------------------------------------------- C C 2. Second part - taking into account convection C IF(HMIX0.GT.0.) THEN CALL CONTMP GO TO 110 END IF C C ------------------------------------------------------------------- C C 3. Third part C Interpolation of the computed model to the depth scale which is C going to be used in the subsequent - complete-linearization - C part of the model atmosphere construction C ND=ND0 C C First option - logarithmically equidistant Rosseland opt.depths C the same first and last depth as in the first part C IF(IDEPTH.EQ.0) THEN TAU1=TAUFIR TAUL=TAULAS TAU2=TAULAS-1. C C Second option - logarithmically equidistant Rosseland opt.depths C the first, last-but-one, and last depths are read C ELSE IF(IDEPTH.EQ.1) THEN READ(IBUFF,*) TAU1,TAU2,TAUL END IF C IF(IDEPTH.LE.1) THEN DML0=LOG(TAU1) IF(TAUL.GT.0.) THEN DLGM=(LOG(TAU2)-DML0)/(ND-2) DO I=1,ND-1 TAU0(I)=DML0+(I-1)*DLGM END DO TAU0(ND)=LOG(TAUL) ELSE DLGM=(LOG(TAU2)-DML0)/(ND-1) DO I=1,ND TAU0(I)=DML0+(I-1)*DLGM END DO END IF ELSE IF(IDEPTH.EQ.2) THEN C C Third option - prescribed set of Rosseland optical depths C READ(IBUFF,*) (TAU0(I),I=1,ND) DO I=1,ND TAU0(I)=LOG(TAU0(I)) END DO ELSE if(idepth.eq.3) then C C Fourth option - interpolation to the prescribed mass scale DM C DO I=1,ND DM(I)=DM0(I) DM0(I)=LOG(DM(I)) END DO CALL INTERP(DEPTH0,TEMP0,DM0,TEMP,NDEPTH,ND,2,0,0) CALL INTERP(DEPTH0,ELEC0,DM0,ELEC,NDEPTH,ND,2,0,1) CALL INTERP(DEPTH0,DENS0,DM0,DENS,NDEPTH,ND,2,0,1) END IF C C in the first three options - interpolation from the previous C Rosseland opacity scale to the new scale and from the previous C mass depth scale to the new one C IF(IDEPTH.LE.2) THEN DO I=1,NDEPTH TEMP0(I)=TEMP(I) ELEC0(I)=ELEC(I) DENS0(I)=DENS(I) TAU(I)=LOG(TAUROS(I)) DEPTH0(I)=LOG(DM(I)) END DO CALL INTERP(TAU,DEPTH0,TAU0,DM0,NDEPTH,ND,3,0,0) CALL INTERP(TAU,TEMP0,TAU0,TEMP,NDEPTH,ND,3,0,0) CALL INTERP(TAU,ELEC0,TAU0,ELEC,NDEPTH,ND,3,0,1) CALL INTERP(TAU,DENS0,TAU0,DENS,NDEPTH,ND,3,0,1) DO ID=1,ND DM(ID) = EXP(DM0(ID)) TOTN(ID) = DENS(ID)/WMM(ID)+ELEC(ID) PTOTAL(ID) = DM(ID)*GRAV+PRAD0 PGS(ID) = TOTN(ID)*BOLK*TEMP(ID) END DO END IF C C Recalculation of the populations C DO ID=1,ND CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) END DO C 110 CONTINUE IF(HMIX0.GE.0.) THEN CALL CONOUT(2,IPRING) END IF LCHC=LCHC0 LTE=LTE0 IRSPLT=IRSPL0 601 FORMAT(1H1, 'COMPUTED LTE-GREY MODEL'//' ID TAU',7X, * 'MASS',5X,'TEMP',7X,'N',10X,'NE',9X,'P',9X,'ROSS.OP'/) 602 FORMAT(1H ,I4,1P2D11.3,0PF8.0,1P4D11.3) RETURN END C C C ******************************************************************** C C SUBROUTINE ROSSOP(ID,P,TAUR,HOPF,T4,T,ANE,ABROSS) C ================================================= C C Auxiliary procedure for LTEGR C Evaluation of temperature, electron density, and Rosseland C opacity for a given TAUR (Rosseland optical depth) and P (total C pressure) C C Input parameters: C ID - depth index C P - total pressure C TAUR - Rosseland optical depth C HOPF - mode of evaluating Hopf function; C = 0 - exact Hopf function C > 0 - constant Hopf function to HOPF C T4 = effective temperature ** 4 C C Output: C T - temperature C ANE - electron density C ABROSS - Rosseland opacity (per gram) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION A(5) C DATA A/0.71044609D0,-0.2830385D0,0.57975839D0,-0.75751038D0, * 0.45026781D0/ SAVE A C C Hopf function C X=HOPF IF(X.GT.0.) GO TO 10 X=A(1) IF(TAUR.GT.160.) GO TO 10 EX=EXP(-TAUR) E1=EXPINT(TAUR) E=E1 DO I=1,4 E=(EX-TAUR*E)/I X=X+E*A(I+1) END DO C C Temperature C 10 T=(0.75*T4*(TAUR+X)+EXTOT)**0.25 C C Determination of electron density from the total pressure C if(ioptab.ge.-1) then AN=P/T/BOLK CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO C C temperature and electron density are transmitted to SABOLF C and RATMAT through arrays TEMP and ELEC C TEMP(ID)=T ELEC(ID)=ANE C C Corresponding LTE populations C if(ioptab.ge.0) then CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) C C Finally, evaluation of the Rosseland opacity for the new values C of temperature, electron density, and populations C (ROSS - Rosseland opacity per 1 cm**3) C CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROSS=OPROS/RHO ABROSD(ID)=ABROSS ABPLAD(ID)=OPPLA/RHO else call meanopt(t,id,rho,opros,oppla) abrosd(id)=opros abplad(id)=oppla abross=opros end if else temp(id)=t rho=rhoeos(t,p) dens(id)=rho call meanopt(t,id,rho,opros,oppla) abrosd(id)=opros abplad(id)=oppla abross=opros end if RETURN END C C C **************************************************************** C C SUBROUTINE CONTMP C ================= C C Auxiliary procedure for LTEGR C Determination of temperature in convectively unstable layers C This is done by solving the energy balance equation C F(rad)+F(conv)=F(mech), which yields a cubic equation for C the logarithmic temperature gradient C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' COMMON ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * DEPTH(MDEPTH),DEPTH0(MDEPTH),TAU(MDEPTH),TAU0(MDEPTH), * TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),DM0(MDEPTH) DIMENSION DELTR(MDEPTH),TEMPR(MDEPTH),ICON0(MDEPTH) COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD common/ichndm/ichanm PARAMETER (ERRT=1.D-3) C C First, store the temperature(rad) and gradient Delta(rad) - C quantities for the purely raditive equilibrium model C T4=TEFF**4 FLXTO0=SIG4P*T4 DPRAD=1.891204931D-15*T4 if(ifprad.eq.0) dprad=0. C PRAD0=DPRAD/1.732D0 DO ID=1,ND TEMPR(ID)=TEMP(ID) IF(ID.EQ.1) THEN DELTR(ID)=0. ELSE if(ilgder.eq.0) then DELTR(ID)= * (TEMP(ID)-TEMP(ID-1))/(PTOTAL(ID)-PTOTAL(ID-1))* * (PTOTAL(ID)+PTOTAL(ID-1))/(TEMP(ID)+TEMP(ID-1)) else DELTR(ID)= * LOG(TEMP(ID)/TEMP(ID-1))/LOG(PTOTAL(ID)/PTOTAL(ID-1)) end if END IF END DO ICONIT=0 C C ------------------------------------------------------ C Global iteration loop for calculating convective model C ------------------------------------------------------ C 20 ICONIT=ICONIT+1 ICONBE=0 CHANTM=0. DO ID=1,ND T=TEMP(ID) PTOT=PTOTAL(ID) PGAS=PGS(ID) PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PRAD=PTOT-PGAS-PTURB PRADT(ID)=PRAD FLXTOT=FLXTO0 IF(IDISK.EQ.1) THEN FLXTOT=FLXTO0*(UN-THETA(ID)) GRAVD=ZD(ID)*QGRAV END IF ICON0(ID)=0 C IF(ID.EQ.1) GO TO 45 J=0 IF(ICONIT.EQ.1) T=T-TEMPR(ID-1)+TEMP(ID-1) TM=TEMP(ID-1) IF(T.LT.0.) T=TM PTOTM=PTOTAL(ID-1) if(ilgder.eq.0) then PT0=HALF*(PTOT+PTOTM) else pt0=sqrt(ptot*ptotm) end if DELR=DELTR(ID) C C Inner iteration loop for determining temperature in the C conectively unstable layers C 30 J=J+1 TOLD=T if(ilgder.eq.0) then T0=HALF*(T+TM) PG0=HALF*(PGAS+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) else t0=sqrt(t*tm) pg0=sqrt(pgas*pgm) pr0=sqrt(prad*pradm) ab0=sqrt(abrosd(id)*abrosd(id-1)) end if IF(ID.GE.ND-2.AND.ICONBE.EQ.0) GO TO 40 CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DELR,FLXCNV,VCON) IF(FLXCNV.EQ.0..or.id.lt.idconz) GO TO 40 ICON0(ID)=1 ICONBE=1 CALL CUBIC(DELTA0) REFF=DELTA0/DELR PRAD=PRADM+(TAUROS(ID)-TAUROS(ID-1))*DPRAD*REFF PRADT(ID)=PRAD PGAS=PTOT-PRAD-PTURB if(ilgder.eq.0) then IF(REFF.GT.UN) REFF=UN IF(REFF.LT.0.) REFF=0. FAC=DELTA0*(PTOT-PTOTM)/(PTOT+PTOTM) T=TM*(UN+FAC)/(UN-FAC) IF(T.LT.TM) T=TM else T=TM*(PTOT/PTOTM)**DELTA0 IF(T.LT.TM) T=TM*1.0001 end if IF(ABS(UN-T/TOLD).GT.ERRT.AND.J.LT.10) GO TO 30 C C Store the final quantitites C 40 IF(ID.GT.1.AND.ICON0(ID).EQ.0.AND.ICON0(ID-1).EQ.1) * DELTC=DELT0 45 DELT0=TEMP(ID)-T IF(TEMP(ID).NE.0.) CHANT0=ABS((T-TEMP(ID))/TEMP(ID)) IF(CHANT0.GT.CHANTM) CHANTM=CHANT0 TEMP(ID)=T IF(ICONIT.GT.1.AND.ICON0(ID).EQ.0.AND.ICONBE.EQ.1) * TEMP(ID)=T-DELTC PGM=PGAS PRADM=PRAD PGS(ID)=PGAS END DO C C Diagnostic outprint C IF(IPRING.EQ.2) THEN WRITE(6,600) ICONIT CALL CONOUT(1,IPRING) END IF 600 FORMAT(1H1,' CONVECTIVE FLUX: AT CONTMP, ITER=',I2/) C C 2. New values of electron density, density, sound spped, C and mean opacities and optical depths C c ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) DO 70 ID=1,ND T=TEMP(ID) P=PTOTAL(ID) ITINT=0 60 ITINT=ITINT+1 if(ioptab.ge.-1) then AN=PGS(ID)/T/BOLK CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) ELEC(ID)=ANE DENS(ID)=WMM(ID)*(AN-ANE) PHMOL(ID)=AHMOL C C Corresponding LTE populations C if(ioptab.ge.0) then CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) C C Evaluation of the Rosseland and Planck mean opacities C CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROS=OPROS/DENS(ID) ABPLA=OPPLA/DENS(ID) else rho=dens(id) call meanopt(t,id,rho,abros,abpla) abrosd(id)=abros abplad(id)=abpla end if else rho=rhoeos(t,p) dens(id)=rho call meanopt(t,id,rho,abros,abpla) abrosd(id)=abros abplad(id)=abpla end if C C New values of the the column mass C PTOLD=PTOTAL(ID) if(idisk.eq.0.and.ichanm.gt.0) then IF(ID.EQ.1) THEN DM(ID)=TAUROS(ID)/ABROS PTOTAL(ID)=DM(ID)*GRAV+PRAD0 ELSE DM(ID)=DM(ID-1)+(TAUROS(ID)-TAUROS(ID-1))/ * HALF/(ABROSD(ID-1)+ABROS) PTOTAL(ID)=DM(ID)*GRAV+PRAD0 END IF C C Store the final quantitites C PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PGS(ID)=PTOTAL(ID)-PRADT(ID)-PTURB end if ABROSD(ID)=ABROS ABPLAD(ID)=ABPLA IF((PTOTAL(ID)-PTOLD)/PTOLD.LT.1.D-3) GO TO 70 IF(ITINT.GT.5) THEN WRITE(6,601) ID,PTOLD,PTOTAL(ID) GO TO 70 ELSE GO TO 60 END IF 70 CONTINUE C *** TEMPORARY C IF(ICONIT.LT.NCONIT) GO TO 20 601 FORMAT(1H0,'SLOW CONVERGENCE OF INTERNAL ITERATIONS IN', * ' CONTMP: ID, PTOT(OLD), PTOT(NEW) ='/I3,1P2D10.2/) RETURN END C C C **************************************************************** C C SUBROUTINE CONTMD C ================= C C Auxiliary procedure for LTEGRD C Determination of temperature in convectively unstable layers C for disks. C This is done by solving the energy balance equation C F(rad)+F(conv)=F(mech), which yields a cubic equation for C the logarithmic temperature gradient C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' COMMON ESEMAT(MLEVEL,MLEVEL),BESE(MLEVEL), * DEPTH(MDEPTH),DEPTH0(MDEPTH),TAU(MDEPTH),TAU0(MDEPTH), * TEMP0(MDEPTH),ELEC0(MDEPTH),DENS0(MDEPTH),DM0(MDEPTH) DIMENSION DELTR(MDEPTH),TEMPR(MDEPTH),ICON0(MDEPTH) COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 PARAMETER (ERRT=1.D-3) C C First, store the temperature(rad) and gradient Delta(rad) - C quantities for the purely raditive equilibrium model C T4=TEFF**4 FLXTO0=SIG4P*T4 DPRAD=1.891204931D-15*T4 if(ifprad.eq.0) dprad=0. PRAD0=DPRAD/1.732D0 DO ID=1,ND TEMPR(ID)=TEMP(ID) IF(ID.EQ.1) THEN DELTR(ID)=0. ELSE DELTR(ID)= * (TEMP(ID)-TEMP(ID-1))/(PTOTAL(ID)-PTOTAL(ID-1))* * (PTOTAL(ID)+PTOTAL(ID-1))/(TEMP(ID)+TEMP(ID-1)) END IF END DO ICONIT=0 C C ------------------------------------------------------ C Global iteration loop for calculating convective model C ------------------------------------------------------ C 20 ICONIT=ICONIT+1 ICONBE=0 HR1=FLXTO0*PCK*ABROSD(1)/QGRAV CHANTM=0. DOID=1,ND T=TEMP(ID) PTOT=PTOTAL(ID) PGAS=PGS(ID) PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PRAD=PRADT(ID) FLXTOT=FLXTO0*(UN-THETA(ID)) GRAVD=ZD(ID)*QGRAV ICON0(ID)=0 C IF(ID.EQ.1) GO TO 40 J=0 IF(ICONIT.EQ.1) T=T-TEMPR(ID-1)+TEMP(ID-1) TM=TEMP(ID-1) IF(T.LT.0.) T=TM PGM=PGS(ID-1) PTOTM=PTOTAL(ID-1) PT0=HALF*(PTOT+PTOTM) DELR=DELTR(ID) C C Inner iteration loop for determining temperature in the C conectively unstable layers C 30 J=J+1 TOLD=T T0=HALF*(T+TM) PG0=HALF*(PGAS+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) IF(ID.GE.ND-2.AND.ICONBE.EQ.0) GO TO 40 CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DELR,FLXCNV,VCON) IF(FLXCNV.EQ.0.) GO TO 40 ICON0(ID)=1 ICONBE=1 if(id.eq.nd) then pip=(ptot+ptotm)/(ptot-ptotm) t=tm*(pip+delr)/(pip-delr) go to 40 end if CALL CUBIC(DELTA0) FAC=DELTA0*(PTOT-PTOTM)/(PTOT+PTOTM) T=TM*(UN+FAC)/(UN-FAC) IF(T.LT.TM) T=TM IF(ABS(UN-T/TOLD).GT.ERRT.AND.J.LT.10) GO TO 30 C C Store the final quantitites C 40 IF(ID.GT.1.AND.ICON0(ID).EQ.0.AND.ICON0(ID-1).EQ.1) * DELTC=DELT0 if(id.eq.nd) then pip=(ptot+ptotm)/(ptot-ptotm) t=tm*(pip+delr)/(pip-delr) end if DELT0=TEMP(ID)-T PRADT(ID)=PRADT(ID)*(T/TEMP(ID))**4 DENS(ID)=DENS(ID)*(TEMP(ID)/T) IF(TEMP(ID).NE.0.) CHANT0=ABS((T-TEMP(ID))/TEMP(ID)) IF(CHANT0.GT.CHANTM) CHANTM=CHANT0 TEMP(ID)=T IF(ICONIT.GT.1.AND.ICON0(ID).EQ.0.AND.ICONBE.EQ.1) * TEMP(ID)=T-DELTC PRADM=PRADT(ID) END DO C C Diagnostic outprint C IF(IPRING.EQ.2) THEN WRITE(6,600) ICONIT CALL CONOUT(1,IPRING) END IF 600 FORMAT(1H1,' CONVECTIVE FLUX: AT CONTMD, ITER=',I2/) C C 2. New values of electron density and density C CALL HESOL6 C C Evaluation of the Rosseland and Planck mean opacities C DO ID=1,ND T=TEMP(ID) CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROS=OPROS/DENS(ID) ABPLA=OPPLA/DENS(ID) ABROSD(ID)=ABROS ABPLAD(ID)=ABPLA END DO IF(CHANTM.GT.ERRT.AND.ICONIT.LT.NCONIT) GO TO 20 RETURN END C C C **************************************************************** C C SUBROUTINE ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,IPRI) C =============================================== C C Evaluation of the electron density and the total hydrogen C number density for a given total particle number density C and temperature; C by solving the set of Saha equations, charge conservation and C particle conservation equations (by a Newton-Raphson method) C C Input parameters: C T - temperature C AN - total particle number density C C Output: C ANE - electron density C ANP - proton number density C AHTOT - total hydrogen number density C AHMOL - relativer number of hydrogen molecules with respect to the C total number of hydrogens C ENERG - part of the internal energy: excitation and ionization C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' DIMENSION R(3,3),S(3),P(3) common/terden/rhoter,anta,entrp common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) c if(ioptab.lt.-1) return C if(anerel.le.0.) then anerel=0.5 if(t.lt.9000.) anerel=0.4 if(t.lt.8000.) anerel=0.1 if(t.lt.7000.) anerel=0.01 if(t.lt.6000.) anerel=0.001 if(t.lt.5500.) anerel=0.0001 if(t.lt.5000.) anerel=1.e-5 if(t.lt.4000.) anerel=1.e-6 end if c if(ifmol.gt.0.and.t.lt.tmolim) then aein=an*anerel call moleq(id,t,an,aein,ane,enrg,entt,wm,ipri) anerel=ane/an return end if c QMI=0. Q2=0. QP=0. Q=0. DQN=0. TK=BOLK*T THET=5.0404D3/T anta=an C C Coefficients entering ionization (dissociation) balance of: C atomic hydrogen - QH; C negative hydrogen ion - QM (considered only if IHM>0); C hydrogen molecule - QP (considered only if IH2>0); C ion of hydrogen molecule - Q2 (considered only if IH2P>0). C IF(T.LE.9000.) THEN QMI=1.0353D-16/T/SQRT(T)*EXP(8762.9/T) QP=TK*EXP((-11.206998+THET*(2.7942767+THET* * (0.079196803-0.024790744*THET)))*2.30258509299405) call mpartf(1,1,0,t,uh,duh) uh=max(uh,two) call mpartf(0,0,2,t,uh2,duh2) q2=1.47e-20/(t*sqrt(t))*uh2/uh/uh*exp(51951.8/t) END IF tkln15=log(bolk*t)*1.5 QH0=EXP((15.38287+1.5*LOG10(T)-13.595*THET)*2.30258509299405)*two C ANE=AN*ANEREL IT=0 C C Basic Newton-Raphson loop - solution of the non-linear set C for the unknown vector P, consistiong of AH, ANH (neutral C hydrogen number density) and ANE. C 10 IT=IT+1 C C procedure STATE determines Q (and DQN) - the total charge (and its C derivative wrt temperature) due to ionization of all atoms which C are considered (both explicit and non-explicit), by solving the set C of Saha equations for the current values of T and ANE C CALL STATE(1,ID,T,ANE) C C Auxiliary parameters for evaluating the elements of matrix of C linearized equations. C Note that complexity of the matrix depends on whether the hydrogen C molecule is taken into account C Treatment of hydrogen ionization-dissociation is based on C Mihalas, in Methods in Comput. Phys. 7, p.10 (1967) C IF(IATREF.EQ.IATH.or.ioptab.ge.-1) THEN qh=qh0/pfhyd G2=QH/ANE G3=0. G4=0. G5=0. D=0. E=0. G3=QMI*ANE A=UN+G2+G3 D=G2-G3 IF(IT.GT.1) GO TO 60 IF(T.GT.9000.) THEN F1=UN/A FE=D/A+Q AH=ANE/FE ANH=AH*F1 else if(t.gt.4000.) then E=G2*QP/Q2 B=TWO*(UN+E) GG=ANE*Q2 C1=B*(GG*B+A*D)-E*A*A C2=A*(TWO*E+B*Q)-D*B C3=-E-B*Q F1=(SQRT(C2*C2-4.*C1*C3)-C2)*HALF/C1 FE=F1*D+E*(UN-A*F1)/B+Q AH=ANE/FE ANH=AH*F1 else c1=q2*(two*ytot(id)-un) c2=ytot(id) c3=-an anh=(sqrt(c2*c2-4.*c1*c3)-c2)*half/c1 ah=anh*(un+two*anh*q2) c1=un+qmi*anh c2=-q*ah c3=-qh*anh ane=(sqrt(c2*c2-4.*c1*c3)-c2)*half/c1 end if 60 AE=ANH/ANE GG=AE*QP E=ANH*Q2 B=ANH*QMI C C Matrix of the linearized system R, and the rhs vector S C if(ifmol.eq.0.or.t.ge.tmolim) then R(1,1)=YTOT(ID) R(1,2)=0. R(1,3)=UN S(1)=AN-ANE-YTOT(ID)*AH else R(1,1)=YTOT(ID)-UN R(1,2)=A+E+GG R(1,3)=UN S(1)=AN-ANE-ANH*(A+E+GG)-(YTOT(ID)-UN)*AH end if c R(2,1)=-Q R(2,2)=-D-TWO*GG R(2,3)=UN+B+AE*(G2+GG)-DQN*AH R(3,1)=-UN R(3,2)=A+4.*(E+GG) R(3,3)=B-AE*(G2+TWO*GG) S(2)=ANH*(D+GG)+Q*AH-ANE S(3)=AH-ANH*(A+TWO*(E+GG)) C C Solution of the linearized equations for the correction vector P C CALL LINEQS(R,S,P,3,3) C C New values of AH, ANH, and ANE C AH=AH+P(1) ANH=ANH+P(2) DELNE=P(3) ANE=ANE+DELNE C C hydrogen is not the reference atom C ELSE C C Matrix of the linearized system R, and the rhs vector S C IF(IT.EQ.1) THEN ANE=AN*HALF AH=ANE/YTOT(ID) END IF R(1,1)=YTOT(ID) R(1,2)=UN R(2,1)=-Q-QREF R(2,2)=UN-(DQN+DQNR)*AH S(1)=AN-ANE-YTOT(ID)*AH S(2)=(Q+QREF)*AH-ANE C C Solution of the linearized equations for the correction vector P C CALL LINEQS(R,S,P,2,3) AH=AH+P(1) DELNE=P(2) ANE=ANE+DELNE END IF C C Convergence criterion C IF(ANE.LE.0.) ANE=1.D-6*AN IF(ABS(DELNE/ANE).GT.1.D-3.AND.IT.LE.10) GO TO 10 C C ANEREL is the exact ratio betwen electron density and total C particle density, which is going to be used in the subseguent C call of ELDENS C ANEREL=ANE/AN AHTOT=AH AHMOL=ANH*ANH*Q2 ANP=ANH/ANE*QH ANHM=ANH*ANE*QMI RHOTER=WMY(ID)*AH*HMASS if(ipri.gt.0) then dens(id)=rhoter elec(id)=ane wmm(id)=dens(id)/(an-ane) end if C c internal energy and entropy c call entene(t,ah,anh,anp,ane,energ,entrop) ener=energ entr=entrop c if(id.eq.1) write(6,602) id,t,an,ener,entr c c energy and entropy of H_2 c if(t.lt.9000..and.ahmol.gt.0..and.uh2.gt.0.) then ener=ener+(duh2-51951.8/t)*tk*ahmol entr=entr+ahmol*(tkln15-log(ahmol)+log(uh2)+1.0487+ * 103.973)*bolk end if C enrg=ener entt=entr wm=rhoter/an/hmass c if(ifmol.le.0.or.t.ge.tmolim) then if(n0hn.gt.0) then anato(1,id)=popul(n0hn,id) else anato(1,id)=dens(id)/wmm(id)/ytot(id) end if if(iathe.gt.0) then anato(2,id)=popul(n0a(iathe),id) else anato(2,id)=dens(id)/wmm(id)/ytot(id)*abndd(2,id) end if end if c RETURN END C C C **************************************************************** C C subroutine entene(t,ah,anh,anpr,ane,energ,entrop) c ================================================= c c internal energy and entropy of atoms and ions c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' parameter (ev2erg=1.6018d-12, * entcon=103.973) c tk=bolk*t tkk=tk*t tkln15=1.5*log(tk) natoms=30 energ=0. entrop=0. c c hydrogen c call mpartf(1,1,0,t,u,dulog) if(u.lt.2.) u=2. if(dulog.lt.0.) dulog=0. alm=1.5*log(amas(1)) energ=tk*dulog*anh entrop=(tkln15-log(anh)+log(u)+alm+tkk*dulog+entcon)*anh energ=energ+enev(1,1)*ev2erg*anpr entrop=entrop+(tkln15-log(anpr)+alm+entcon)*anpr c c other species c xmax=2.154e4*sqrt(sqrt(t/ane)) do i=2,natoms chip=0 do j=1,2 if(rr(i,j).gt.1.e-15) then aden=rr(i,j)*ah if(aden.lt.1.e-20) aden=1.e-20 call mpartf(i,j,0,t,u,dulog) if(u.lt.un) u=un if(dulog.lt.0.) dulog=0. energ=energ+(chip*ev2erg+tk*dulog)*aden entrop=entrop+(tkln15-log(aden)+log(u)+ * 1.5*log(amas(i))+tkk*dulog+entcon)*aden end if chip=chip+enev(i,j) end do end do c c entropy of electrons c c entel=tkln15-log(ane)+1.5*log(emass(99))+entcon entel=tkln15-log(ane)-11.2622+entcon entrop=entrop+entel*ane entrop=entrop*bolk C return end C C C *********************************************************************** C C SUBROUTINE MEANOP(T,ABSO,SCAT,OPROS,OPPLA) C ========================================== C C Rosseland and Planck mean opacities C C Input parameters: C T - temperature C ABSO - array of absorption coefficients in all explicit C frequency points C SCAT - array of scttering coefficients C Output: C OPROS - Rosseland opacity (per 1 cm**3) C OPPLA - Planck mean opacity (per 1 cm**3) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' DIMENSION ABSO(MFREQ),SCAT(MFREQ) C ABR=0. SUMDB=0. ABP=0. SUMB=0. HKT=HK/T C DO IJ=1,NFREQC FR=FREQ(IJ) X=HKT*FR IF(X.GT.150.) X=150. EX=EXP(X) E1=UN/(EX-UN) PLAN=BNUE(IJ)*E1*W(IJ) DPLAN=PLAN*HKT*FR*EX*E1 ABR=ABR+DPLAN/ABSO(IJ) ABP=ABP+PLAN*(ABSO(IJ)-SCAT(IJ)) SUMDB=SUMDB+DPLAN SUMB=SUMB+PLAN END DO OPROS=SUMDB/ABR OPPLA=ABP/SUMB RETURN END C C C **************************************************************** C C SUBROUTINE MEANOPT(T,ID,RHO,OPROS,OPPLA) C ======================================== C C Rosseland and Planck mean opacities C C Input parameters: C T - temperature C RHO - density C Output: C OPROS - Rosseland opacity (per gram) C OPPLA - Planck mean opacity (per gram) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C ABR=0. SUMDB=0. ABP=0. SUMB=0. HKT=HK/T C DO IJ=1,NFREQ FR=FREQ(IJ) EX=EXP(HKT*FR) E1=UN/(EX-UN) PLAN=BNUE(IJ)*E1*W(IJ) DPLAN=PLAN*HKT*FR*EX*E1 CALL OPCTAB(FR,IJ,ID,T,RHO,AB,SC,SCT,1) ABR=ABR+DPLAN/(AB+SCT) ABP=ABP+PLAN*AB SUMDB=SUMDB+DPLAN SUMB=SUMB+PLAN END DO OPROS=SUMDB/ABR OPPLA=ABP/SUMB RETURN END C C C **************************************************************** C C SUBROUTINE CONVEC(ID,T,PTOT,PG,PRAD,ABROS,DELTA,FLXCNV,VCONV) C ============================================================= C C Determination of the mixing-lengths convective flux C C Input: T - temperature C PTOT - total pressure C PG - gas pressure C PRAD - radiation pressure C ABROS - Rosseland opacity (per gram) C DELTA - corresponding temperature gradient C Output: FLXCNV - convective flux (expressed as H, ie F/4/pi) C VCONV - convective velocity C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' COMMON/CUBCON/A,B,DDEL,GRDADB,DLT,RHO,FLXTOT,GRAVD C VCONV=0. FLXCNV=0. DLT=0. GRDADB=0. IF(HMIX0.LT.0.) RETURN C C Thermodynamic derivatives C if(ioptab.ge.-1) then CALL TRMDER(ID,T,PG,PRAD,TAURS(ID),HEATCP,DLRDLT,GRDADB,RHO) else call trmdrt(id,t,ptot,heatcp,dlrdlt,grdadb,rho) end if DDEL=DELTA-GRDADB C C Convective instability criterion C IF(DDEL.LT.0.) RETURN if(idisk.eq.0) then HSCALE=PTOT/RHO/GRAV else if(gravd.eq.0.) return hscale=ptot/rho/gravd end if HMIX=HMIX0 if(hmix0.eq.0.) hmix=1. VCO=HMIX*SQRT(ABS(aconml*PTOT/RHO*DLRDLT)) FLCO=bconml*RHO*HEATCP*T*HMIX/12.5664 TAUE=HMIX*ABROS*RHO*HSCALE FAC=TAUE/(UN+HALF *TAUE*TAUE) C C Set up parameters A and B (see Mihalas, Eq. 7-76, 7-79, etc) C B=5.67d-5*T**3/(rho*heatcp*VCO)*FAC*cconml*half IF(FLXTOT.GT.0.) A=FLCO*VCO/FLXTOT*DELTA C C Determination of Delta - Delta(E) C D=B*B/2.D0 DLT=D+DDEL-B*SQRT(D/2.D0+DDEL) IF(DLT.LT.0.) DLT=0. C C Resulting convective velocity VCONV and flux FLXCNV C VCONV=VCO*SQRT(DLT) FLXCNV=FLCO*VCONV*DLT RETURN END C C C **************************************************************** C C SUBROUTINE CONVC1(ID,T,PTOT,PG,PRAD,ABROS,DELTA,FLXCNV,FC0) C =========================================================== C C Determination of the mixing-lengths convective flux C C Input: T - temperature C PTOT - total pressure C PG - gas pressure C PRAD - radiation pressure C ABROS - Rosseland opacity (per gram) C DELTA - corresponding temperature gradient C Output: FLXCNV - convective flux (expressed as H, ie F/4/pi) C VCONV - convective velocity C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' COMMON/CUBCON/A,B,DDEL,GRDADB,DLT,RHO,FLXTOT,GRAVD C VCONV=0. FLXCNV=0. DLT=0. IF(HMIX0.LT.0.) RETURN C C Thermodynamic derivatives C if(ioptab.ge.-1) then CALL TRMDER(ID,T,PG,PRAD,TAURS(ID),HEATCP,DLRDLT,GRDADB,RHO) else call trmdrt(id,t,ptot,heatcp,dlrdlt,grdadb,rho) end if DDEL=DELTA-GRDADB C C Convective instability criterion C if(idisk.eq.0) then HSCALE=PTOT/RHO/GRAV else if(gravd.eq.0.) return hscale=ptot/rho/gravd end if HMIX=HMIX0 if(hmix0.eq.0.) hmix=1. VCO=HMIX*SQRT(ABS(aconml*PTOT/RHO*DLRDLT)) FLCO=bconml*RHO*HEATCP*T*HMIX/12.5664 FC0=FLCO*VCO IF(DDEL.LT.0.) RETURN c TAUE=HMIX*ABROS*RHO*HSCALE FAC=TAUE/(UN+HALF *TAUE*TAUE) C C Set up parameters A and B (see Mihalas, Eq. 7-76, 7-79, etc) C B=5.67d-5*T**3/(rho*heatcp*VCO)*FAC*cconml*half IF(FLXTOT.GT.0.) A=FLCO*VCO/FLXTOT*DELTA C C Determination of Delta - Delta(E) C D=B*B/2.D0 DLT=D+DDEL-B*SQRT(D/2.D0+DDEL) IF(DLT.LT.0.) DLT=0. C C Resulting convective velocity VCONV and flux FLXCNV C VCONV=VCO*SQRT(DLT) FLXCNV=FLCO*VCONV*DLT RETURN END C C C **************************************************************** C C SUBROUTINE TRMDER(ID,T,PG,PRAD,TAU,HEATCP,DLRDLT,GRDADB,RHO) C ============================================================ C C Thermodynamic derivatives C Evaluation similar as in Kurucz's ATLAS C C Input: T - temperature C PG - gas pressure C PRAD - radiation pressure C Output: DEDT - d(energy)/d(T) C DRDT - d(rho)/d(T) C DEDPG - d(energy)/d(PG) C DRDPG - d(rho)/d(PG) C RHO - density C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' common/derdif/dift,difp common/terden/rhoter,anta,entrp common/adiaba/grdad0,itgrad DIMENSION TT(5),PP(5),RHON(5),ENER(5),entr(5) C C NUMERICAL EVALUATION OF THERMODYNAMIC DERIVATIVES C c prad=0. P=PG TT(1)=T*(UN+DIFT) TT(2)=T*(UN-DIFT) TT(3)=T TT(4)=T TT(5)=T PP(1)=P PP(2)=P PP(3)=P*(UN+DIFP) PP(4)=P*(UN-DIFT) PP(5)=P tmoli0=tmolim if(t.lt.tmolim) tmolim=t*(un+dift+0.001) if(t.ge.tmolim) tmolim=t*(in-dift-0.001) DO I=1,5 TE=TT(I) TKN=TE*1.38054D-16 ANT=PP(I)/TKN CALL ELDENS(ID,TE,ANT,ANE,ENRG,ENT,WM,0) RHON(I)=rhoter ENER(I)=(1.5D0*PP(I)+ENRG+3.D0*PRAD*(TE/T)**4)/RHON(I) entr(i)=ent/RHON(I) END DO tmolim=tmoli0 entrp=entr(5) c DRDT=(RHON(1)-RHON(2))/(2.*T*DIFT) DRDPG=(RHON(3)-RHON(4))/(2.*P*DIFP) RHO=RHON(5) DPDPG=1. dpdt=0. if(tau.lt.50.) DPDT=4.*PRAD/T*(un-exp(-tau)) DLRDLT=T/RHO*(DRDT-DRDPG*DPDT/DPDPG) ptot=pg+prad c if(ifentr.le.0) then DEDT= (ENER(1)-ENER(2))/(2.*T*DIFT) DEDPG=(ENER(3)-ENER(4))/(2.*P*DIFP) HEATCV=DEDT-DEDPG*DRDT/DRDPG HEATCP=DEDT-DEDPG*DPDT/DPDPG- * PTOT/RHO/RHO*(DRDT-DRDPG*DPDT/DPDPG) GRDADB=-PTOT/RHO/T*DLRDLT/HEATCP else DSDT= (ENTR(1)-ENTR(2))/(2.*T*DIFT) DSDP= (ENTR(3)-ENTR(4))/(2.*P*DIFP) grdadb=-dsdp/dsdt*pg/t c heatcp=-PTOT/RHO/T*DLRDLT/grdadb heatcp=t*dsdt end if c if(iter.le.itgrad.and.grdad0.gt.0) * grdadb=grdad0*0.4+(un-grdad0)*grdadb RETURN END C C C *************************************************************** C C SUBROUTINE CUBIC(DELTA) C ======================= C C Solution of the cubic equation for determination of C the true gradient DELTA C C Input: A,B - coefficients; transmitted by COMMON/CUBCON C DEL - DELTA(RAD) - DELTA(ADIAB); also transm. by CUBCON C Output: DELTA - true gradient C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD PARAMETER (THIRD = 0.333333333333333D0) data ipri /0/ C C first solve the cubic equation C A*X**3 + X**2 + B*X = DEL C where X = (DELTA - DELTA(ELEM))**(1/2) C AA=THIRD/A BB=B/A CC=-DEL/A P=BB*THIRD-AA*AA Q=AA**3-(BB*AA-CC)/2.D0 D=Q*Q+P*P*P IF(D.GT.0.) THEN D=SQRT(D) if(d-abs(q).lt.1.e-14*d) then SOL=(2.D0*D)**THIRD-AA ELSE D1=ABS(D-Q) D2=ABS(D+Q) SOL=D1/(D-Q)*D1**THIRD-D2/(D+Q)*D2**THIRD-AA END IF ELSE COSF=-Q/SQRT(ABS(P*P*P)) TANF=SQRT(UN-COSF*COSF)/COSF FI=ATAN(TANF)*THIRD SOL=2.D0*SQRT(ABS(P))*COS(FI)-AA END IF C C if the previous formalism gives an unphysical solution C x > DEL, then find the physical solution in the range (0, DEL) C by a Newton-Raphson solution of the cubic equation C DELDA=SOL*(B+SOL) IF(DELDA.GT.DEL.OR.DELDA.LT.0.) THEN X0=sol J=0 10 DELX=(DEL-X0*(B+X0+A*X0*X0))/(3.D0*A*X0*X0+2.D0*X0+B) X0=X0+DELX J=J+1 IF(ABS(DELX/X0).GT.1D-6.AND.J.LT.50) GO TO 10 SOL=X0 END IF C C finally, the actual gradient delta C DELTA=GRDADB+B*SOL+SOL*SOL RETURN END C C C *************************************************************** C C SUBROUTINE CONOUT(IMOD,IPRIN) C ============================= C C Diagnostic outprint of temperature gradients, convective flux, C and their derivatives C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD C IF(IPRIN.GT.0) WRITE(6,600) ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) ICBEG=0 FLXTO0=SIG4P*TEFF**4 DO ID=1,ND T=TEMP(ID) PTOT=PTOTAL(ID) PG=PGS(ID) PRAD=PTOT-PG-HALF*DENS(ID)*VTURB(ID)**2 if(prad.lt.0.) prad=0. IF(IMOD.EQ.2) THEN if(ioptab.ge.0) then CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROSD(ID)=OPROS/DENS(ID) else call meanopt(t,id,dens(id),opros,oppla) if(hmix0.gt.0.) abrosd(id)=opros end if END IF FLXTOT=flxto0 if(idisk.eq.1) then flxtot=flxto0*(un-thetav(id)) gravd=zd(id)*qgrav prad=pradt(id) end if IF(ID.EQ.1) THEN TAU=DM(ID)*ABROSD(ID) FLXCR=0. GRDADB=0. DELTA(ID)=0. FLXC(ID)=0. FLXCNV=0. ELSE TM=TEMP(ID-1) TAU=TAUM+HALF*(DM(ID)-DM(ID-1))*(ABROSD(ID)+ABROSD(ID-1)) PTOTM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PTOTM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 if(idisk.eq.1) pradm=pradt(id-1) if(pradm.lt.0.) pradm=0. if(ilgder.eq.0) then T0=HALF*(T+TM) PT0=HALF*(PTOT+PTOTM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(PTOT-PTOTM)*PT0/T0 else T0=SQRT(T*TM) PT0=SQRT(PTOT*PTOTM) PG0=SQRT(PG*PGM) PR0=SQRT(PRAD*PRADM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) DLT=LOG(T/TM)/LOG(PTOT/PTOTM) end if DELTA(ID)=DLT flxcnv=0. if(idisk.ne.1.or.id.lt.nd) * CALL CONVEC(ID,T0,PT0,PG0,PR0,AB0,DLT,FLXCNV,VCON) if(hmix0.gt.0.) FLXC(ID)=FLXCNV IF(ICBEG.EQ.0.AND.FLXC(ID).GT.0..AND.FLXC(ID-1).EQ.0.. * AND.ID.GT.25) ICBEG=ID if(icbeg.gt.0.and.flxc(id).gt.0.) icend=id END IF PRADR=PRAD/PTOT conrel=0. radrel=1. if(flxtot.gt.0.) then conrel=FLXCNV/FLXTOT radrel=flrd(id)/flxtot end if IF(IPRIN.GT.0) WRITE(6,601) ID,TAU,T,DELTA(ID), * GRDADB,conrel,radrel,conrel+radrel TAUM=TAU END DO if(iprin.gt.0) write(6,603) icbeg,icend 603 format(/' convective zone between depths (inclusive) ',2i4/) C c if ICONV=3, then: c in the convective zone the radiative (+ convective) equilibrium c is taken obligatorily in the differential form, i.e. c NDRE is modified to have the value just below the beginning of c convection zone, and c rediff(id) has to be set to unity, and reint(id) to 0 for id => ndre c IF(ICBEG.GT.3.AND.ICONV.EQ.3) THEN NDRE=ICBEG-1 DO ID=1,ND IF(ID.GE.NDRE) THEN REINT(ID)=0. REDIF(ID)=1. else reint(id)=1. redif(id)=0. END IF END DO WRITE(6,602) NDRE END IF c IF(ICBEG.GT.3.AND.ICONV.EQ.2) THEN NDRE=ICBEG-1 DO ID=1,ND IF(ID.GE.NDRE) THEN REDIF(ID)=1. END IF END DO WRITE(6,602) NDRE END IF c 600 FORMAT(//' ID',3X,'TAUR',7X,'TEMP',6X, * 'DELTA',2X,'DELTA(AD)',2X,'CON/TOT RAD/TOT (C+R)/TOT'//) 601 FORMAT(1H ,I4,1PD9.2,0PF9.1,1P5D10.2) 602 FORMAT(//' NDRE IS RESET IN CONOUT DUE TO THE EXISTENCE OF' * ,' CONVECTIVE ZONE'/' NDRE= ',I3/) RETURN END C C C *************************************************************** C C FUNCTION ERFCX(X) C ================= C C complementary error function C expression from Abramowitz and Stegun, p.299, Eq. 7.1.26 C INCLUDE 'IMPLIC.FOR' PARAMETER (P = 0.3275911D0, * A1 = 0.254829592D0, * A2 =-0.284496736D0, * A3 = 1.421413741D0, * A4 =-1.453152027D0, * A5 = 1.061405429D0, * UN = 1.D0) T=UN/(UN+P*X) ERFCX=0. IF(X.GT.13.) RETURN ERFCX=T*(A1+T*(A2+T*(A3+T*(A4+T*A5))))*EXP(-X*X) RETURN END C C C ****************************************************************** C C SUBROUTINE MATCON(ID) C ===================== C C Evaluation of the terms in matrices A and B of complete C linearization due to convection. C Two rows are modified: C NRE - energy balance (i.e. temperature) C NDEL - new row corresponding to a new model parameter DELTA C C Model parameter DELTA is defined as dln(T)/dln(P); C FCONV is the convective flux C C The equations and corresponding matrix elements are similar C to those considered by Grenfell, Astr.Ap. 20, 293 (1972). C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD C IF(HMIX0.LE.0.) RETURN NHE=NFREQE+INHE NRE=NFREQE+INRE NPC=NFREQE+INPC NDEL=NFREQE+INDL C C Upper boundary condition (ID=1) C ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) IF(ID.EQ.1) THEN DELTA(ID)=0. FLXC(ID)=0. IF(INDL.GT.0) B(NDEL,NDEL)=UN ELSE C C Normal depth point 1 < ID < ND C T=TEMP(ID) P=PTOTAL(ID) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 TM=TEMP(ID-1) PM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 if(ilgder.eq.0) then T0=HALF*(T+TM) P0=HALF*(P+PM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 TT=T*T-TM*TM DDT0= DLT/HALF*TM/TT DDTM=-DDT0*T/TM else T0=SQRT(T*TM) P0=SQRT(P*PM) PG0=SQRT(PG*PGM) PR0=SQRT(PRAD*PRADM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) DLP=UN/LOG(P/PM) DLT=LOG(T/TM)*DLP DDT0= DLP/T DDTM=-DLP/TM end if DELTA(ID)=DLT IF(INDL.GT.0) THEN B(NDEL,NDEL)=-UN VECL(NDEL)=DELTA(ID)-DLT DDP0=0. DDPM=0. IF(IPRESS.GT.0) THEN if(ilgder.eq.0) then PP0=P*P-PM*PM DDP0=-DLT/HALF*PM/PP0 DDPM=-DDP0*P/PM else PP0=LOG(T/TM)*DLP*DLP DDP0=-PP0/P DDPM=PP0/PM end if END IF C C the row of matrix A corresponding to DELTA C if(inhe.gt.0) A(NDEL,NHE)=BOLK*TM*DDPM A(NDEL,NRE)=PGM/TM*DDPM+DDTM C C the row of matrix B corresponding to DELTA C if(inhe.gt.0) B(NDEL,NHE)=BOLK*T*DDP0 B(NDEL,NRE)=PG/T*DDP0+DDT0 END IF C C convective flux and its derivatives C (derivativs wrt. T and P(gas) - calculated numerically; C derivative wrt. DELTA calculated analytically) C if(idisk.eq.1) gravd=zd(id)*qgrav CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON) FLXC(ID)=FLXCNV DHCDD=0. IF(DELMDE.GT.0.) DHCDD=1.5D0/DELMDE*FLXCNV T1=1.001D0*T0 CALL CONVEC(ID,T1,P0,PG0,PR0,AB0,DLT,FLXC1,VCON) DHCDT0=(FLXC1-FLXCNV)*1.D3*HALF DHCDT =DHCDT0/T DHCDTM=DHCDT0/TM DHCDP=0. IF(IPRESS.GT.0) THEN PG1=1.001*PG0 CALL CONVEC(ID,T0,P0,PG1,PR0,AB0,DLT,FLXC2,VCON) DHCDP=(FLXC2-FLXCNV)*1.D3/PG0*HALF IF(IPRESS.GT.1) THEN P1=1.001*P0 CALL CONVEC(ID,T0,P1,PG0,PR0,AB0,DLT,FLXC3,VCON) DHCDPT=(FLXC3-FLXCNV)*1.D3/P0*HALF DHCDP=DHCDP+DHCDPT DHCDT=DHCDT+DHCDPT*4.*PR0/T0 END IF END IF IF(INDL.EQ.0) THEN DHCDT=DHCDT+DHCDD*DDT0 DHCDTM=DHCDTM+DHCDD*DDTM END IF C C additional terms in matrices A and B (the row corresponding to C energy balance, i.e. T) due to convection C C C ** 1. differential equation form C if(redif(id).gt.0) then IF(ICONV.GT.0) THEN IF(INHE.GT.0) A(NRE,NHE)=A(NRE,NHE)-DHCDP*BOLK*TM*redif(id) A(NRE,NRE)=A(NRE,NRE)-(DHCDP*PGM/TM+DHCDTM)*redif(id) IF(INHE.GT.0) B(NRE,NHE)=B(NRE,NHE)+DHCDP*BOLK*T*redif(id) B(NRE,NRE)=B(NRE,NRE)+(DHCDP*PG/T+DHCDT)*redif(id) IF(INDL.GT.0) B(NRE,NDEL)=B(NRE,NDEL)+DHCDD*redif(id) END IF VECL(NRE)=VECL(NRE)-FLXC(ID)*redif(id) end if C C ** 2. integral equation form C if(reint(id).gt.0.AND.ICONV.LE.2) then TP=TEMP(ID+1) PTP=PTOTAL(ID+1) PGP=PGS(ID+1) PRADP=PTP-PGP-HALF*DENS(ID+1)*VTURB(ID+1)**2 if(ilgder.eq.0) then T0=HALF*(T+TP) P0=HALF*(P+PTP) PG0=HALF*(PG+PGP) PR0=HALF*(PRAD+PRADP) AB0=HALF*(ABROSD(ID)+ABROSD(ID+1)) DLT=(TP-T)/(PTP-P)*P0/T0 else T0=SQRT(T*TP) P0=SQRT(P*PTP) PG0=SQRT(PG*PGP) PR0=SQRT(PRAD*PRADP) AB0=SQRT(ABROSD(ID)*ABROSD(ID+1)) DLP=UN/LOG(PTP/P) DLT=LOG(TP/T)*DLP DDTP0= DLP/TP DDTPM=-DLP/T end if CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON) DHCDDP=0. IF(DELMDE.GT.0.) DHCDDP=1.5D0/DELMDE*FLXCNV T1=1.001D0*T0 CALL CONVEC(ID,T1,P0,PG0,PR0,AB0,DLT,FLXC1,VCON) DHCDT0=(FLXC1-FLXCNV)*1.D3*HALF DHCDTP=DHCDT0/TP DHCDTU=DHCDT0/T DHCDPP=0. IF(IPRESS.GT.0) THEN PG1=1.001*PG0 CALL CONVEC(ID,T0,P0,PG1,PR0,AB0,DLT,FLXC2,VCON) DHCDPP=(FLXC2-FLXCNV)*1.D3/PG0*HALF IF(IPRESS.GT.1) THEN P1=1.001*P0 CALL CONVEC(ID,T0,P1,PG0,PR0,AB0,DLT,FLXC3,VCON) DHCDPT=(FLXC3-FLXCNV)*1.D3/P0*HALF DHCDPP=DHCDPP+DHCDPT DHCDTP=DHCDTP+DHCDPT*4.*PR0/T0 END IF END IF IF(INDL.EQ.0) THEN DHCDTP=DHCDTP+DHCDDP*DDTP0 DHCDTU=DHCDTU+DHCDDP*DDTPM END IF C C additional terms in matrices A and B (the row corresponding to C energy balance, i.e. T) due to convection C DELM=(DM(ID+1)-DM(ID-1))*HALF RDELM=DENS(ID)/DELM DELHC=WMM(ID)/DELM*(FLXCNV-FLXC(ID)) IF(ICONV.GT.0) THEN IF(INHE.GT.0) THEN A(NRE,NHE)=A(NRE,NHE)-RDELM*DHCDP*BOLK*TM*reint(id) B(NRE,NHE)=B(NRE,NHE)+ * (DELHC+RDELM*(DHCDP-DHCDPP)*BOLK*T)*reint(id) C(NRE,NHE)=C(NRE,NHE)+RDELM*DHCDPP*BOLK*TP*reint(id) END IF A(NRE,NRE)=A(NRE,NRE)-RDELM*(DHCDP*PGM/TM+DHCDTM)*reint(id) B(NRE,NRE)=B(NRE,NRE)+ * RDELM*((DHCDPP-DHCDP)*PG/T+DHCDTP-DHCDTU)*reint(id) C(NRE,NRE)=C(NRE,NRE)+RDELM*(DHCDPP*PGP/TP+DHCDTP)*reint(id) IF(INPC.GT.0) B(NRE,NPC)=B(NRE,NPC)-DELHC*reint(id) IF(INDL.GT.0) THEN B(NRE,NDEL)=B(NRE,NDEL)-RDELM*DHCDD*reint(id) C(NRE,NDEL)=C(NRE,NDEL)+RDELM*DHCDDP*reint(id) END IF END IF VECL(NRE)=VECL(NRE)-RDELM*(FLXCNV-FLXC(ID))*reint(id) end if END IF RETURN END C C C ****************************************************************** C C SUBROUTINE TEMCOR C ================= C C Auxiliary procedure for INILAM. C Tests wheather the convective flux corresponding to newly C determined temperature and logarithmic gradient DELTA C is larger than the total flux. If so, the temperature is modified C by an iterative procedure for determining new temperature C that yields convective flux less than SIG4P*TEFF**4 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ALIPAR.FOR' COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD C IF(ICONV.LE.0.AND.INDL.EQ.0) RETURN FLXTO0=SIG4P*TEFF**4 ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) DLTND=DELTA(ND) IFNDM1=0 C DO 100 ID=2,ND flxtot=flxto0 if(idisk.eq.1) then flxtot=flxto0*(un-thetav(id)) gradv=zd(id)*qgrav end if T=TEMP(ID) P=PTOTAL(ID) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 TM=TEMP(ID-1) PM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 IF(ID.EQ.ND.AND.IFNDM1.EQ.1) THEN FAC=DLTND*(P-PM)/(P+PM) T=TM*(UN+FAC)/(UN-FAC) END IF KKK=0 10 KKK=KKK+1 T0=HALF*(T+TM) P0=HALF*(P+PM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 DELTA(ID)=DLT C C convective flux and its derivatives C CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON) FLXC(ID)=FLXCNV IF(FLXCNV.LT.0.999999*FLXTOT) GO TO 100 C C in case that convective flux it too large: C iterative procedure for determining new temperature such C that yields convective flux less than SIG4P*TEFF**4 C C Basically by the Newton-Raphson method; C derivative of the convective flux wrt. T calculated C numerically; derivative wrt. DELTA calculated analytically C DHCDD=0. IF(DELMDE.GT.0.) DHCDD=1.5D0/DELMDE*FLXCNV T1=1.001D0*T0 CALL CONVEC(ID,T1,P0,PG0,PR0,AB0,DLT,FLXC1,VCON) DHCDT=(FLXC1-FLXCNV)*1.D3/T0*HALF TT=T*T-TM*TM DDT0= DLT/HALF*TM/TT DFLCDT=DHCDT+DHCDD*DDT0 DELTEM=(FLXTOT-FLXCNV)/DFLCDT T1=T+DELTEM IF(T1.LT.TM+HALF*(T-TM)) T1=TM+HALF*(T-TM) T=T1 write(94,601) iter,id,kkk,delta(id),temp(id),t,deltem,flxcnv 601 format(3i4,f10.4,2f12.3,f12.5,1pe15.6) TEMP(ID)=T IF(ID.EQ.ND-1) IFNDM1=1 IF(KKK.LE.10.and.abs(deltem/t).gt.1.e-5) GO TO 10 C C Determination of electron density from the total pressure C AN=PG/T/BOLK CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROS=OPROS/DENS(ID) ABROSD(ID)=ABROS 100 CONTINUE RETURN END C C C ****************************************************************** C C SUBROUTINE CONCOR C ================= C C Auxiliary procedure called from INILAM C Initialization of the model parameter DELTA immediately C after a completed iteration of complete linearization C C DELTA is defined as d(lnT)/dln(P) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C IF(INDL.EQ.0) RETURN NDEL=NFREQE+INDL C if(idisk.eq.0) then PRAD0=PRADT(1)-PRD0 DO ID=1,ND PTOTAL(ID)=DM(ID)*GRAV+PRAD0 END DO end if C DO ID=2,ND P=PTOTAL(ID) PM=PTOTAL(ID-1) DEL1=DELTA(ID) TM=TEMP(ID-1) T1=TEMP(ID) FAC=DEL1*(P-PM)/(P+PM) T2=TM*(UN+FAC)/(UN-FAC) DEL2=(T1-TM)/(P-PM)/(T1+TM)*(P+PM) IF(ITEMP.EQ.1.AND.ID.GE.ICBEG-1) TEMP(ID)=T2 IF(ITEMP.EQ.2) TEMP(ID)=T2 END DO C C check whether the corresponding convective flux is less C than total flux; if not, recalculate tempertaure C if(itmcor.ne.0) then CALL TEMCOR write(6,603) call conout(1,ipconf) end if c 603 format(' recalculation of convective flux in CONCOR'/) RETURN END C C C ****************************************************************** C C SUBROUTINE CONREF C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ARRAY1.FOR' COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD common/imucnn/imucon dimension idcon(mdepth), * flxtt(mdepth),delta0(mdepth) C IF(ICONV.LE.0.AND.INDL.EQ.0) RETURN FLXTO0=SIG4P*TEFF**4 DLTND=DELTA(ND) IFNDM1=0 C ICBEG=0 ICEND=0 DO ID=2,ND T=TEMP(ID) P=PTOTAL(ID) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 TM=TEMP(ID-1) PM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 IF(ID.EQ.ND.AND.IFNDM1.EQ.1) THEN FAC=DLTND*(P-PM)/(P+PM) T=TM*(UN+FAC)/(UN-FAC) END IF if(ilgder.eq.0) then T0=HALF*(T+TM) P0=HALF*(P+PM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 else T0=SQRT(T*TM) P0=SQRT(P*PM) PG0=SQRT(PG*PGM) PR0=SQRT(PRAD*PRADM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) DLT=LOG(T/TM)/LOG(P/PM) end if DELTA(ID)=DLT if(idisk.eq.0) then flxtot=flxto0 gravd=grav else flxtot=flxto0*(1.d0-thetav(id)) gravd=qgrav*zd(id) end if flxtt(id)=flxtot C C convective flux C CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,VCON) FLXC(ID)=FLXCNV idcon(id)=0 if(flxc(id).gt.0.) idcon(id)=1 IF(ICBEG.EQ.0.AND.FLXC(ID).GT.0..AND.FLXC(ID-1).EQ.0.. * AND.ID.GT.IDCONZ) ICBEG=ID if(icbeg.gt.0.and.flxc(id).gt.0.) icend=id END DO C c correction algorithm - if in the convetion zone one has c some depth point have gradient slightly smaller that the c adaibatic gradient, recompute gradients to have convection there. C in this case, the radiation flux is held fixed c c icbeg0=icbeg if(ideepc.gt.0) then if(icend.eq.nd-1.and.ideepc.eq.2) icend=nd icbegd=icend do id=icend,icbeg,-1 if(idcon(id).gt.0) then icbegd=id else igap=0 do idd=id-1,id-ndcgap,-1 if(idcon(idd).gt.0) igap=1 end do if(igap.gt.0) then icbegd=id else go to 10 end if end if end do 10 continue icbeg0=icbegd end if c if(ideepc.eq.3) icend=nd if(ideepc.ge.4) then if(icend.le.icbegp) then icbeg0=icbegp icend=icendp end if end if icbegp=icbeg0 icendp=icend c if(icbeg0.gt.0.and.icend.gt.0) then write(6,601) icbeg0,icend 601 format(/' convective refinement between depths ',2i4/) c c check the temperature at the depth just above the base of c convection zone; if there is an oscillation there, re-adjust c the temperature c if(temp(icbeg0-1).lt.temp(icbeg0-2).and. * temp(icbeg0-1).lt.temp(icbeg0)) then temp(icbeg0-1)=half*(temp(icbeg0)+temp(icbeg0-2)) end if c do id=icbeg0,icend T=TEMP(ID) P=PTOTAL(ID) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 TM=TEMP(ID-1) PM=PTOTAL(ID-1) PGM=PGS(ID-1) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 if(ilgder.eq.0) then P0=HALF*(P+PM) T0=HALF*(T+TM) PG0=HALF*(PG+PGM) PR0=HALF*(PRAD+PRADM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 ppd=(p+pm)/(p-pm) else T0=SQRT(T*TM) P0=SQRT(P*PM) PG0=SQRT(PG*PGM) PR0=SQRT(PRAD*PRADM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) DLT=LOG(T/TM)/LOG(P/PM) end if if(idisk.eq.0) then flxtot=flxto0 gravd=grav else flxtot=flxto0*(1.d0-thetav(id)) gravd=qgrav*zd(id) end if fcnv=flxtot-flrd(id) tor=t if(fcnv.le.0.) fcnv=flxtot*(un-flrd(id)/flrd(2)) if(fcnv.lt.0.) fcnv=0.001*flxtot c c iteration loop to correct temperature c iic=0 20 iic=iic+1 if(ilgder.eq.0) then T0=HALF*(T+TM) AB0=HALF*(ABROSD(ID)+ABROSD(ID-1)) DLT=(T-TM)/(P-PM)*P0/T0 else T0=SQRT(T*TM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) DLT=LOG(T/TM)/LOG(P/PM) end if DELTA(ID)=DLT if(flxc(id)/flxtot.gt.crflim) then CALL CONVC1(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCNV,FC0) deltae=(fcnv/fc0)**0.666666666666667 deltaa=deltae+bcnv*sqrt(deltae) dlt=deltaa+grdadb end if told=t if(ilgder.eq.0) then dlp=dlt/ppd t=tm*(un+dlp)/(un-dlp) else t=tm*(P/PM)**DLT end if flxcnv=fc0*deltae**1.5 ff=flxcnv/flxtot dtt=(t-told)/told erfl=(flrd(id)+flxcnv)/flxtot if(ilgder.eq.0) then T0=HALF*(T+TM) DLT=(T-TM)/(P-PM)*P0/T0 else T0=SQRT(T*TM) DLT=LOG(T/TM)/LOG(P/PM) end if CALL CONVEC(ID,T0,P0,PG0,PR0,AB0,DLT,FLXCN0,VCON) erfl=(flrd(id)+flxcn0)/flxtot if(abs(dtt).gt.1.e-9.and.iic.lt.10) go to 20 delta(id)=dlt temp(id)=t c write(6,667) id,iic,tor,t,flxcn0/flxtot,dlt,grdadb end do c c new refinement procedure c if(iter.ge.imucon) then icbeg0=icbeg icend=nd icendp=nd write(6,674) imucon,icbeg0,icend 674 format(/' modification with imucon: icbeg0,icend',3i4) write(6,677) icbeg0,icend 677 format(/' new refinement procedure: icbeg0, icend ',2i4/ *' entries are: id,itrc,t,dlt,grdadb,flrd/ft,flr/ft,fcn0/ft, *(fcn0+flr)/ft'/) do id=icbeg0,icend t=temp(id) p=ptotal(id) tm=temp(id-1) pm=ptotal(id-1) pg=pgs(id) PG=PGS(ID) PRAD=P-PG-HALF*DENS(ID)*VTURB(ID)**2 PGM=PGS(ID) PRADM=PM-PGM-HALF*DENS(ID-1)*VTURB(ID-1)**2 pg0=sqrt(pg*pgm) pr0=sqrt(prad*pradm) told=t fcnv=flxtt(id)-flrd(id) t0=sqrt(t*tm) p0=sqrt(p*pm) ab0=sqrt(abrosd(id)*abrosd(id-1)) dlt=log(t/tm)/log(p/pm) call convc1(id,t0,p0,pg0,prad0,ab0,dlt,flxcn0,fc0) alp=min(flrd(id),flxtt(id))/t0**4/dlt c if(fcnv.le.0.) go to 200 if(flxcn0.le.0.) go to 200 c bet=bcnv/t0**3 deltae=(fcnv/fc0)**twothr deltaa=deltae+bcnv*sqrt(deltae) dlt=deltaa+grdadb t=tm*(P/PM)**DLT t0=sqrt(t*tm) c itrnrc=0 100 continue itrnrc=itrnrc+1 t1=un/t dltp=t1/log(p/pm) t0p=half*t0*t1 dele=(flxtt(id)-alp*t0**4*dlt)/fc0 dele3= dele**third delep=-alp*t0**4*dlt/fc0*(two*t1+d1tp/dlt) vl=dlt-grdadb-dele3*(dele3+bet*t0**3) bb=dltp-twothr*delep/dele3- * bet*t0**3*dele3*(1.5d0*t1+third*delep/dele) dt=-vl/bb*t1 t=t*(un+dt) t0=sqrt(t*tm) dlt=log(t/tm)/log(p/pm) call convc1(id,t0,p0,pg0,prad0,ab0,dlt,flxcn0,fc0) 645 format(2i4,1pe11.3,0pf8.2,1p3e13.5) if(abs(dt).lt.1.e-9.or.itrnrc.gt.20) go to 110 go to 100 110 continue go to 230 c 200 continue if(flxtt(id).lt.flrd(id)) then alp=flxtt(id)/flrd(id)*t0**4*delta0(id) itrnrc=0 210 continue itrnrc=itrnrc+1 t1=un/t dltp=t1/log(p/pm) t0p=half*t0*t1 dele=alp-t0**4*dlt delep=-t0**4*dlt*(two*t1+dltp/dlt) dt=-dele/delep*t1 t=t*(un+dt) write(6,645) id,itrnrc,dt,t if(abs(dt).lt.1.e-6.or.itrnrc.gt.20) go to 220 t0=sqrt(t*tm) dlt=log(t/tm)/log(p/pm) go to 210 220 continue alp=flrd(id)/t0**4/dlt end if c 230 continue delta(id)=dlt temp(id)=t flr=alp*t0**4*dlt if(dlt.ge.grdadb) then flc=fc0*dele write(6,646) id,itrnrc,t,dlt,grdadb,flrd(id)/flxtt(id), * flr/flxtt(id),flc/flxtt(id),flxcn0/flxtt(id), * (flr+flxcn0)/flxtt(id) else itrnrc=0 write(6,646) id,itrnrc,t,dlt,grdadb,flrd(id)/flxtt(id), * flr/flxtt(id) end if 646 format(2i4,f8.1,1p7e12.4) end do end if c if(ioptab.ge.-1.and.ifryb.gt.0) then do id=1,nd t=temp(id) an=pgs(id)/bolk/t CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) END DO END IF c call tdpini call conout(1,ipconf) end if c return end C C C C ****************************************************************** C C SUBROUTINE PZEVAL C ================= C C Auxiliary procedure called from RESOLV C determination of the total and gas pressures, and logarithmic C gradient of pressure C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' common/icnrsp/iconrs C C total pressure, gas pressure, and logarithmic gradient DELTA C IF(IPPZEV.GT.0) WRITE(6,601) DO ID=1,ND PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PGS0=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) PTOTL0=PGS0+PRADT(ID)+PTURB PTOTL1=GRAV*DM(ID)+PRADT(1)-PRD0 PGS1=PTOTL1-PTURB-PRADT(ID) AAA=3.D0*PRADT(ID)/TEMP(ID)**4/7.5639D-15 if(idisk.eq.0) then PTOTAL(ID)=PTOTL1 PGS(ID)=PGS1 else PTOTAL(ID)=PTOTL0 PGS(ID)=PGS0 end if IF(IPPZEV.GT.0) WRITE(6,602) ID,PTOTL0,PTOTL1,PGS0,PGS1, * PRADT(ID),AAA END DO IF(HMIX0.LT.0.) RETURN IF(IPPZEV.GT.0) THEN WRITE(6,600) ITER-1 CALL CONOUT(1,IPCONF) END IF if(iconre.gt.0.and.iter.le.iconre.and.iter.ge.iconrs) call conref IF(IPPZEV.EQ.0.AND.LFIN) THEN WRITE(6,600) ITER-1 CALL CONOUT(1,1) END IF 600 FORMAT(/' CONVECTIVE FLUX: RESOLV; GLOBAL ITERATION =',I2/) 601 FORMAT(/' ID PTOT-SUM PTOT-MG PGAS-RHO PGAS-P PRAD', * ' A'/) 602 FORMAT(I4,1P6D10.3) RETURN END C C C ****************************************************************** C C SUBROUTINE PZEVLD C ================= C C Auxiliary procedure called from RESOLV C determination of the total and gas pressures, and logarithmic C gradient of pressure C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 COMMON/DEPTDR/DDM(MDEPTH),DDP(MDEPTH),DD0(MDEPTH), * DDMIN(MDEPTH),DDPLU(MDEPTH),DDA(MDEPTH), * DDC(MDEPTH),DDB(MDEPTH) common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) common/ifpzpa/ifpzev dimension dpp(mdepth),zd1(mdepth),zd2(mdepth),zd3(mdepth), * ZOLD(MDEPTH) C if(ifryb.gt.0.and.ifpzev.eq.0) return iheitr=0 5 continue iheitr=iheitr+1 C C geometrical distance from the central plane - z C if(ihecor.ge.0) then ZD(ND)=ZND DO IID=1,ND-1 ID=ND-IID if(iheitr.eq.1) then ZD(ID)=ZD(ID+1)+HALF*(DM(ID+1)-DM(ID))*(UN/DENS(ID+1)+ * UN/DENS(ID)) ZOLD(ID)=ZD(ID) end if END DO else zd1(1)=-ddc(1)/ddb(1) zd2(1)=-dens1(1)/ddb(1) do id=2,nd-1 x=un/(ddb(id)-dda(id)*zd1(id-1)) zd1(id)=-x*ddc(id) zd2(id)=-x*(dens1(id)-dda(id)*zd2(id-1)) end do zd(nd)=znd do id=nd-1,1,-1 zd(id)=zd1(id)*zd(id+1)+zd2(id) end do end if C C total pressure, gas pressure, and sound speed C DO ID=1,ND PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PGSC=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) PGS(ID)=PGSC PTOTL0=PGS(ID)+PRADT(ID)+PTURB PTOTAL(ID)=PTOTL0 VSND2(ID)=PTOTAL(ID)/DENS(ID) END DO ID=1 HG1=SQRT(2.*PGS(1)/DENS(1)/QGRAV) HR1=PRD0/QGRAV RR1=HR1/HG1 C C recalculate the z-distance C IJ1=1 if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) IJ1=2 DO ID=1,ND GRP=0. FLEX=0. IF(NFREQE.GT.0.or.ifryb.eq.0) THEN DO IJ=IJ1,NFREQE RAD0(IJ)=RADEX(IJ,ID) FK0(IJ)=FAKEX(IJ,ID) ABSO0(IJ)=ABSOEX(IJ,ID) IJT=IJFR(IJ) WD0=W(IJT) FLUXW=FH(IJT)*RAD0(IJ)-HEXTRD(IJT) IF(.NOT.LSKIP(ID,IJT)) THEN IF(ID.EQ.1) THEN GRP=GRP+WD0*FLUXW*ABSO0(IJ) ELSE RADM(IJ)=RADEX(IJ,ID-1) FKM(IJ)=FAKEX(IJ,ID-1) ABSOM(IJ)=ABSOEX(IJ,ID-1) FRD=FK0(IJ)*RAD0(IJ)-FKM(IJ)*RADM(IJ) GRP=GRP+WD0*FRD END IF END IF END DO GRD(ID)=GRP+FPRD(ID) END IF IF(ID.EQ.1) THEN GRV=QGRAV*ZD(ID) ELSE GRV=QGRAV*(ZD(ID)+ZD(ID-1))*HALF dpt=(ptotal(id)-ptotal(id-1))/ddm(id) dpr=(pradt(id)-pradt(id-1))/ddm(id) dpg=(pgs(id)-pgs(id-1))/ddm(id) dpr1=grd(id)/(dm(id)-dm(id-1))*4.19168946e-10 err=10. if(grv.ne.0.) err=(dpg+dpr-grv)/grv dpp(id)=(dpg+dpr1)/qgrav end if end do c if(iter.le.iabs(ifz0)) then zd1(1)=dpp(2) zd1(nd)=znd do id=2,nd-1 zd1(id)=(dpp(id)+dpp(id+1))*half end do c zd2(nd)=znd zd3(nd)=znd izdiv=0 nzdiv=0 do id=nd-1,1,-1 zd2(id)=2.*dpp(id+1)-zd2(id+1) zd3(id)=dpp(id)*ddmin(id)+dpp(id+1)*ddplu(id) if(zd2(id).le.zd2(id+1)) nzdiv=nzdiv+1 if(nzdiv.eq.1) izdiv=id end do c if(ihecor.ge.0) then do id=1,nd zd(id)=zd2(id) if(id.le.izdiv) zd(id)=zd1(id) end do else do id=1,nd zd(id)=zd3(id) end do end if c c recalculate densities (if required) c if(ihecor.gt.0) then do id=nd-1,1,-1 x=HALF*(DM(ID+1)-DM(ID)) xne=elec(id)/dens(id) dens(id)=x*dens(id+1)/((zd(id)-zd(id+1))*dens(id+1)-x) dens1(id)=un/dens(id) elec(id)=xne*dens(id) end do else if(ihecor.lt.-1) then do id=nd-1,1,-1 xne=elec(id)/dens(id) if(id.gt.1) then dens1(id)=zd(id-1)*dda(id)-zd(id)*ddb(id)- * zd(id+1)*ddc(id) else dens1(id)=-zd(id)*ddb(id)-zd(id+1)*ddc(id) end if dens(id)=un/dens1(id) elec(id)=xne*dens(id) end do end if c dzmx=0. do id=1,nd-1 dzmx=max(dzmx,abs((zd(id)-zold(id))/zd(id))) zold(id)=zd(id) end do if(iheitr.ge.5.or.dzmx.lt.1.d-3) go to 25 go to 5 25 continue c end if RETURN END C C C ******************************************************************** C C SUBROUTINE LEMINI C ================= C C Initializes necessary arrays for evaluating hydrogen line profiles C from the Lemke tables C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C DO I=1,4 DO J=1,22 ILINH(I,J)=0 END DO END DO 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 C --------------------------------- C read Lemke or Tremblay tables C --------------------------------- C ILINE=0 READ(IHYDPR,*) NTAB 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 write(6,643) ntab,nlly,iline,i,j 643 format(' ntab,nlly,iline,i,j ',5i4) ILINH(I,J)=ILINE NWLH(ILINE)=NWL NWLHYD(ILINE)=NWL NTH(ILINE)=NT NEH(ILINE)=NE DO IWL=1,NWL WLH(IWL,ILINE)=ALMIN+(IWL-1)*DLA WLHYD(ILINE,IWL)=WLH(IWL,ILINE) WLH(IWL,ILINE)=EXP(2.3025851*WLH(IWL,ILINE)) END DO DO INE=1,NE XNELEM(INE,ILINE)=ANEMIN+(INE-1)*DLE END DO DO IT=1,NT XTLEM(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,(PRFHYD(ILNE,IWL,IT,INE),IWL=1,NWL) END DO END DO C C coefficient for the asymptotic profile is determined from C the input data C XCLOG=PRFHYD(ILNE,NWL,1,1)+2.5*WLHYD(ILNE,NWL)-0.477121 XKLOG=0.6666667*XCLOG XK0(ILNE)=EXP(XKLOG*2.3025851) END DO END DO CLOSE(IHYDPR) 500 FORMAT(1X) C RETURN END C C C ******************************************************************** C C SUBROUTINE INTLEM(PRFH,WL0,ILINE,ID) C ==================================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (FOC1=1.25e-9,TTW=2./3.,VTBC=6.06e-9) DIMENSION PRFH(MHWL) C C temperature is modified in order to account for the C effect of turbulent velocity on the Doppler width C T=TEMP(ID)+VTBC*VTURBS(ID)*VTURBS(ID) ANE=ELEC(ID) TL=LOG10(T) ANEL=LOG10(ANE) F00=FOC1*EXP(TTW*LOG(ANE)) XK=XK0(ILINE) 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 C NWL=NWLHYD(ILINE) DO IWL=1,NWL CALL INTHYD(PRFH0,TL,ANEL,IWL,ILINE) PRFH(IWL)=PRFH0 END DO RETURN END C C C ******************************************************************** C C SUBROUTINE INTHYD(W0,X0,Z0,IWL,ILINE) C ===================================== C C Interpolation in temperature and electron density from the C Lemke tables for hydrogen lines to the actual valus of C temperature and electron density C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' DIMENSION ZZ(3),XX(3),WX(3),WZ(3) C NX=2 NZ=2 NT=NTH(ILINE) NE=NEH(ILINE) BETA=WLH(IWL,ILINE)/XK IZH=1 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.XNELEM(1,ILINE)*0.99) THEN CALL DIVSTR(IZH) W0=STARKA(BETA,TWO)*DBETA W0=LOG10(W0) RETURN 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.XNELEM(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 IZZ=N0Z,N1Z I0Z=IZZ-N0Z+1 ZZ(I0Z)=XNELEM(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 C IF(X0.GT.1.01*XTLEM(NT,ILINE).AND.BETAD.GT.10.) THEN IF(X0.GT.1.01*XTLEM(NT,ILINE)) THEN CALL DIVSTR(IZH) W0=STARKA(BETA,TWO)*DBETA W0=LOG10(W0) RETURN 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.XTLEM(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)=XTLEM(IX,ILINE) WX(I0)=PRFHYD(ILINE,IWL,IX,IZZ) END DO IF(WX(1).LT.-99..OR.WX(2).LT.-99..OR.WX(3).LT.-99.) THEN CALL DIVSTR(IZH) W0=STARKA(BETA,TWO)*DBETA W0=LOG10(W0) RETURN ELSE WZ(I0Z)=YINT(XX,WX,X0) END IF END DO W0=YINT(ZZ,WZ,Z0) RETURN END C C C ******************************************************************** C C FUNCTION YINT(XL,YL,XL0) C ======================== C C Quadratic interpolation routine C C Input: XL - array of x C YL - array of f(x) C XL0 - the point x(0) to which one interpolates C INCLUDE 'IMPLIC.FOR' DIMENSION XL(3),YL(3) A0=(XL(2)-XL(1))*(XL(3)-XL(2))*(XL(3)-XL(1)) A1=(XL0-XL(2))*(XL0-XL(3))*(XL(3)-XL(2)) A2=(XL0-XL(1))*(XL(3)-XL0)*(XL(3)-XL(1)) A3=(XL0-XL(1))*(XL0-XL(2))*(XL(2)-XL(1)) YINT=(YL(1)*A1+YL(2)*A2+YL(3)*A3)/A0 RETURN END C C C ****************************************************************** C C SUBROUTINE STARK0(I,J,IZZ,XKIJ,WL0,FIJ) C ======================================= C C Auxiliary procedure for evaluating the approximate Stark profile C of hydrogen lines - sets up necessary frequency independent C parameters C C Input: I - principal quantum number of the lower level C J - principal quantum number of the upper level C IZZ - ionic charge (IZZ=1 for hydrogen, etc.) C Output: XKIJ - coefficients K(i,j) for the Hotzmark profile; C exact up to j=6, asymptotic for higher j C WL0 - wavelength of the line i-j C FIJ - Stark f-value for the line i-j C INCLUDE 'IMPLIC.FOR' PARAMETER (RYD1=911.763811,RYD2=911.495745/4.,CXKIJ=5.5E-5) PARAMETER (WI1=911.753578, WI2=227.837832) PARAMETER (UN=1.,TEN=10.,TWEN=20.,HUND=100.) DIMENSION FSTARK(10,4),XKIJT(5,4) DATA XKIJT/3.56D-4,5.23D-4,1.09D-3,1.49D-3,2.25D-3,.0125,.0177, * .028,.0348,.0493,.124,.171,.223,.261,.342,.683,.866,1.02,1.19, * 1.46/ DATA FSTARK/.1387,.0791,.02126,.01394,.00642,4.814D-3,2.779D-3, * 2.216D-3,1.443D-3,1.201D-3,.3921,.1193,.03766,.02209,.01139, * 8.036D-3,5.007D-3,3.85D-3,2.658D-3,2.151D-3,.6103,.1506,.04931, * .02768,.01485,.01023,6.588D-3,4.996D-3,3.524D-3,2.838D-3,.8163, * .1788,.05985,.03189,.01762,.01196,7.825D-3,5.882D-3,4.233D-3, * 3.375D-3/ SAVE XKIJT,FSTARK C II=I*I JJ=J*J JMIN=J-I IF(JMIN.LE.5) THEN XKIJ=XKIJT(JMIN,I) ELSE XKIJ=CXKIJ*(II*JJ)*(II*JJ)/(JJ-II) END IF IF(JMIN.LE.10) THEN FIJ=FSTARK(JMIN,I) ELSE CFIJ=((TWEN*I+HUND)*J/(I+TEN)/(JJ-II)) FIJ=FSTARK(10,I)*CFIJ*CFIJ*CFIJ END IF WL0=WI1 IF(IZZ.EQ.2) WL0=WI2 WL0=WL0/(UN/II-UN/JJ) RETURN END C C C **************************************************************** C C FUNCTION STARKA(BETA,FAC) C ========================= C C Approximate expressions for the hydrogen Stark profile C C Input: BETA - delta lambda in beta units, C BETAD - Doppler width in beta units C A - auxiliary parameter C A=1.5*LOG(BETAD)-1.761 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)= C = 1.5*FAC*beta**-5/2 C (ie. the point where Doppler profile is equal to C the asymptotic Holtsmark) C In order to save computer time, the division point C DIV is calculated in advance by routine DIVSTR. C FAC - Multiplicative factor (2. for H I; 1. for He II) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (F0=-0.5758228,F1=0.4796232,F2=0.07209481,AL=1.26) PARAMETER (SD=0.5641895,SLO=-2.5,THRA=1.5,BL1=1.14,BL2=11.4) PARAMETER (SAC=0.08, PISQ1=UN/1.77245385090551D0) C C for a > 1 Doppler core + asymptotic Holtzmark wing with division C point DIV C BETAD1=UN/BETAD IF(ADH.GT.AL) THEN XD=BETA*BETAD1 IF(XD.LE.DIVH) THEN STARKA=EXP(-XD*XD)*BETAD1*PISQ1 ELSE STARKA=THRA*FAC*EXP(SLO*LOG(BETA)) END IF ELSE C C empirical formula for a < 1 C IF(BETA.LE.BL1) THEN STARKA=SAC ELSE IF(BETA.LT.BL2) THEN XL=LOG(BETA) FL=(F0*XL+F1)*XL STARKA=F2*EXP(FL) ELSE STARKA=THRA*FAC*EXP(SLO*LOG(BETA)) END IF END IF RETURN END C C C ******************************************************************* C C SUBROUTINE DIVSTR(IAH) C ====================== C C Auxiliary procedure for STARKA - determination of the division C point between Doppler and asymptotic Stark profiles C C Input: BETAD - Doppler width in beta units C Output: A - auxiliary parameter C A=1.5*LOG(BETAD)-1.671 C DIV - only for A > 1; division point between Doppler C and asymptotic Stark wing, expressed in units C of betad. C DIV = solution of equation C exp(-(beta/betad)**2)/betad/sqrt(pi)=3*beta**-5/2 C C He II: different definition of parameter ADH ! C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (UNQ=1.25,UNH=1.5,TWH=2.5,FO=4.,FI=5.) PARAMETER (CA=1.671,BL=5.821,AL=1.26,CX=0.28,DX=0.0001) PARAMETER (CA2=0.978,XA2=0.69314718) C ADH=UNH*LOG(BETAD)-CA IF(IAH.EQ.2) ADH=ADH+XA2 IF(BETAD.LT.BL) RETURN IF(ADH.GE.AL) THEN X=SQRT(ADH)*(UN+UNQ*LOG(ADH)/(FO*ADH-FI)) ELSE X=SQRT(CX+ADH) ENDIF DO I=1,5 X2=X*X XN=X*(UN-(X2-TWH*LOG(X)-ADH)/(TWO*X2-TWH)) IF(ABS(XN-X).LE.DX) GO TO 10 X=XN END DO 10 DIVH=X RETURN END C C C ******************************************************************** C C SUBROUTINE OPAHST C ================= C C Auxiliary routine for START C sets up necessary parameters for routines OPAHYL and OPHYL1, i.e. C for opacity and emissivity in higher hydrogen lines C Also sets up Stark parameters for OPAHYL C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ODFPAR.FOR' C ALLIM1=1450. ABLIM1=6650. ABLIM2=5000. ABLIM3=6500. C C Lyman lines C ILOW=1 IF(IABS(IOPHL1).EQ.1) IOPHL2=IOPHL2*2 DO I=1,4 M1FILE(I,ILOW)=MAX(I,IABS(IOPHL1)) M2FILE(I,ILOW)=I+1 END DO DO I=5,NLMX M1FILE(I,ILOW)=MAX(I-1,IABS(IOPHL1)) M2FILE(I,ILOW)=MIN(I+3,NLMX) END DO M1FILE(NLMX,ILOW)=NLMX+1 M2FILE(NLMX,ILOW)=NLMX C IF(IABS(IOPHL1).GT.100) THEN IOPHL1=MOD(IOPHL1,100) ISET=0 40 CONTINUE READ(IBUFF,*,ERR=90) IL1,IU1,IM1,IP1 ISET=ISET+1 IF(IL1.LE.0.AND.ISET.EQ.1) THEN IL1=1 IU1=4 IM1=0 IP1=1 END IF IF(IL1.LE.0.AND.ISET.EQ.2) THEN IL1=5 IU1=NLMX IM1=1 IP1=3 END IF IUP1=MIN(IU1,NLMX) DO I=IL1,IUP1 M1FILE(I,ILOW)=MAX(I-IM1,IABS(IOPHL1)) M2FILE(I,ILOW)=MIN(I+IP1,NLMX) END DO IF(IU1.LT.NLMX) GO TO 40 90 CONTINUE READ(IBUFF,*,ERR=100) ALLIM1 IF(ALLIM1.LE.0) ALLIM1=1450. END IF M1FILE(NLMX,ILOW)=NLMX+1 M2FILE(NLMX,ILOW)=NLMX C C Balmer lines C 100 ILOW=2 IF(IABS(IOPHL2).EQ.1) IOPHL2=IOPHL2*3 IF(IABS(IOPHL2).EQ.2) IOPHL2=IOPHL2*3/2 DO I=1,6 M1FILE(I,ILOW)=MAX(I,IABS(IOPHL2)) M2FILE(I,ILOW)=I+1 END DO DO I=7,NLMX M1FILE(I,ILOW)=MAX(I-1,IABS(IOPHL2)) M2FILE(I,ILOW)=MIN(I+3,NLMX) END DO IF(IABS(IOPHL2).GT.100) THEN IOPHL2=MOD(IOPHL2,100) ISET=0 140 CONTINUE READ(IBUFF,*,ERR=190) IL1,IU1,IM1,IP1 ISET=ISET+1 IF(IL1.LE.0.AND.ISET.EQ.1) THEN IL1=1 IU1=6 IM1=0 IP1=1 END IF IF(IL1.LE.0.AND.ISET.EQ.2) THEN IL1=7 IU1=NLMX IM1=1 IP1=3 END IF IUP1=MIN(IU1,NLMX) DO I=IL1,IUP1 M1FILE(I,ILOW)=MAX(I-IM1,IABS(IOPHL2)) M2FILE(I,ILOW)=MIN(I+IP1,NLMX) END DO IF(IU1.LT.NLMX) GO TO 140 190 CONTINUE READ(IBUFF,*,ERR=200,END=200) ABLIM1,ABLIM2,ABLIM3 IF(ABLIM1.LE.0) ABLIM1=6650. IF(ABLIM2.LE.0) ABLIM2=5000. IF(ABLIM3.LE.0) ABLIM3=6500. END IF 200 CONTINUE M1FILE(NLMX,ILOW)=NLMX+1 M2FILE(NLMX,ILOW)=NLMX c C ------------------- C Stark paramereters C ------------------- C izzh=1 IF(IOPHL1.NE.0) THEN I=1 I1=MAX(2,IABS(IOPHL1)) DO J=I1,NLMX CALL STARK0(I,J,izzh,XKIJ(I,J),WL0(I,J),FIJ(I,J)) END DO END IF IF(IOPHL2.NE.0) THEN I=2 I2=MAX(3,IABS(IOPHL2)) DO J=I2,NLMX CALL STARK0(I,J,izzh,XKIJ(I,J),WL0(I,J),FIJ(I,J)) END DO END IF RETURN END C C C ******************************************************************** C C SUBROUTINE WNSTOR(ID) C ===================== C C Stores occupation probabilities for hydrogen levels C in common WNCOM for further use C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (SIXTH=UN/6.,CCOR=0.09) parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.) parameter (tkn=3.01,ckn=5.33333333,cb0=8.59d14,f23=-2./3.) if(ioptab.lt.0) return C cb=cb0*bergfc ANE=ELEC(ID) A=CCOR*EXP(SIXTH*LOG(ANE))/SQRT(TEMP(ID)) z=un x=exp(p4*log(un+p3*a)) c1=p1*(x+p5*(z-un)*a*a*a) c2=p2*x beta0=cb*z*z*z*exp(f23*log(ane)) DO I=1,NLMX XN=I if(xn.le.tkn) then xkn=un else xn1=un/(xn+un) xkn=ckn*xn*xn1*xn1 end if beta=beta0*xkn*xi2(i)*xi2(i) f=(c1*beta*beta*beta)/(un+c2*beta*sqrt(beta)) WNHINT(I,ID)=f/(un+f) END DO C C array WOP - occupation probabilities for explicit levels C (if ifwop>1, occ. probabilities have been initialized C for iron-peak elements and are not updated) C do ii=1,nlevel if(ifwop(ii).le.0) then wop(ii,id)=un else if(ifwop(ii).eq.1) then ie=iel(ii) nq=nquant(ii) if(iz(ie).eq.1) then wop(ii,id)=wnhint(nq,id) else z=iz(ie) xn=nq wop(ii,id)=wn(xn,a,ane,z) end if end if if(ifwop(ii).gt.1.and.lte) wop(ii,id)=un end do RETURN END C C C ******************************************************************** C C function wn(xn,a,ane,z) c c evaluation of the occupation probablities for a hydrogenic ion c using eqs (4.26), and (4.39) of Hummer,Mihalas Ap.J. 331, 794, 1988. c approximate evaluation of Q(beta) - Hummer c c Input: xn - real number corresponding to quantum number n c a - correlation parameter c ane - electron density c z - ionic charge c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.) parameter (tkn=3.01,ckn=5.33333333,cb0=8.59d14) parameter (f23=-2./3.) c cb=cb0*bergfc c c evaluation of k(n) c if(xn.le.tkn) then xkn=un else xn1=un/(xn+un) xkn=ckn*xn*xn1*xn1 end if c c evaluation of beta c beta=cb*z*z*z*xkn/(xn*xn*xn*xn)*exp(f23*log(ane)) c c approximate expression for Q(beta) c x=exp(p4*log(un+p3*a)) c1=p1*(x+p5*(z-un)*a*a*a) c2=p2*x f=(c1*beta*beta*beta)/(un+c2*beta*sqrt(beta)) wn=f/(un+f) return end C C C ******************************************************************** C C SUBROUTINE DWNFR(MODE,N,FRE,A,ANE,Z,FR,DW) C ========================================== C C Auxiliary routine to compute set of dissolved fractions C for all frequencies C MODE=0 -> DW=1 C MODE>0 -> DW=1-w C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.) parameter (tkn=3.01,ckn=5.33333333,cb0=8.59d14,f23=-2./3.) PARAMETER (FRH=3.28805D15,SQFRH=5.734152D7) DIMENSION FR(N),DW(N) C cb=cb0*berfc IF(MODE.EQ.0) THEN DO IJ=1,N DW(IJ)=UN END DO ELSE DO IJ=1,N IF(FR(IJ).LT.FRE) THEN XN=SQFRH*Z/SQRT(FRE-FR(IJ)) if(xn.le.tkn) then xkn=un else xn1=un/(xn+un) xkn=ckn*xn*xn1*xn1 end if beta=cb*z*z*z*xkn/(xn*xn*xn*xn)*exp(f23*log(ane)) x=exp(p4*log(un+p3*a)) c1=p1*(x+p5*(z-un)*a*a*a) c2=p2*x f=(c1*beta*beta*beta)/(un+c2*beta*sqrt(beta)) DW(IJ)=UN-f/(un+f) ELSE DW(IJ)=UN END IF END DO END IF RETURN END C C C ******************************************************************** C C SUBROUTINE ODF1(IMODE,IL,IU,ID,ODF) C =================================== C C opacity distribution function for overlapping lines near the series limit C C The lines converge to the edge of the (continuum) transition IL - IU, C IL - index of the lower level C IU - index of the upper level (usually the ground state of teh next ion) C ID - depth index C C Output: ODF - opacity distribution function interpolated to the set of C explicit frequencies C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (FRH=3.28805D15,CQT=1.284523D12) PARAMETER (CCOR=0.09,C00=1.25D-9,CID=0.02654,SIXTH=UN/6.) DIMENSION FRO(MFRO),ODF0(MFRO),ABSO0(MFRO),ODF(MFREQ),SGT(MFRO), * ALAM(MFRO), * FROD(MFRO),SGFR(MFRO),IODF(MFRO),IODR(MFRO),DWF(MFRO) SAVE FRO,SGFR,ODF0,IODF C I=NQUANT(IL) KL=INDODF(IL) IELO=IEL(IL) N1H=NLAST(IELO) NQ1=NQLODF(IL) FRE=ENION(IL)/H T=TEMP(ID) SQT=SQRT(T) ANE=ELEC(ID) ANES=EXP(SIXTH*LOG(ANE)) F00=C00*ANES*ANES*ANES*ANES DOP0=CQT*SQT QZ=IZ(IELO) C C pseudocontinuum opacity (non-zero in all frequencies); C formulated through the dissolved fraction C ITR=ITRA(IL,IU) NFR0=NFRODF(KL) IF(IMODE.EQ.0) THEN DO IJ=1,NFR0 FRO(IJ)=FROS(IJ,KL) SGFR(IJ)=SIGK(FRO(IJ),ITR,1) ALAM(IJ)=CAS/FRO(IJ) END DO END IF C C function D(nu) - dissolved fraction C c CALL DWNFR(1,NFR0,FRE,ACOR,ANE,QZ,FRO,DWF) DO IJ=1,NFR0 ABSO0(IJ)=SGFR(IJ)*DWF(IJ) END DO C C summation over individual lines C DO J=NQ1,NLMX XJ=J FXK=F00*XKIJ(KL,J) DOP=DOP0/WL0(KL,J) DBETA=WL0(KL,J)*WL0(KL,J)/CAS/FXK BETAD=DOP*DBETA FID=CID*FIJ(KL,J)*DBETA CALL DIVSTR(1) WPROB=WNHINT(J,ID) CALL ODFHST(NFR0,FXK,FID,WPROB,WL0(KL,J),ALAM,SGT) DO IJ=1,NFR0 ABSO0(IJ)=ABSO0(IJ)+SGT(IJ) END DO END DO C C opacity distribution function in the internal set of frequencies C IF(IMODE.EQ.0) THEN ODF0(1)=ABSO0(1) IODF(1)=1 DO IJ=2,NFR0 ODF0(IJ)=ABSO0(IJ) IODF(IJ)=IJ IF(ODF0(IJ).LT.ODF0(IJ-1)) THEN AB=ODF0(IJ) IJODF=IODF(IJ) DO IJ0=1,IJ-1 IJ1=IJ-IJ0+1 IF(ODF0(IJ1).GE.ODF0(IJ1-1)) GO TO 71 ODF0(IJ1)=ODF0(IJ1-1) ODF0(IJ1-1)=AB IODF(IJ1)=IODF(IJ1-1) IODF(IJ1-1)=IJODF END DO 71 CONTINUE END IF if(odf0(ij).gt.0.001) write(6,603) ij,id,odf0(ij) 603 format(' ij,id,odf0',2i5,1pd10.3) END DO ELSE ODF0(1)=ABSO0(IODF(1)) IODR(1)=IODF(1) DO IJ=2,NFR0 ODF0(IJ)=ABSO0(IODF(IJ)) IODR(IJ)=IODF(IJ) IF(ODF0(IJ).LT.ODF0(IJ-1)) THEN AB=ODF0(IJ) IJODF=IODR(IJ) DO IJ0=1,IJ-1 IJ1=IJ-IJ0+1 IF(ODF0(IJ1).GE.ODF0(IJ1-1)) GO TO 86 ODF0(IJ1)=ODF0(IJ1-1) ODF0(IJ1-1)=AB IODR(IJ1)=IODR(IJ1-1) IODR(IJ1-1)=IJODF END DO 86 CONTINUE END IF if(odf0(ij).gt.0.001) write(6,603) ij,id,odf0(ij) END DO DO IJ=1,NFR0 IODF(IJ)=IODR(IJ) END DO END IF C C Reinitialization of the internal frequencies set C FROD(1)=FRO(1) IW=IODF(1) IF(IW.GT.1 .AND. IW.LT.NFR0) THEN W1=FRO(IW-1)-FRO(IW+1) ELSE IF (IW.EQ.1) THEN W1=FRO(1)-FRO(2) ELSE W1=FRO(NFR0-1)-FRO(NFR0) END IF DO IJ=2,NFR0-1 IW=IODF(IJ) IF(IW.GT.1 .AND. IW.LT.NFR0) THEN W2=HALF*(FRO(IW-1)-FRO(IW+1)) ELSE IF (IW.EQ.1) THEN W2=HALF*(FRO(1)-FRO(2)) ELSE W2=HALF*(FRO(NFR0-1)-FRO(NFR0)) END IF FROD(IJ)=FROD(IJ-1)-HALF*(W1+W2) W1=W2 END DO IJ=NFR0 IW=IODF(IJ) IF(IW.GT.1 .AND. IW.LT.NFR0) THEN W2=FRO(IW-1)-FRO(IW+1) ELSE IF (IW.EQ.1) THEN W2=FRO(1)-FRO(2) ELSE W2=FRO(NFR0-1)-FRO(NFR0) END IF FROD(IJ)=FROD(IJ-1)-HALF*(W1+W2) C C Interpolated opacity distribution function to explicit frequencies C DO 150 IJ=2,NFREQ IF(FREQ(IJ).GT.FREQ(IJ-1)) RETURN ODF(IJ)=0. IF(FREQ(IJ).GT.FROD(1).OR.FREQ(IJ).LT.FROD(NFR0)) GO TO 150 IF(ID.EQ.1) THEN IF(FREQ(IJ-1).GT.FROD(1)) I1ODF(IL)=IJ I2ODF(IL)=IJ END IF DO IJ1=2,NFR0 IJ0=IJ1 IF(FREQ(IJ).GE.FROD(IJ1)) GO TO 120 END DO 120 ODF(IJ)=ODF0(IJ0-1)+(ODF0(IJ0)-ODF0(IJ0-1))/ * (FROD(IJ0)-FROD(IJ0-1))*(FREQ(IJ)-FROD(IJ0-1)) 150 CONTINUE RETURN END C C C ******************************************************************** C C SUBROUTINE ODFHST(N,FXK,FID,WP,WL,ALAM,SG) C ========================================== C C Auxiliary routine for ODF1 (replaces multiple calls to STARKA) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (F0=-0.5758228,F1=0.4796232,F2=0.07209481,AL=1.26) PARAMETER (SD=0.5641895,SLO=-2.5,THRA=1.5,BL1=1.14,BL2=11.4) PARAMETER (SAC=0.08, THR=THRA*TWO) DIMENSION ALAM(MFRO),SG(MFRO) C BETAD1=UN/BETAD FXK1=UN/FXK FIDWP=FID*WP C C for a > 1 Doppler core + asymptotic Holtzmark wing with division C point DIV C IF(ADH.GT.AL) THEN DO IJ=1,N BETA=ABS(ALAM(IJ)-WL)*FXK1 XD=BETA*BETAD1 IF(XD.LE.DIVH) THEN ST=SD*EXP(-XD*XD)*BETAD1 ELSE ST=THR*EXP(SLO*LOG(BETA)) END IF SG(IJ)=ST*FIDWP END DO ELSE C C empirical formula for a < 1 C DO IJ=1,N BETA=ABS(ALAM(IJ)-WL)*FXK1 XD=BETA*BETAD1 IF(BETA.LE.BL1) THEN ST=SAC ELSE IF(BETA.LT.BL2) THEN XL=LOG(BETA) FL=(F0*XL+F1)*XL ST=F2*EXP(FL) ELSE ST=THR*EXP(SLO*LOG(BETA)) END IF SG(IJ)=ST*FIDWP END DO END IF C RETURN END C C C ******************************************************************** C C SUBROUTINE ODFFR(IL,IU) C ======================= C C Internal frequencies set for opacity distribution function C for overlapping lines near the series limit C C The lines converge to the edge of the (continuum) transition IL - IU, C IL - index of the lower level C IU - index of the upper level (usually the ground state of the next ion) C or a mean level in the line ODF formalism C C Output: FROS - set of internal frequencies C in common ODFFRQ C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (FRH=3.28805D15,CDOP=2.84511D-7,CDOM=14.) PARAMETER (SIX=6.,SEPT=7.) DIMENSION FFRO(MFRO) C CH=IZ(IEL(IL))*IZ(IEL(IL)) FRION=CH*FRH FRE=ENION(IL)/H NF=1 NQ1=NQUANT(IU) XL2=UN/(NQUANT(IL)*NQUANT(IL)) XU1=UN/((NQUANT(IU)-1)*(NQUANT(IU)-1)) XU2=UN/(NQUANT(IU)*NQUANT(IU)) FRC=FRION*(XL2-XU2) FFRO(NF)=HALF*(FRC+FRION*(XL2-XU1)) KT=ITRA(IL,IU) KL=JNDODF(KT) DOPO=CDOP*SQRT(TEFF)*FRC DOPM=CDOM*DOPO FR1=FFRO(1) C DO I=NQ1,NLMX II=I*I FR2=FRE-FRION/II DF=FR2-FR1 IF(DF.GT.DOPM) THEN DO J=1,7 NF=NF+1 FFRO(NF)=FR1+J*DOPO END DO DF=FR2-SEPT*DOPO-FFRO(NF) NI=int(DF/SIX/DOPO) DDF=DF/(NI+1) DO J=1,NI NF=NF+1 FFRO(NF)=FR1+SEPT*DOPO+J*DDF END DO DO J=7,0,-1 NF=NF+1 FFRO(NF)=FR2-J*DOPO END DO FR1=FR2 ELSE NI=int(DF/DOPO) DDF=DF/(NI+1) DO J=1,NI NF=NF+1 if(nf.gt.mfro-3) then nf=nf-1 go to 10 end if FFRO(NF)=FR1+J*DDF END DO NF=NF+1 FFRO(NF)=FR2 FR1=FR2 END IF END DO 10 CONTINUE NF=NF+1 FFRO(NF)=FRE*0.999999999 NFRODF(KL)=NF if(nf.gt.mfro) * CALL QUIT('too many points for hydrogen ODF - nf.gt.mfro', * nf,mfro) DO I=1,NF FROS(I,KL)=FFRO(NF-I+1) END DO C C Associated weights C WNUS(1,KL)=HALF*(FROS(1,KL)-FROS(2,KL)) WNUS(NF,KL)=HALF*(FROS(NF-1,KL)-FROS(NF,KL)) DO I=2,NF-1 WNUS(I,KL)=HALF*(FROS(I-1,KL)-FROS(I+1,KL)) END DO C RETURN END C C C ******************************************************************** C C SUBROUTINE CHCKSE C ================== C C Auxiliary output routine, which enables printing C total rates to check statistical equilibrium at each depth. C C Output: unit 16: and rates, and relative difference, C for each level. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (MLEVES=mlevel) DIMENSION ROUT(MLEVES,MDEPTH),RIN(MLEVES,MDEPTH) if(ioptab.lt.0) return C DO ID=1,ND T=TEMP(ID) HKT=HK/T TK=HKT/H ANE=ELEC(ID) CALL SABOLF(ID) DO IAT=1,NATOM N0I=N0A(IAT) NKI=NKA(IAT) N1I=NKI-1 DO I=N0I,NKI OUT=0. XIN=0. NKE=NNEXT(IEL(I)) DO IT=1,NTRANS II=ILOW(IT) JJ=IUP(IT) IF(II.EQ.I) THEN J=JJ IF(LINE(IT)) THEN AIJ=COLTAR(IT,ID)*WOP(I,ID)+RRD(IT,ID)* * G(I)/G(J)*WOP(I,ID)*EXP(HKT*FR0(IT)) ELSE CORR=UN NKE=NNEXT(IEL(I)) IF(NKE.NE.J) CORR=G(NKE)/G(J)* * EXP((ENION(NKE)-ENION(J))*TK) AIJ=COLTAR(IT,ID)+WOP(I,ID)+RRD(IT,ID)* * ANE*SBF(I)*CORR*WOP(I,ID) END IF AJI=(COLRAT(IT,ID)+RRU(IT,ID))*WOP(J,ID) XIN=XIN+AIJ*POPUL(J,ID) OUT=OUT+AJI ELSE IF(JJ.EQ.I) THEN J=II IF(LINE(IT)) THEN AJI=COLTAR(IT,ID)+WOP(J,ID)+RRD(IT,ID)* * G(J)/G(I)*WOP(J,ID)*EXP(HKT*FR0(IT)) ELSE CORR=UN NKE=NNEXT(IEL(J)) IF(NKE.NE.I) CORR=G(NKE)/G(I)* * EXP((ENION(NKE)-ENION(I))*TK) AJI=COLTAR(IT,ID)*WOP(J,ID)+RRD(IT,ID)* * ANE*SBF(J)*CORR*WOP(J,ID) END IF AIJ=(COLRAT(IT,ID)+RRU(IT,ID))*WOP(I,ID) XIN=XIN+AIJ*POPUL(J,ID) OUT=OUT+AJI END IF END DO RIN(I,ID)=XIN ROUT(I,ID)=OUT*POPUL(I,ID) END DO END DO END DO DO I=1,NLEVEL IF(RIN(I,ND).GT.0.) THEN WRITE(16,300) I DO ID=1,ND DEL=(RIN(I,ID)-ROUT(I,ID))/RIN(I,ID) WRITE(16,310) I,ID,RIN(I,ID),ROUT(I,ID),DEL,popul(i,id) END DO END IF END DO 300 FORMAT('1 Level:',I5///) 310 FORMAT(2I5,1P3E16.7,2x,e16.7) RETURN END C C C **************************n****************************************** C C SUBROUTINE ACCEL2 C ================= C C Acceleration of convergence (from Auer 1987, in Numerical C Radiative Transfer p. 101) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'MODELQ.FOR' C IF(NITER.LT.IACC .OR. ITER.LT.IACC0) RETURN ipng=1 if(iacd.gt.0) ipng=mod((iter-iacc),iacd) if(.not.lac2) then IPT=MOD(ITER,3) IPT0=MOD(IACC,3) IPT1=MOD((IACC+1),3) IPT2=MOD((IACC+2),3) IF(ITER.EQ.IACC0) THEN DO ID=1,ND DO IX=1,NN PSY3(IX,ID)=PSY0(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT1) THEN DO ID=1,ND DO IX=1,NN PSY2(IX,ID)=PSY0(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT2) THEN DO ID=1,ND DO IX=1,NN PSY1(IX,ID)=PSY0(IX,ID) END DO END DO END IF else if (ipng.ne.0) then DO ID=1,ND DO IX=1,NN PSY3(IX,ID)=PSY2(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NN PSY2(IX,ID)=PSY1(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NN PSY1(IX,ID)=PSY0(IX,ID) END DO END DO RETURN end if IF(ITER.LT.IACC) RETURN C A1=0. B1=0. B2=0. C1=0. C2=0. DO IX=1,NN IF(LSNG(IX)) THEN DO ID=1,ND WT=0. IF(PSY0(IX,ID).NE.0.) WT=1./ABS(PSY0(IX,ID)) D0=PSY0(IX,ID)-PSY1(IX,ID) D1=D0-PSY1(IX,ID)+PSY2(IX,ID) D2=D0-PSY2(IX,ID)+PSY3(IX,ID) A1=A1+WT*D1*D1 B1=B1+WT*D1*D2 B2=B2+WT*D2*D2 C1=C1+WT*D0*D1 C2=C2+WT*D0*D2 END DO END IF END DO AB=B2*A1-B1*B1 IF(AB.EQ.0.) THEN WRITE(6,601) ITER,AB WRITE(10,601) ITER,AB IACC=IACC+IACD IACC0=IACC-3 RETURN ENDIF A=(B2*C1-B1*C2)/AB B=(A1*C2-B1*C1)/AB C DO ID=1,ND DO IX=1,NN PSY0(IX,ID)=(1.-A-B)*PSY0(IX,ID)+A*PSY1(IX,ID)+ * B*PSY2(IX,ID) END DO END DO WRITE(6,600) ITER WRITE(10,600) ITER LAC2=.TRUE. LRES2=.FALSE. c c call RESOLV after evaluating the accelerated estimate c CALL RESOLV LRES2=.TRUE. RETURN 600 FORMAT(' **** ACCEL2, ITER=',I4) 601 FORMAT(' **** ACCEL2, ITER=',I4,' AB = ',F7.3) END C C C ******************************************************************** C C SUBROUTINE ACCELP C ================= C C Acceleration of convergence for populations C (from Auer 1987, in Numerical Radiative Transfer p. 101) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' COMMON/POPULS/POPUL1(MLEVEL,MDEPTH), * POPUL2(MLEVEL,MDEPTH),POPUL3(MLEVEL,MDEPTH) C IF(NLAMBD.LT.IACPP.OR. ILAM.LT.IACC0P) RETURN ipng=1 if(iacdp.gt.0) ipng=mod((ILAM-IACPP),IACDP) if(.not.lac2p) then IPT=MOD(ILAM,3) IPT0=MOD(IACPP,3) IPT1=MOD((IACPP+1),3) IPT2=MOD((IACPP+2),3) IF(ILAM.EQ.IACC0P) THEN DO ID=1,ND DO IX=1,NLEVEL POPUL3(IX,ID)=POPUL(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT1) THEN DO ID=1,ND DO IX=1,NLEVEL POPUL2(IX,ID)=POPUL(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT2) THEN DO ID=1,ND DO IX=1,NLEVEL POPUL1(IX,ID)=POPUL(IX,ID) END DO END DO END IF else if (ipng.ne.0) then DO ID=1,ND DO IX=1,NLEVEL POPUL3(IX,ID)=POPUL2(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NLEVEL POPUL2(IX,ID)=POPUL1(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NLEVEL POPUL1(IX,ID)=POPUL(IX,ID) END DO END DO RETURN end if IF(ILAM.LT.IACPP) RETURN C A1=0. B1=0. B2=0. C1=0. C2=0. DO ID=1,ND DO IX=1,NLEVEL IF(POPUL(IX,ID).NE.0.) WT=1./ABS(POPUL(IX,ID)) D0=POPUL(IX,ID)-POPUL1(IX,ID) D1=D0-POPUL1(IX,ID)+POPUL2(IX,ID) D2=D0-POPUL2(IX,ID)+POPUL3(IX,ID) A1=A1+WT*D1*D1 B1=B1+WT*D1*D2 B2=B2+WT*D2*D2 C1=C1+WT*D0*D1 C2=C2+WT*D0*D2 END DO END DO AB=B2*A1-B1*B1 IF(AB.EQ.0.) THEN WRITE(6,601) ILAM,AB WRITE(10,601) ILAM,AB IACPP=IACPP+IACDP IACC0P=IACPP-3 RETURN ENDIF A=(B2*C1-B1*C2)/AB B=(A1*C2-B1*C1)/AB C DO ID=1,ND DO IX=1,NLEVEL POPUL(IX,ID)=(1.-A-B)*POPUL(IX,ID)+A*POPUL1(IX,ID)+ * B*POPUL2(IX,ID) END DO END DO WRITE(6,600) ILAM WRITE(10,600) ILAM LAC2P=.TRUE. 600 FORMAT(' **** ACCELP, ITER=',I4) 601 FORMAT(' **** ACCELP, ITER=',I4,' AB = ',F7.3) RETURN END C C C ******************************************************************** C C SUBROUTINE TIMING(MOD,ITER) C =========================== C C Timing procedure (call machine dependent routine!!) C CHARACTER ROUT*20 dimension dummy(2) DATA T0/0./ SAVE T0 C TIME=etime(dummy) DT=TIME-T0 T0=TIME IF(MOD.EQ.1) THEN IP=ITER-1 ROUT=' FORMAL SOLUTION' ELSE IF(MOD.EQ.2) THEN IP=ITER ROUT=' LINEARIZATION' ENDIF WRITE(69,600) IP,MOD,TIME,DT,ROUT 600 FORMAT(2I4,2F11.2,2X,A20) RETURN END C C C ******************************************************************** C C subroutine quit(text,i1,i2) c c stops the program and writes a text c character*(*) text write(6,10) text,i1,i2 write(10,10) text,i1,i2 10 format(1x,a,2x,2i10) stop end C C C ******************************************************************** C C SUBROUTINE ODFSET C ================= C C Initialization of line ODF's C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' COMMON/STFCR/OFR(MFODF),OW(MFODF),OWSUB(MFODF), * ODFL0(MDODF,MFODF),ODF2(MDEPTH),IFTRA(MTRANS), * IDODF(MDODF),NDODF DIMENSION DML(MDEPTH) C IDSTD=ND*2/3 NLASTE=NFREQ ITR0=0 DO ID=1,ND IF(DM(ID).GT.0) THEN DML(ID)=LOG(DM(ID)) ELSE DML(ID)=ID END IF END DO C DO 500 ION=1,NION IND=INODF1(ION) IF(IND.LE.0) GO TO 500 IND2=INODF2(ION) IF(FIODF1(ION).NE.' ') OPEN(IND,FILE=FIODF1(ION),STATUS='OLD') IF(FIODF2(ION).NE.' ') OPEN(IND2,FILE=FIODF2(ION),STATUS='OLD') READ(IND,*,END=500) NDODF IF(NDODF.GT.MDODF) * CALL QUIT('too many depths for an ODF - ndodf.gt.mdodf', * ndodf,mdodf) READ(IND,*) (IDODF(ID),ID=1,NDODF) IREC=0 10 CONTINUE READ(IND,*,END=500) II,JJ,FR,NFRO,FAV IF(NFRO.GT.MFODF) * CALL QUIT('too many frequencies for an ODF - nfro.gt.mfodf', * nfro,mfodf) DO IJ=1,NFRO READ(IND,*) OFR(IJ),OW(IJ),OWSUB(IJ) END DO IND2=INODF2(ION) READ(IND2,*) ((ODFL0(ID,IF),ID=1,NDODF),IF=1,NFRO) IREC=IREC+1 C N0=NFIRST(ION)-1 I=II+N0 J=JJ+N0 IF(J.GT.NLAST(ION)) GO TO 10 IF(I.GE.NLAST(ION)) GO TO 500 ITR=ITRA(I,J) IF(ITR.EQ.ITR0) THEN ITR1=0 IF(IF1.EQ.1) THEN IFIJ=0 DO 30 IT=1,NTRANS IF(ILOW(IT).NE.I.OR.IUP(IT).NE.J) GO TO 30 IF(IT.EQ.ITR) GO TO 30 IFIJ=IFIJ+1 IFTRA(IT)=IFIJ 30 CONTINUE IF1=0 END IF DO IT=1,NTRANS IF(IFTRA(IT).GT.0) THEN ITR1=IT GO TO 50 END IF END DO 50 CONTINUE IF(ITR1.EQ.0) THEN WRITE(6,601) ITR,N0,II,JJ STOP 601 FORMAT(' CONFLICT IN ODF INPUT; ITR=',4I5) END IF ITR=ITR1 IFTRA(ITR)=0 OSC0(ITR)=FAV ELSE ITR0=ITR IF1=1 OSC0(ITR)=FAV END IF C MODE=IABS(INDEXP(ITR)) IF(MODE.EQ.3.OR.MODE.EQ.4) THEN LCOMP(ITR)=.FALSE. INTMOD(ITR)=5 END IF IFRQ0=IFR0(ITR) IFRQ1=IFR1(ITR) IF(OFR(1).GE.OFR(NFRO)) THEN IF(MODE.EQ.3) THEN IFR0(ITR)=NLASTE+1 IFR1(ITR)=NLASTE+NFRO DO IJ=1,NFRO FREQ(IJ+NLASTE)=OFR(IJ) W(IJ+NLASTE)=OW(IJ) END DO IF(NDODF.EQ.1) THEN DO ID=1,ND DO IJ=1,NFRO PRFLIN(ID,IJ+NLASTE)=real(ODFL0(1,IJ)) END DO END DO ELSE DO ID=1,ND ID1=1 DO IDO=1,NDODF-1 IF(ID.GE.IDODF(IDO).AND.ID.LE.IDODF(IDO+1)) THEN ID1=IDO ID2=IDO+1 GO TO 140 END IF END DO 140 CONTINUE IF(ID2.GT.NDODF) ID2=NDODF IF(ID1.EQ.ID2) THEN A1=1. A2=0. ELSE X=DML(IDODF(ID2))-DML(IDODF(ID1)) A1=(DML(IDODF(ID2))-DML(ID))/X A2=UN-A1 END IF DO IJ=1,NFRO IF(ODFL0(ID1,IJ).LE.0.OR. * ODFL0(ID2,IJ).LE.0) THEN PRFLIN(ID,IJ+NLASTE)=0. ELSE X=EXP(A1*LOG(ODFL0(ID1,IJ))+ * A2*LOG(ODFL0(ID2,IJ))) PRFLIN(ID,IJ+NLASTE)=real(X) END IF END DO END DO END IF C IF(IPROF(ITR).EQ.0) THEN DO ID=1,ND PRFLIN(ID,IFR1(ITR))=0. END DO END IF DO IJ=1,NFRO PROF(IJ+NLASTE)=PRFLIN(IDSTD,IJ+NLASTE) END DO NLASTE=IFR1(ITR) END IF ELSE IF(MODE.EQ.3) THEN IFR0(ITR)=NLASTE+1 IFR1(ITR)=NLASTE+NFRO DO IJ=1,NFRO FREQ(IJ+NLASTE)=OFR(NFRO-IJ+1) W(IJ+NLASTE)=OW(NFRO-IJ+1) END DO IF(NDODF.EQ.1) THEN DO ID=1,ND DO IJ=1,NFRO PRFLIN(ID,IJ+NLASTE)=real(ODFL0(1,NFRO-IJ+1)) END DO END DO ELSE DO ID=1,ND ID1=1 DO IDO=1,NDODF-1 IF(ID.GE.IDODF(IDO).AND.ID.LE.IDODF(IDO+1)) THEN ID1=IDO ID2=IDO+1 GO TO 240 END IF END DO 240 CONTINUE IF(ID2.GT.NDODF) ID2=NDODF IF(ID1.EQ.ID2) THEN A1=1. A2=0. ELSE X=DML(IDODF(ID2))-DML(IDODF(ID1)) A1=(DML(IDODF(ID2))-DML(ID))/X A2=UN-A1 END IF DO IJ=1,NFRO IJ0=NFRO-IJ+1 IF(ODFL0(ID1,IJ0).LE.0.OR.ODFL0(ID2,IJ0).LE.0) * THEN PRFLIN(ID,IJ+NLASTE)=0. ELSE X=EXP(A1*LOG(ODFL0(ID1,IJ0))+ * A2*LOG(ODFL0(ID2,IJ0))) PRFLIN(ID,IJ+NLASTE)=REAL(X) END IF END DO END DO END IF C IF(IPROF(ITR).EQ.0) THEN DO ID=1,ND PRFLIN(ID,IFR0(ITR))=0. END DO END IF DO IJ=1,NFRO PROF(IJ+NLASTE)=PRFLIN(IDSTD,IJ+NLASTE) END DO NLASTE=IFR1(ITR) END IF END IF IF(NLASTE.GT.MFREQ) * CALL QUIT(' too many frequencies in ODFSET - nlaste.gt.mfreq', * nlaste,mfreq) IF(INDEXP(ITR).NE.0) THEN CALL IJALIS(ITR,IFRQ0,IFRQ1) END IF GO TO 10 500 CONTINUE C NFREQ=NLASTE RETURN END C C C ******************************************************************** C C SUBROUTINE ODFHYS(DOPO) C ======================= C C Initialization of line ODF's for hydrogen C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (CCM=UN/2.997925D10,THIRD=UN/3.,FRH=3.28805D15) DIMENSION FFRO(MFRO) C izzh=1 IF(ISPODF.GE.1) THEN DO 200 ITR=1,NTRANS JND=JNDODF(ITR) MODE=IABS(INDEXP(ITR)) IF(JND.LE.0 .OR. MODE.NE.2) GO TO 200 LINEXP(ITR)=.FALSE. LCOMP(ITR)=.FALSE. INTMOD(ITR)=6 I=ILOW(ITR) J=IUP(ITR) NQLODF(I)=IABS(IPROF(ITR)) IF(NQLODF(I).EQ.0) NQLODF(I)=NQUANT(J) OSC0(ITR)=0. IS=NQUANT(I) DO K=NQUANT(J),NLMX CALL STARK0(IS,K,izzh,XKIJ(JND,K),WL0(JND,K), * FIJ(JND,K)) OSC0(ITR)=OSC0(ITR)+FIJ(JND,K) END DO 200 CONTINUE RETURN END IF C NLASTE=NFREQ DO 100 ITR=1,NTRANS JND=JNDODF(ITR) MODE=IABS(INDEXP(ITR)) IF(JND.LE.0 .OR. MODE.NE.2) GO TO 100 LCOMP(ITR)=.FALSE. INTMOD(ITR)=6 I=ILOW(ITR) J=IUP(ITR) NQLODF(I)=IABS(IPROF(ITR)) IF(NQLODF(I).EQ.0) NQLODF(I)=NQUANT(J) XJ2A=HALF*(XI2(NQUANT(J))+XI2(NQUANT(J)-1)) C C set up explicit frequencies & weights C NFRO=0 DO IFQ=1,4 NFRO=NFRO+KDO(IFQ,JND) END DO NFRO=NFRO-2 FRION=FRH*IZ(IEL(I))*IZ(IEL(I)) FRA=FRION*(XI2(NQUANT(I))-XJ2A) DOPI=DOPO*FRA*CCM FRB=0.99999999*FRION*XI2(NQUANT(I)) IFRQ0=IFR0(ITR) IFRQ1=IFR1(ITR) IFR0(ITR)=NLASTE+1 IFR1(ITR)=NLASTE+NFRO I1ODF(I)=IFR0(ITR) I2ODF(I)=IFR1(ITR)-1 FFRO(1)=0.99999999*FRA FFRO(2)=FRA IJ00=1 DO IK=1,3 DO IJ=2,KDO(IK,JND) IJQ=IJ00+IJ FFRO(IJQ)=FFRO(IJQ-1)+XDO(IK,JND)*DOPI END DO IJ00=IJ00+KDO(IK,JND)-1 END DO do ij=1,ij00 if(ffro(ij).lt.frb) nfrb=ij end do if(nfrb.eq.ij00) then IJ00=IJ00+1 FFRO(NFRO)=0.99999999*FRION*XI2(NQUANT(I)) do while (ffro(ij00).ge.ffro(nfro)) xdo(3,jnd)=0.75*xdo(3,jnd) ij00=ij00-kdo(3,jnd) do ij=2,kdo(3,jnd) ijq=ij00+ij ffro(ijq)=ffro(ijq-1)+xdo(3,jnd)*dopi end do ij00=ij00+kdo(3,jnd) enddo TIDO=(FFRO(NFRO)-FFRO(IJ00))/FLOAT(KDO(4,JND)-1) DO IJ=1,KDO(4,JND)-2 IJQ=NFRO-IJ FFRO(IJQ)=FFRO(NFRO)-FLOAT(IJ)*TIDO END DO else TIDO=(FRB-FFRO(nfrb))*third ffro(nfrb+1)=FFRO(nfrb)+tido ffro(nfrb+2)=frb-tido ffro(nfrb+3)=frb nfro=nfrb+3 IFR1(ITR)=NLASTE+NFRO I2ODF(I)=IFR1(ITR)-1 endif DO IJ=1,NFRO FREQ(NLASTE+IJ)=FFRO(NFRO-IJ+1) END DO W(NLASTE+NFRO)=HALF*(FREQ(NLASTE+NFRO-1)-FREQ(NLASTE+NFRO)) W(NLASTE+NFRO-1)=W(NLASTE+NFRO) DO IJ=2,NFRO-2,2 TIDO=(FREQ(NLASTE+IJ)-FREQ(NLASTE+IJ+1))*THIRD W(NLASTE+IJ-1)=W(NLASTE+IJ-1)+TIDO W(NLASTE+IJ)=W(NLASTE+IJ)+4.*TIDO W(NLASTE+IJ+1)=W(NLASTE+IJ+1)+TIDO END DO NLASTE=IFR1(ITR) C C set up internal frequencies & Stark parameters C CALL ODFFR(I,J) OSC0(ITR)=0. IS=NQUANT(I) DO K=NQUANT(J),NLMX CALL STARK0(IS,K,izzh,XKIJ(JND,K),WL0(JND,K),FIJ(JND,K)) OSC0(ITR)=OSC0(ITR)+FIJ(JND,K) END DO IF(INDEXP(ITR).NE.0) THEN CALL IJALIS(ITR,IFRQ0,IFRQ1) END IF 100 CONTINUE C NFREQ=NLASTE RETURN END C C C ******************************************************************** C C SUBROUTINE ODFMER C ================= C C Opacity distribution function for superlines to merged states C (calculated only if DT/T>=CHTL, kept constant after). C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (CHTL=1.D-3) C DO 10 ITR=1,NTRANS IF(.NOT.LINE(ITR).OR.IABS(INDEXP(ITR)).NE.2) GO TO 10 DO ID=1,ND IF(INIT.EQ.1 .OR. ABS(CHANT(ID)).GE.CHTL) * CALL ODFHYD(ID,ITR) END DO 10 CONTINUE RETURN END C C C C ******************************************************************** C C SUBROUTINE ODFHYD(ID,ITR) C ========================= C C Line ODF's for hydrogen line series C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (CDOP=TWO*BOLK/HMASS) PARAMETER (CA=2.997925D18,CCM=CA/1.D8,FRH=3.28805D15) PARAMETER (RYDEL=911.764,TTW=2./3.) PARAMETER (C00=1.25D-9,CID=0.02654) DIMENSION SIG(MFRO),SGT(MFRO),ODF(MFRO),IODF(MFRO) DIMENSION YNUS(MFRO),ALAM(MFRO) C JO=JNDODF(ITR) IF(ISPODF.EQ.0) THEN NF=NFRODF(JO) DO IJ=1,NF IODF(IJ)=0 SIG(IJ)=0. ODF(IJ)=0. YNUS(IJ)=FROS(IJ,JO) ALAM(IJ)=CAS/YNUS(IJ) END DO ELSE NF=IFR1(ITR)-IFR0(ITR)+1 DO IJ=1,NF SIG(IJ)=0. YNUS(IJ)=FREQ(IFR0(ITR)+IJ-1) ALAM(IJ)=CAS/YNUS(IJ) END DO END IF C II=ILOW(ITR) JJ=IUP(ITR) ANES=EXP(TTW*LOG(ELEC(ID))) F00=C00*ANES FRA=FRH*(XI2(NQUANT(II))-XI2(NQUANT(JJ))) DOPO=FRA/CCM*SQRT(CDOP*TEMP(ID)+VTB*VTB) DO J=NQLODF(II),NLMX WL=RYDEL/(XI2(NQUANT(II))-XI2(J)) FXK=F00*XKIJ(JO,J) DBETA=WL*WL/CA/FXK BETAD=DBETA*DOPO FID=CID*FIJ(JO,J)*DBETA CALL DIVSTR(1) WPROB=WNHINT(J,ID) CALL ODFHST(NF,FXK,FID,WPROB,WL,ALAM,SGT) DO IJ=1,NF SIG(IJ)=SIG(IJ)+SGT(IJ) END DO END DO C IF(ISPODF.EQ.0) THEN CALL INDEXX(NF,SIG,IODF) DO IJ=1,NF ODF(IJ)=SIG(IODF(IJ)) END DO I0=IFR0(ITR) I1=IFR1(ITR) IF(IABS(INDEXP(ITR)).EQ.2) YNUS(1)=FREQ(I0) IW1=IODF(1) DO IJ=2,NF IW2=IODF(IJ) IF(IJ.GT.2 .AND. IJ.LT.NF) THEN YNUS(IJ)=YNUS(IJ-1)-HALF*(WNUS(IW1,JO)+WNUS(IW2,JO)) ELSE IF (IJ.EQ.2) THEN YNUS(IJ)=YNUS(IJ-1)-HALF*(TWO*WNUS(IW1,JO)+WNUS(IW2,JO)) ELSE IF (IJ.EQ.NF) THEN YNUS(IJ)=YNUS(IJ-1)-HALF*(WNUS(IW1,JO)+TWO*WNUS(IW2,JO)) END IF IW1=IW2 END DO END IF C IF(ISPODF.EQ.0) THEN PRFLIN(ID,I1)=1.E-35 DO IJQ=I0,I1-1 DO IJ=2,NF JI=IJ IF(YNUS(IJ).LE.FREQ(IJQ)) GO TO 70 END DO 70 PRFLN=ODF(JI-1)+(ODF(JI)-ODF(JI-1))* * (FREQ(IJQ)-YNUS(JI-1))/(YNUS(JI)-YNUS(JI-1)) PRFLIN(ID,IJ0)=real(PRFLN) END DO ELSE DO IJ=1,NF PRFLIN(ID,KFR0(ITR)+IJ-1)=real(SIG(IJ)) END DO END IF RETURN END C C C ******************************************************************** C C SUBROUTINE INDEXX(N,ARRIN,INDX) C =============================== C C Sorting routine C INCLUDE 'IMPLIC.FOR' DIMENSION ARRIN(N),INDX(N) DO J=1,N INDX(J)=J END DO M=N/2+1 IR=N 10 CONTINUE IF(M.GT.1)THEN M=M-1 INDXT=INDX(M) Q=ARRIN(INDXT) ELSE INDXT=INDX(IR) Q=ARRIN(INDXT) INDX(IR)=INDX(1) IR=IR-1 IF(IR.EQ.1)THEN INDX(1)=INDXT RETURN END IF END IF I=M J=M+M 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(ARRIN(INDX(J)).LT.ARRIN(INDX(J+1)))J=J+1 END IF IF(Q.LT.ARRIN(INDX(J))) THEN INDX(I)=INDX(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 END IF INDX(I)=INDXT GO TO 10 END C C C ******************************************************************** C C SUBROUTINE SIGAVE C ================= C C Read bound-free cross-sections for averaged levels C from the unit INSA (given by IFANCY), with increasing frequencies C It assumes that all continuum transitions for a given ion are C given in a successive order in the data C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (HCCM=H*2.997925D10) PARAMETER (TX=2.30258509299405,BAM=1.e-18) DIMENSION XIFE(8) DIMENSION FRINSG(MFREQ),CRIN(MFREQ),JKF(MFREQ) C DATA XIFE/63480.,130563.,247220.,442000.,605000.,799000., * 1008000.,1218380./ C NFREQB=NFREQ IF(IBFINT.GT.0) NFREQB=NFREQC ITR=0 10 ITR=ITR+1 IF(ITR.GT.NTRANS) RETURN IC=ITRA(IUP(ITR),ILOW(ITR)) INSA=IBF(IC) IF(INSA.LT.50 .OR. INSA.GT.100) GO TO 10 IE=IEL(ILOW(ITR)) ITR=ITR-1 NL1=NFIRST(IE) NL2=NLAST(IE) IF(FIBFCS(IE).NE.' ') THEN INSA=INBFCS(IE) OPEN(INSA,FILE=FIBFCS(IE),STATUS='OLD') END IF READ(INSA,*,END=500,ERR=500) IERR,IZRR,NLRR DO 100 I=NL1,NL2 ITR=ITR+1 IF(INDEXP(ITR).EQ.0) GO TO 100 IC=ITRA(IUP(ITR),ILOW(ITR)) READ(INSA,*) INL,ECMR,GDUM,NFIS IF(IERR.NE.26) GO TO 20 ECMR=XIFE(IZRR)-ECMR DE=ABS((ENION(ILOW(ITR))-HCCM*ECMR)/ENION(ILOW(ITR))) IF(DE.GT.2.D-2) THEN PRINT *,INSA,IE,ITR,I END IF 20 DO IJ=1,NFIS JI=NFIS-IJ+1 READ(INSA,*,END=500,ERR=500) FRINSG(JI),CRIN(JI) END DO DO IJ=1,NFREQB JK=0 FR=FREQ(IJ) IF(ISPODF.GE.1) FR=FREQ(IFREQB(IJ)) DO IK=1,NFIS IF(FR.GT.FRINSG(IK)) THEN JK=IK GO TO 40 END IF END DO JK=NFIS 40 IF(JK.EQ.1) JK=2 JKF(IJ)=JK END DO DO IJ=1,NFREQB JK=JKF(IJ) FR=FREQ(IJ) IF(ISPODF.GE.1) FR=FREQ(IFREQB(IJ)) IF(CRIN(JK-1).EQ.0. .OR. CRIN(JK).EQ.0.) THEN BFCS (IC,IJ)=real(CRIN(JK)+(FR-FRINSG(JK))/ * (FRINSG(JK-1)-FRINSG(JK))*(CRIN(JK-1)-CRIN(JK))) ELSE XF1=LOG10(FRINSG(JK-1)) XF2=LOG10(FRINSG(JK)) YS1=LOG10(CRIN(JK-1)) YS2=LOG10(CRIN(JK)) XXF=LOG10(FR) YYF=(XXF-XF2)/(XF1-XF2)*(YS1-YS2)+YS2 EXTX=EXP(TX*YYF) BFCS(IC,IJ)=real(EXTX) END IF BFCS(IC,IJ)=real(BAM*BFCS(IC,IJ)) END DO 100 CONTINUE GO TO 10 500 CALL QUIT *('error in data for bf-cs of averaged levels - itr,ie:', * itr,ie) RETURN END C C C ********************************************************************* C c subroutine readbf(ius) c ====================== c c auxiliary subroutine for enabling reading of input data with c comments c c lines beginning with ! or * are understood as comments c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' character*80 buff c iur=ius if(iur.eq.0) iur=5 iuw=ibuff if(iur.ne.5) iuw=95 c 10 continue read(iur,501,end=20) buff c PRINT *, 'READ LINE:', TRIM(BUFF) if(buff(1:1).eq.'!'.or.buff(1:1).eq.'*') go to 10 write(iuw,501) buff go to 10 c 20 continue rewind iuw return 501 format(a) end C C C ******************************************************************* C C SUBROUTINE CORRWM C ================= C C The routine for management of various flags for treating C frequency points; in particular those connected to the so-called C "subtraction weights" (in the non-overlapping mode only) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (T15=1.D-15) C NFREQE=0 DO 10 IJ=1,NFREQ IJEX(IJ)=0 DO ID=1,ND LSKIP(ID,IJ)=.FALSE. END DO if(ifprad.eq.0) then do id=1,nd lskip(id,ij)=.true. end do end if IF(IJALI(IJ).NE.0) GO TO 10 NFREQE=NFREQE+1 IJEX(IJ)=NFREQE IJFR(NFREQE)=IJ 10 CONTINUE c if(ifryb.ne.0) then nfreqe=0 do ij=1,nfreq ijex(ij)=0 end do end if C IF(IBFINT.LE.0) THEN DO IJ=1,NFREQ IJBF(IJ)=IJ AIJBF(IJ)=UN END DO ELSE IF(ISPODF.EQ.0) THEN DO IJ=1,NFREQC IJBF(IJ)=IJ AIJBF(IJ)=UN END DO IF(NFREQ.GT.NFREQC) THEN DO IJ=NFREQC+1,NFREQ FR=FREQ(IJ) IJ0=1 DO IJT=1,NFREQC IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 12 END IF END DO 12 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) IJBF(IJ)=IJ1 AIJBF(IJ)=A1 END DO END IF ELSE DO IJ=1,NFREQC-1 IJ0=IFREQB(IJ) IJ1=IFREQB(IJ+1) DO KJ=IJ0,IJ1-1 IJBF(KJ)=IJ AIJBF(KJ)=(FREQ(KJ)-FREQ(IJ1))/(FREQ(IJ0)-FREQ(IJ1)) END DO END DO IJ0=IFREQB(NFREQC) IJBF(IJ0)=NFREQC AIJBF(IJ0)=UN END IF END IF C if(nfreqe.gt.mfrex) CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex) C DO 100 ITR=1,NTRANS IF(.NOT.LINE(ITR)) GO TO 100 C C first set up array LSKIP(ID,IJ), which has values C TRUE - if the radiation at frequency point IJ does not contribute C radiation pressure (ie. this point belongs to a transition C for which the user required the radiation pressure to be C skipped - IABS(INDEXP) chosen as 9 or 19) C FALSE - normal calculatitn of radiation pressure C INX=IABS(INDEXP(ITR)) IF(INX.EQ.9.OR.INX.GE.19) THEN DO IJ=IFR0(ITR),IFR1(ITR) DO ID=1,ND LSKIP(ID,IJ)=.TRUE. END DO END DO END IF 100 CONTINUE C IF(NFREQE.GT.0) WRITE(6,609) DO 110 IJ=1,NFREQ FR15=FREQ(IJ)*T15 W0E(IJ)=W(IJ)*PI4H/FREQ(IJ) BNUE(IJ)=BN*FR15*FR15*FR15 IF(IJALI(IJ).NE.0.or.ifryb.gt.0) GO TO 110 if(ispodf.eq.0) then WRITE(6,610) IJ,FREQ(IJ),W(IJ),PROF(IJ) else WRITE(6,610) IJ,FREQ(IJ),W(IJ) end if 110 CONTINUE C DO IJ=1,NFREQ WC(IJ)=W(IJ) IF(IJALI(IJ).LE.0) WC(IJ)=0. END DO C 609 FORMAT(1H0//' FREQUENCY POINTS AND WEIGHTS - EXPLICIT'/ * ' ---------------------------------------'// * ' IJ',7X,'FREQ',13X,'WEIGHT',11X,'PROF'/) 610 FORMAT(1H ,I8,1P2D17.8,D15.5,D17.8) RETURN END C C C ******************************************************************* C C SUBROUTINE IJALIS(ITR,IFRQ0,IFRQ1) C ================================== C C auxiliary routine - sets up the necessary flags for ALI treatment C of individual transitions (in the fully hybrid CL/ALI scheme) C C Output: C C IJALI(IJ) = 0 - frequency point IJ is an explicit point C = 1 - frequency point IJ is an ALI point C C LEXP(ITR) = T - at least one point within transition ITR is explicit C LEXP(ITR) = F - no point within transition ITR is explicit C LALI(ITR) = T - at least one point within transition ITR is ALI C LALI(ITR) = F - no point within transition ITR is ALI C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C c NFRECL=NFREQ c if(nfrecl.ge.nfreq) return INDXP=INDEXP(ITR) I0=IFR0(ITR) I1=IFR1(ITR) NF=I1-I0+1 DO IJ=I0,I1 IF(INDXP.GT.0) THEN IJALI(IJ)=0 ELSE IF(INDXP.LT.0) THEN IJALI(IJ)=1 END IF END DO C C primarily explicit transitions C IF(INDXP.GT.0) THEN LEXP(ITR)=.TRUE. LALI(ITR)=.FALSE. IF(IFRQ0.GT.0.and.iadop(iatm(ilow(itr))).eq.0) THEN LALI(ITR)=.TRUE. IF(IFRQ1.EQ.0.OR.IFRQ1.GT.NF) IFRQ1=NF DO I=IFRQ0,IFRQ1 IJALI(I0+I-1)=1 END DO ELSE IF(IFRQ0.LT.0) THEN LALI(ITR)=.TRUE. READ(57,*) (IJALI(IJ),IJ=I0,I1) END IF IF(IFRQ0.EQ.1.AND.IFRQ1.EQ.NF) LEXP(ITR)=.FALSE. ELSE IF(INDXP.LT.0) THEN C C primarily ALI transitions C LALI(ITR)=.TRUE. LEXP(ITR)=.FALSE. IF(IFRQ0.GT.0.and.iadop(iatm(ilow(itr))).eq.0) THEN LEXP(ITR)=.TRUE. IF(IFRQ1.EQ.0.OR.IFRQ1.GT.NF) IFRQ1=NF DO I=IFRQ0,IFRQ1 IJALI(I0+I-1)=0 END DO ELSE IF(IFRQ0.LT.0) THEN LEXP(ITR)=.TRUE. READ(57,*) (IJALI(IJ),IJ=I0,I1) END IF IF(IFRQ0.EQ.1.AND.IFRQ1.EQ.NF) LALI(ITR)=.FALSE. END IF IF(NFFIX.GT.0) THEN DO IJ=I0,I1 IJALI(IJ)=1 END DO LALI(ITR)=.TRUE. LEXP(ITR)=.FALSE. END IF RETURN END C C C ******************************************************************* C C SUBROUTINE IJALI2 C ================= C C auxiliary routine - sets up the necessary flags for ALI treatment C of individual transitions (in the fully hybrid CL/ALI scheme) C C Version for opacity sampling mode C C Output: C C IJALI(IJ) = 0 - frequency point IJ is an explicit point C = 1 - frequency point IJ is an ALI point C C LEXP(ITR) = T - at least one point within transition ITR is explicit C LEXP(ITR) = F - no point within transition ITR is explicit C LALI(ITR) = T - at least one point within transition ITR is ALI C LALI(ITR) = F - no point within transition ITR is ALI C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' C DO IJ=1,NFREQ IJALI(IJ)=1 IJX(IJ)=1 NLINES(IJ)=0 END DO NLITOT=0 NLIMAX=0 C C Overlapping lines at frequency IJ C DO 10 IT=1,NTRANS IF(LINEXP(IT)) GO TO 10 DO IJ=IFR0(IT),IFR1(IT) NLINES(IJ)=NLINES(IJ)+1 ITRLIN(NLINES(IJ),IJ)=int2(IT) END DO 10 CONTINUE DO IJ=1,NFREQ NLITOT=NLITOT+NLINES(IJ) IF(NLINES(IJ).GT.MITJ) * CALL QUIT('Too many overlappins-nlines(ij).gt.mitj', * nlines(ij),mitj) IF(NLINES(IJ).GT.NLIMAX) NLIMAX=NLINES(IJ) END DO WRITE(10,*) ' Max. number of line overlaps: ',NLIMAX WRITE(10,*) ' Total number of line overlaps: ',NLITOT C C Switches for ALI and explicit transitions C IF(NFFIX.EQ.2) THEN DO ITR=1,NTRANS LEXP(ITR)=.FALSE. LALI(ITR)=.TRUE. END DO RETURN END IF C XFRMA=DLOG10(FRS1) DO 100 ITR=1,NTRANS INDXP=INDEXP(ITR) I0=IFR0(ITR) I1=IFR1(ITR) NF=I1-I0+1 IF(FR0(ITR).GT.FRS1) GO TO 100 IJL=IJTC(ITR) C C primarily explicit line transitions C IF(LINE(ITR)) THEN IF(INDXP.GT.0) THEN LEXP(ITR)=.TRUE. LALI(ITR)=.FALSE. IF(IFC0(ITR).EQ.0) THEN DO IJ=I0,I1 IJALI(IJ)=0 END DO ELSE LALI(ITR)=.TRUE. NFC=IABS(IFC1(ITR)-IFC0(ITR)+1) IF(NFC.EQ.NF) THEN LEXP(ITR)=.FALSE. ELSE NFC=NFC/2 DO IJ=I0,IJL-NFC IJALI(IJ)=0 END DO DO IJ=IJL+NFC,I1 IJALI(IJ)=0 END DO END IF END IF ELSE IF(INDXP.LT.0) THEN C C primarily ALI line transitions C LEXP(ITR)=.FALSE. LALI(ITR)=.TRUE. IF(IFC0(ITR).NE.0) THEN LEXP(ITR)=.TRUE. NFC=IABS(IFC1(ITR)-IFC0(ITR)+1) IF(NFC.EQ.NF) THEN LALI(ITR)=.FALSE. DO IJ=I0,I1 IJALI(IJ)=0 END DO ELSE NFC=NFC/2 DO IJ=IJL-NFC,IJL+NFC IJALI(IJ)=0 END DO END IF END IF END IF C C continuum transitions C ELSE IF(IFC0(ITR).GT.0) THEN DO IJ=1,IFC1(ITR)-IFC0(ITR)+1 IJALI(IJL-IJ+1)=0 END DO END IF END IF 100 CONTINUE C RETURN END C C C ******************************************************************* C C SUBROUTINE LEVSET C ================= C C sets up level parameters IIEXP and IIFOR which control the C treatment of levels C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' if(ioptab.lt.0) return C C 1. case - treatment of levels determined by IMODL C IF(IFLEV.EQ.0) THEN DO I=1,NLEVEL IIEXP(I)=0 IIFOR(I)=0 END DO IIE=0 IIF=0 DO 20 IAT=1,NATOM IGRP=0 IF(IIFIX(IAT).EQ.1) GO TO 20 DO I=N0A(IAT),NKA(IAT) INEW=1 IF(IMODL(I).EQ.0) THEN IIE=IIE+1 IIF=IIF+1 IIEXP(I)=IIE IIFOR(I)=IIF INDLEV(IIEXP(I))=I ELSE IF(IMODL(I).GT.0) THEN IIF=IIF+1 IIFOR(I)=IIF IF(ILTLEV(I).GE.1) THEN IIE=IIE+1 IIEXP(I)=IIE END IF IF(I.EQ.NFIRST(IEL(I)).OR.I.EQ.NNEXT(IEL(I))) THEN IIE=IIE+1 IIEXP(I)=IIE END IF ELSE IF(IMODL(I).LT.-100) THEN IF(I.GT.1) THEN IF(IMODL(I).EQ.IMODL(I-1)) INEW=0 END IF IIEXP(I)=-IIE IF(INEW.EQ.1) THEN IIE=IIE+1 IIEXP(I)=-IIE IM=NFIRST(IEL(I)) LML=.TRUE. DO WHILE (IM.LT.I-1 .AND. LML) IF(IMODL(I).EQ.IMODL(IM)) THEN IIEXP(I)=IIEXP(IM) IIE=IIE-1 LML=.FALSE. END IF IM=IM+1 END DO END IF IGRP=1 IIF=IIF+1 IIFOR(I)=IIF ELSE IF(IMODL(I).LT.-200) THEN IF(I.GT.1) THEN IF(IMODL(I).EQ.IMODL(I-1)) INEW=0 END IF IF(INEW.EQ.1) IIE=IIE+1 IF(INEW.EQ.1) IIF=IIF+1 IIEXP(I)=-IIE IIFOR(I)=-IIF IGRP=1 END IF END DO IF(IGRP.EQ.1) THEN DO I=N0A(IAT),NKA(IAT) IF(IIEXP(I).GT.0) IIEXP(I)=-IIEXP(I) IF(IMODL(I).EQ.0) IMODL(I)=7 END DO END IF 20 CONTINUE NLVEXP=IABS(IIE) if(nlvexp.gt.mlvexp) * CALL QUIT('nlvexp.gt.mlvexp',nlvexp,mlvexp) NLVFOR=IABS(IIF) DO 30 I=1,NLEVEL IF(IMODL(I).EQ.1.OR.IMODL(I).EQ.3) THEN IIEXP(I)=0 ELSE IF(IMODL(I).EQ.4.OR.IMODL(I).EQ.5) THEN IIEXP(I)=0 ELSE IF(IMODL(I).EQ.-1.OR.IMODL(I).EQ.-3) THEN IIEXP(I)=0 IIFOR(I)=0 ELSE IF(IMODL(I).EQ.6) THEN IIEXP(I)=0 ELSE IF(IMODL(I).EQ.-5.OR.IMODL(I).EQ.-6) THEN IIEXP(I)=0 IIFOR(I)=0 ELSE IF(IMODL(I).LT.-100) THEN IMODL(I)=7 ELSE IF(IMODL(I).LT.-200) THEN IMODL(I)=-7 END IF DO ID=1,ND ILTREF(I,ID)=NNEXT(IEL(I)) END DO 30 CONTINUE IF(IGRP.EQ.1) THEN DO I=N0A(IAT),NKA(IAT) IMODL(I)=7 END DO END IF C C 2. case - treatment of levels automatic - all levels with ILK=0 C in updated LTE mode C ELSE IIF=0 DO 110 I=1,NLEVEL IF(IIFIX(IATM(I)).EQ.1) GO TO 110 IMODL(I)=5 IF(I.EQ.NFIRST(IEL(I)).OR.I.EQ.NNEXT(IEL(I))) THEN IIF=IIF+1 IIFOR(I)=IIF END IF 110 CONTINUE NLVEXP=IIF if(nlvexp.gt.mlvexp) * CALL QUIT('nlvexp.gt.mlvexp',nlvexp,mlvexp) NLVFOR=IIF DO I=1,NLEVEL IF(I.NE.NFIRST(IEL(I)).AND.I.NE.NNEXT(IEL(I))) * IIFOR(I)=0 END DO DO I=1,NLEVEL IIEXP(I)=IIFOR(I) IF(IIEXP(I).GT.0) INDLEV(IIEXP(I))=I DO ID=1,ND ILTREF(I,ID)=NNEXT(IEL(I)) END DO END DO if(.not.lte) then do i=1,nlevel iifor(i)=i end do nlvfor=nlevel end if c END IF C C initialize b-factors C DO I=1,NLEVEL DO ID=1,ND BFAC(I,ID)=UN END DO END DO C do ii=1,nlvexp indlev(ii)=0 do id=1,nd igzero(ii,id)=0 end do end do do i=1,nlevel do id=1,nd ipzero(i,id)=0 end do if(iabs(imodl(i)).le.6) then IF(IIEXP(I).GT.0) INDLEV(IIEXP(I))=I end if end do C RETURN END C C C ******************************************************************* C C SUBROUTINE DWNFR0(ID) C ===================== C C Auxiliary quantities for dissolved fractions C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (SIXTH=UN/6.,CCOR=0.09) parameter (p1=0.1402,p2=0.1285,p3=un,p4=3.15,p5=4.) parameter (f23=-2./3.) C ANE=ELEC(ID) ELEC23(ID)=EXP(F23*LOG(ANE)) ANES=EXP(SIXTH*LOG(ANE)) ACOR(ID)=CCOR*ANES/SQT1(ID) X=EXP(P4*LOG(UN+P3*ACOR(ID))) DWC2(ID)=P2*X A3=ACOR(ID)*ACOR(ID)*ACOR(ID) DO IZZ=1,MZZ Z3(IZZ)=IZZ*IZZ*IZZ DWC1(IZZ,ID)=P1*(X+P5*(IZZ-UN)*A3) END DO RETURN END C C C ******************************************************************** C C SUBROUTINE DWNFR1(FR,FR0,ID,IZZ,DW1) C ==================================== C C dissolved fraction for frequency FR C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (TKN=3.01,CKN=5.33333333,CB0=8.59d14) PARAMETER (SQFRH=5.734152D7) C cb=cb0*bergfc c IF(FR.LT.FR0) THEN XN=SQFRH*IZZ/SQRT(FR0-FR) if(xn.le.tkn) then xkn=un else xn1=un/(xn+un) xkn=ckn*xn*xn1*xn1 end if BETA=CB*Z3(IZZ)*XKN/(XN*XN*XN*XN)*ELEC23(ID) BETA3=BETA*BETA*BETA BETA32=SQRT(BETA3) F=(DWC1(IZZ,ID)*BETA3)/(UN+DWC2(ID)*BETA32) DW1=UN-F/(UN+F) ELSE DW1=UN END IF RETURN END C C C **************************************************************** C C SUBROUTINE SGMER0 C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (FRH=3.28805E15, PH2=2.815D29*2., EHB=157802.77355) DIMENSION FREDG(NLMX),S(NLMX),SUM(NLMX),SUD(NLMX) C IMER=0 DO 100 II=1,NLEVEL IF(IFWOP(II).GE.0) GO TO 100 IMER=IMER+1 IMRG(II)=IMER IIMER(IMER)=II IE=IEL(II) CH=IZ(IE)*IZ(IE) FRCH(IMER)=FRH*CH SGM0(IMER)=PH2*CH*CH II0=NQUANT(II-1)+1 DO ID=1,ND EX=EHB*CH*TEMP1(ID) DO I=II0,NLMX FREDG(I)=FRCH(IMER)*XI2(I) EXI=EXP(EX*XI2(I)) S(I)=EXI*WNHINT(I,ID)*XI3(I) SUM(I)=0. END DO SUM(NLMX)=S(NLMX) SUD(NLMX)=S(NLMX)*XI2(NLMX) DO I=NLMX-1,II0,-1 SUM(I)=SUM(I+1)+S(I) END DO DO I=1,II0-1 SUM(I)=SUM(II0) END DO SGEM=SGM0(IMER)/GMER(IMER,ID) DO I=1,NLMX SGMSUM(I,IMER,ID)=SUM(I)*SGEM END DO END DO 100 CONTINUE RETURN END C C C **************************************************************** C C SUBROUTINE SGMER1(FRINV,FR3INV,IMER,ID,SGME1) C ============================================= C C photoionization cross-section for a merged level C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C ISU=INT(SQRT(FRCH(IMER)*FRINV))+1 SGME1=SGMSUM(ISU,IMER,ID)*FR3INV RETURN END C C C **************************************************************** C C SUBROUTINE SGMERD(FRINV,FR3INV,IMER,ID,SGME1,DSGME1) C ==================================================== C C photoionization cross-section for a merged level C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C ISU=INT(SQRT(FRCH(IMER)*FRINV))+1 SGME1=SGMSUM(ISU,IMER,ID)*FR3INV DSGME1=-SGMSUD(ISU,IMER,ID)*FR3INV RETURN END C C C **************************************************************** C C SUBROUTINE TDPINI C ================= C C initialization of only temperature dependent quantities C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (CFF1=1.3727D-25,CFF2=4.3748D-10,CFF3=2.5993D-7) PARAMETER (SGFF0 = 3.694D8) C C temperature-dependent quantities C DO ID=1,ND T=TEMP(ID) T1=UN/T HKT1(ID)=HK*T1 HKT21(ID)=HKT1(ID)*T1 TK1(ID)=HKT1(ID)/H SQT1(ID)=SQRT(T) TEMP1(ID)=T1 CALL GFREE0(ID) EMEL1(ID)=UN END DO C C delta m (for evaluation of optical depths) C DO ID=1,ND-1 DELDM(ID)=HALF*(DM(ID+1)-DM(ID)) deldmz(id)=deldm(id) if(izscal.eq.1) deldmz(id)=half*(zd(id)-zd(id+1)) END DO DEDM1=DM(1)/DENS(1) RETURN END C C C **************************************************************** C C C SUBROUTINE OPAINI(IMOD) C ======================= C C initialization of only depth-dependent quantities C for evaluation of opacities C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION PRF(MFREQL),POPP(MLEVEL) PARAMETER (CFF1=1.3727D-25,CFF2=4.3748D-10,CFF3=2.5993D-7) PARAMETER (SIXTH=UN/6.,CCOR=0.09,T32=1.5D0) PARAMETER (SGFF0 = 3.694D8) DATA ICOMP /0/ C DO ID=1,ND WMT=WMM(ID)*YTOT(ID) T=TEMP(ID) ANE=ELEC(ID) ELEC1(ID)=UN/ANE DENS1(ID)=UN/DENS(ID) DENSI(ID)=DENS1(ID) DENSIM(ID)=DENSI(ID)*WMM(ID) ELSCAT(ID)=ANE*SIGE CALL DWNFR0(ID) CALL WNSTOR(ID) CALL SABOLF(ID) CALL REFLEV(ID,IMOD) CALL LEVGRP(ID,IIEXP,0,POPP) DO II=1,NLEVEL POPINV(II,ID)=0. IF(POPUL(II,ID).NE.0.) POPINV(II,ID)=UN/POPUL(II,ID) END DO DO II=1,NLEVEL IIE=IIEXP(II) IF(IIE.EQ.0) THEN IE=ILTREF(II,ID) PP(II,ID)=POPUL(II,ID)*POPINV(IE,ID) IF(IABS(IMODL(II)).LE.5) THEN PT(II,ID)=POPUL(II,ID)*DSBPST(II,ID) PN(II,ID)=POPUL(II,ID)*DSBPSN(II,ID) END IF ELSE IF(IIE.LT.0) THEN PP(II,ID)=SBPSI(II,ID) END IF END DO DO ION=1,NION USUMS(ION,ID)=USUM(ION) DUSMT(ION,ID)=DUSUMT(ION) DUSMN(ION,ID)=DUSUMN(ION) ENDDO c c quantities for the bound-free opacity c DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) JJ=IUP(ITR) IT=ITRA(JJ,II) IE=IEL(II) NKE=NNEXT(IE) CORR=UN IF(NKE.NE.JJ) CORR=G(NKE)/G(JJ)* * EXP((ENION(NKE)-ENION(JJ))*TK1(ID)) ABTRA(ITR,ID)=POPUL(II,ID) EMTRA(ITR,ID)=POPUL(JJ,ID)*ANE*SBF(II)*WOP(II,ID)*CORR DEMLT(ITR,ID)=-(T32+FR0(ITR)*HKT1(ID))/TEMP(ID) END DO c c quantities for the free-free opacity c IF(IELHM.GT.0) THEN CFFN(ID)=POPUL(NFIRST(IELH),ID)*ANE CFFT(ID)=CFF2-CFF3/T END IF SGFF=SGFF0/SQT1(ID)*ANE DO ION=1,NION SFF2(ION,ID)=EXP(FF(ION)*HKT1(ID)) SFF3(ION,ID)=POPUL(NNEXT(ION),ID)*CHARG2(ION)*SGFF DSFF(ION,ID)=(FF(ION)*HKT1(ID)+HALF)*TEMP1(ID) END DO END DO if(izscal.eq.1) then do id=1,nd densi(id)=un densim(id)=0. end do end if CALL SGMER0 C C initialization of the line opacity C LASER=ITER.GT.ITLAS DO 200 ITR=1,NTRANS INDXA=IABS(INDEXP(ITR)) IF(.NOT.LINE(ITR)) GO TO 200 II=ILOW(ITR) JJ=IUP(ITR) IF(INDXA.NE.0.AND.INTMOD(ITR).NE.0 .AND. ICOMP.EQ.0) THEN IJL0=IFR0(ITR) IJL1=IFR1(ITR) IF(ISPODF.GE.1) THEN IJL0=KFR0(ITR) IJL1=KFR1(ITR) END IF IF(INDXA.LT.2.OR.INDXA.GT.4) THEN DO ID=1,ND CALL LINPRO(ITR,ID,PRF) DO IJ=IJL0,IJL1 PRFLIN(ID,IJ)=real(PRF(IJ-IJL0+1)) END DO END DO END IF END IF GG=G(II)/G(JJ) DO ID=1,ND IF(IFWOP(JJ).GE.0) THEN PI=POPUL(II,ID)*WOP(JJ,ID) PJ=GG*POPUL(JJ,ID)*WOP(II,ID) ELSE PI=POPUL(II,ID) PJ=G(II)/GMER(IMRG(JJ),ID)*POPUL(JJ,ID)*WOP(II,ID) END IF ABTRA(ITR,ID)=PI EMTRA(ITR,ID)=PJ*EXP(FR0(ITR)*HKT1(ID)) DEMLT(ITR,ID)=-FR0(ITR)*HKT21(ID) IF(LASER) THEN qtt=0. if(pi.ne.pj) QTT=PJ/(PI-PJ)*(EXP(FR0(ITR)*HKT1(ID))-UN) lfr=fr0(itr).lt.frtabm.and.iadop(iatm(ii)).gt.0 IF(QTT.LT.0. .OR. QTT.GT.QTLAS .or. lfr) THEN ABTRA(ITR,ID)=0. EMTRA(ITR,ID)=0. DEMLT(ITR,ID)=0. END IF END IF c c set up ABTRA and EMTRA to 0 in the range where c the hydrogen opacity is calculated from Gomez tables c if(ihgom.gt.0.and.elec(id).gt.hglim) then if(ii.ge.n0hn.and.ii.le.n0hn-1+ihgom) then abtra(itr,id)=0. emtra(itr,id)=0. demlt(itr,id)=0. end if end if END DO 200 CONTINUE ICOMP=1 RETURN END C C C **************************************************************** C C SUBROUTINE TRAINI C ================= C C initialization of depth-independent quantities C for evaluation of opacities C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' c do itr=1,ntrans idiel(itr)=0 end do C C bound-free transitions C NCDW=0 DO 10 IBFT=1,NTRANC ITR=ITRBF(IBFT) ii=ilow(itr) if(ilk(iup(itr)).ne.0.and.nfirst(iel(ii)).eq.ii. * and.IFDIEL.NE.0) idiel(itr)=1 MODW=IABS(INDEXP(ITR)) IF(MODW.NE.5.AND.MODW.NE.15) GO TO 10 NCDW=NCDW+1 MCDW(ITR)=NCDW ITRCDW(NCDW)=ITR 10 CONTINUE IF(ISPODF.GE.1) RETURN C C bound-bound transitions C DO IJ=1,NFREQ NLINES(IJ)=0 END DO C DO 100 ITR=1,NTRANS IF(LINEXP(ITR)) GO TO 100 DO IJ=IFR0(ITR),IFR1(ITR) IJLIN(IJ)=ITR END DO 100 CONTINUE RETURN END C C C **************************************************************** C C SUBROUTINE RTEDF1(IJ) C ===================== C C Solution of the radiative transfer equation - for one frequency C for the known source function. C Determination of the radiation field and variable Eddington C factors. C C The numerical method used: c Discontinuous Finite Element method c Castor, Dykema, Klein, 1992, ApJ 387, 561. C C different formulation of the boundary conditions C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' COMMON/OPTDPT/DT(MDEPTH) PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0) DIMENSION RDK(MDEPTH),FKK(MDEPTH), * ST0(MDEPTH),SA0(MDEPTH),SS0(MDEPTH), * dtau(mdepth),rip(mdepth),rim(mdepth), * riin(mdepth),riup(mdepth),u(mdepth), * aip(mdepth),aim(mdepth),al0(mdepth), * aiin(mdepth),aiup(mdepth), * ali0(mdepth),ss0c(mdepth), * AAA(MDEPTH),BBB(MDEPTH),CCC(MDEPTH),EEE(MDEPTH), * ZZZ(MDEPTH),ALRH(MDEPTH),ALRM(MDEPTH),ALRP(MDEPTH), * DDD(MDEPTH),AANU(MDEPTH) C FR=FREQ(IJ) C C optical depth scale C DO ID=1,ND-1 DT(ID)=DELDMZ(ID)*(ABSOT(ID+1)+ABSOT(ID)) SA0(ID)=EMIS1(ID)/ABSO1(ID) SS0(ID)=-SCAT1(ID)/ABSO1(ID) END DO SA0(ND)=EMIS1(ND)/ABSO1(ND) SS0(ND)=-SCAT1(ND)/ABSO1(ND) C TAUMIN=ABSO1(1)*DEDM1 C C Allowance for wind blanketing C ALB1=0. IF(IWINBL.GT.0) ALB1=TWO*ALBE(IJ)/(UN+ALBE(IJ)) C C quantities for the lower boundary condition C FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 PLAND=BNU/(EXP(HK*FR/TEMP(ND))-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMP(ND-1))-UN)*RRDIL IF(TEMPBD.GT.0.) THEN PLAND=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL ENDIF DPLAN=(PLAND-DPLAN)/DT(ND-1) C C global ALI loop for treating electron scattering C itrali=0 10 itrali=itrali+1 C C total source function C DO ID=1,ND ST0(ID)=SA0(ID)-SS0(ID)*RAD(IJ,ID) RAD1(ID)=0. RDK(ID)=0. ALI1(ID)=0. END DO AH=0. ahout=0. ahd=0. U0=0. QQ0=0. US0=0. c c loop over angle poits c DO I=1,NMU AMU2=AMU(I)*AMU(I)*WTMU(I) do id=1,nd-1 dtau(id)=dt(id)/amu(i) enddo c c incoming intensity c ID=1 P0=0. EX=UN C C allowance for non-zero optical depth at the first depth point C c rim(id)=EXTRAD(IJ) rim(id)=EXTINT(IJ,I) c IF(IWINBL.EQ.0) THEN c TAMM=TAUMIN/AMU(I) c EX=EXP(-TAMM) c P0=UN-EX c QQ0=QQ0+P0*AMU(I)*WTMU(I) c U0=U0+EX*WTMU(I) c US0=US0+P0/TAMM*WTMU(I) c rim(id)=st0(id)*p0 c END IF c c incoming intensity c aim(id)=0. do id=1,nd-1 dt0=dtau(id) dtaup1=dt0+un dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=un/(dtau2+bb) rim(id+1)=(two*rim(id)+dt0*st0(id)+cc*st0(id+1))*aa rip(id)=(bb*rim(id)+cc*st0(id)-dt0*st0(id+1))*aa aim(id+1)=cc*aa aip(id)=(cc+bb*aim(id))*aa end do do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) riin(id)=(rim(id)*dtau(id)+rip(id)*dtau(id-1))*dtt aiin(id)=(aim(id)*dtau(id)+aip(id)*dtau(id-1))*dtt end do riin(1)=rim(1) riin(nd)=rim(nd) aiin(1)=aim(1) aiin(nd)=aim(nd) C c outgoing intensity c if(idisk.eq.0) rim(nd)=PLAND+AMU(I)*DPLAN do id=nd-1,1,-1 dt0=dtau(id) dtaup1=dt0+un dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=un/(dtau2+bb) rim(id)=(two*rim(id+1)+dt0*st0(id+1)+cc*st0(id))*aa rip(id+1)=(bb*rim(id+1)+cc*st0(id+1)-dt0*st0(id))*aa aim(id)=cc*aa aip(id+1)=(cc+bb*aim(id+1))*aa end do do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) riup(id)=(rim(id)*dtau(id-1)+rip(id)*dtau(id))*dtt aiup(id)=(aim(id)*dtau(id-1)+aip(id)*dtau(id))*dtt end do riup(1)=rim(1) riup(nd)=rim(nd) aiup(1)=aim(1) aiup(nd)=aim(nd) c c final symmetrized (Feautrier) intensity -- (riin+riup)/2 c do id=1,nd u(id)=(riin(id)+riup(id))*half al0(id)=(aiin(id)+aiup(id))*half end do c DO ID=1,ND RAD1(ID)=RAD1(ID)+WTMU(I)*U(ID) RDK(ID)=RDK(ID)+AMU2*U(ID) ALI1(ID)=ALI1(ID)+WTMU(I)*AL0(ID) END DO AH=AH+AMU(I)*WTMU(I)*U(1) ahd=ahd+amu(i)*wtmu(i)*u(nd) ahout=ahout+amu(i)*wtmu(i)*riup(1) c c end of the loop over angle points c END DO C C solution of the transfer equation C Variables: C RAD1 - mean intensity C FAK1 - Eddington factor f(K) = K/J C FH - the "surface" Eddington factor C ALI1 - diagonal element of the lambda operator C IF(IBC.EQ.0) THEN ALI1(ND)=RAD1(ND)/ST0(ND) ALI1(ND-1)=RAD1(ND-1)/ST0(ND-1) END IF C DJTOT=0. DO ID=1,ND DELTAJ=(RAD1(ID)-RAD(IJ,ID))/(UN+SS0(ID)*ALI1(ID)) RAD(IJ,ID)=RAD(IJ,ID)+DELTAJ DJTOT=MAX(DJTOT,ABS(DELTAJ/RAD(IJ,ID))) END DO IF(DJTOT.GT.DJMAX.AND.ITRALI.LE.NTRALI) GO TO 10 C C end of ALI loop for electron scattering C DO ID=1,ND RAD1(ID)=RAD(IJ,ID) FAK1(ID)=RDK(ID)/RAD(IJ,ID) FKK(ID)=FAK1(ID) END DO FLUX(IJ)=AHout*half FH(IJ)=AH/RAD1(1)-HALF*ALB1 FH0=FH(IJ) fhd(ij)=ahd/rad1(nd) C C ******************** C C Again solution of the transfer equation, now with Eddington C FKK and FH determined above, to insure strict consistency of the C radiation field and Eddington factors C C Upper boundary condition C if(ilmcor.eq.3) then do id=1,nd sa0(id)=st0(id) ss0c(id)=ss0(id) ss0(id)=0. end do end if ID=1 DTP1=DT(ID) IF(MOD(ISPLIN,3).EQ.0) THEN B=DTP1*HALF C=0. ELSE B=DTP1*THIRD C=B*HALF END IF BQ=UN/(B+QQ0) CQ=C*BQ BBB(ID)=(FKK(ID)/DTP1+FH0+B)*BQ+SS0(ID) CCC(ID)=(FKK(ID+1)/DTP1)*BQ-CQ*(UN+SS0(ID+1)) ZZZ(ID)=UN/BBB(ID) VLL=SA0(ID)+CQ*SA0(ID+1) IF(IWINBL.LT.0) VLL=VLL+HEXTRD(IJ)*BQ AANU(ID)=VLL*ZZZ(ID) DDD(ID)=CCC(ID)*ZZZ(ID) IF(ISPLIN.GT.2) FFF=BBB(ID)/CCC(ID)-UN C C Normal depth point C DO ID=2,ND-1 DTM1=DTP1 DTP1=DT(ID) DT0=TWO/(DTP1+DTM1) AL=UN/DTM1*DT0 GA=UN/DTP1*DT0 IF(MOD(ISPLIN,3).EQ.0) THEN A=0. C=0. ELSE IF(ISPLIN.EQ.1) THEN A=DTM1*DT0*SIXTH C=DTP1*DT0*SIXTH ELSE A=(UN-HALF*DTP1*DTP1*AL)*SIXTH C=(UN-HALF*DTM1*DTM1*GA)*SIXTH END IF AAA(ID)=AL*FKK(ID-1)-A*(UN+SS0(ID-1)) CCC(ID)=GA*FKK(ID+1)-C*(UN+SS0(ID+1)) BBB(ID)=(AL+GA)*FKK(ID)+(UN-A-C)*(UN+SS0(ID)) VLL=A*SA0(ID-1)+C*SA0(ID+1)+(UN-A-C)*SA0(ID) AANU(ID)=VLL+AAA(ID)*AANU(ID-1) IF(ISPLIN.LE.2) THEN ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) DDD(ID)=CCC(ID)*ZZZ(ID) AANU(ID)=AANU(ID)*ZZZ(ID) ELSE SUM=-AAA(ID)+BBB(ID)-CCC(ID) FFF=(SUM+AAA(ID)*FFF*DDD(ID-1))/CCC(ID) DDD(ID)=UN/(UN+FFF) AANU(ID)=AANU(ID)*DDD(ID)/CCC(ID) ENDIF END DO C C Lower boundary condition C ID=ND IF(IBC.EQ.0) THEN BBB(ID)=FKK(ID)/DTP1+HALF AAA(ID)=FKK(ID-1)/DTP1 VLL=HALF*PLAND+THIRD*DPLAN ELSE IF(IBC.LT.4) THEN B=UN/DTP1 A=TWO*B*B BBB(ID)=UN+SS0(ID)+B+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=SA0(ID)+B*(PLAND+TWOTHR*DPLAN) ELSE B=UN/DTP1 A=TWO*B*B BBB(ID)=B+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=B*(PLAND+TWOTHR*DPLAN) END IF EEE(ND)=AAA(ID)/BBB(ID) ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) RAD1(ID)=(VLL+AAA(ID)*AANU(ID-1))*ZZZ(ID) FAK1(ID)=FKK(ND) ALRH(ID)=ZZZ(ID) C C Backsolution C DO ID=ND-1,1,-1 EEE(ID)=AAA(ID)/(BBB(ID)-CCC(ID)*EEE(ID+1)) RAD1(ID)=AANU(ID)+DDD(ID)*RAD1(ID+1) FAK1(ID)=FKK(ID) ALRH(ID)=ZZZ(ID)/(UN-DDD(ID)*EEE(ID+1)) ALRM(ID)=0 ALRP(ID)=0 END DO c C evaluate approximate Lambda operator C C a) Rybicki-Hummer Lambda^star operator (diagonal) C (for JALI = 1) C DO ID=1,ND ALIM1(ID)=0. ALIP1(ID)=0. END DO IF(JALI.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALRH(ID) END DO c IF(IBC.EQ.0) THEN ali1(nd-1)=rad1(nd-1)/sa0(nd-1) ali1(nd)=rad1(nd)/sa0(nd) END IF C C for IFALI>5: C tridiagonal Rybicki-Hummer operator (off-diagonal terms) C IF(IFALI.GE.6) THEN ALIP1(1)=ALRH(2)*DDD(1) DO ID=2,ND-1 ALIM1(ID)=ALRH(ID-1)*EEE(ID) ALIP1(ID)=ALRH(ID+1)*DDD(ID) END DO ALIM1(ND)=ALRH(ND-1)*EEE(ND) IF(IBC.EQ.0) THEN ALIM1(nd)=0. ALIM1(nd-1)=0. ALIP1(nd)=0. ALIP1(nd-1)=0. END IF END IF c C b) diagonal Olson-Kunasz Lambda^star operator, C (for JALI = 2) C ELSE IF(JALI.EQ.2) THEN DO ID=1,ND-1 ALI0(ID)=0. DO I=1,NMU DIV=DT(ID)/AMU(I) ALI0(ID)=ALI0(ID)+(UN-EXP(-DIV))/DIV*WTMU(I) END DO END DO DO ID=2,ND-1 ALI1(ID)=UN-HALF*(ALI0(ID)+ALI0(ID-1)) END DO ALI1(1)=UN-HALF*(ALI0(1)+US0) ALI1(ND)=UN-ALI0(ND-1) ali1(nd-1)=rad1(nd-1)/sa0(nd-1) ali1(nd)=rad1(nd)/sa0(nd) END IF C C correction of Lambda^star for scattering C IF(ILMCOR.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)*(UN+SS0(ID)) ALIM1(ID)=ALIM1(ID)*(UN+SS0(ID)) ALIP1(ID)=ALIP1(ID)*(UN+SS0(ID)) END DO IF(IBC.EQ.4) THEN ALI1(ND)= ALI1(ND)/(UN+SS0(ND)) ALIM1(ND)= ALIM1(ND)/(UN+SS0(ND)) ALIP1(ND)= ALIP1(ND)/(UN+SS0(ND)) END IF END IF C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0) RETURN IJE=IJEX(IJ) DO ID=1,ND RADEX(IJE,ID)=RAD1(ID) FAKEX(IJE,ID)=FAK1(ID) END DO Q0(IJE)=QQ0 UU0(IJE)=U0 RETURN END C C C **************************************************************** C C SUBROUTINE RTEDF2(IJ) C ===================== C C Solution of the radiative transfer equation - for one frequency C for the known source function. C Determination of the radiation field and variable Eddington C factors. C Analogous to RTEDF1, but using opacity and emissivity c instead of the source function C C The numerical method used: c Discontinuous Finite Element method c Castor, Dykema, Klein, 1992, ApJ 387, 561. C C different formulation of the boundary conditions C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0, * three=3.d0, * quart=0.25d0) DIMENSION DT(MDEPTH),RDK(MDEPTH),FKK(MDEPTH), * ST0(MDEPTH),SA0(MDEPTH),SS0(MDEPTH), * dtau(mdepth),rip(mdepth),rim(mdepth), * riin(mdepth),riup(mdepth),u(mdepth), * aip(mdepth),aim(mdepth),al0(mdepth), * aiin(mdepth),aiup(mdepth), * chip0(mdepth),chim0(mdepth),ddm0(mdepth), * chip(mdepth),chim(mdepth), * etap(mdepth),etam(mdepth) C FR=FREQ(IJ) C C optical depth scale C DO ID=1,ND-1 DT(ID)=DELDMZ(ID)*(ABSOT(ID+1)+ABSOT(ID)) SA0(ID)=EMIS1(ID)/ABSO1(ID) SS0(ID)=-SCAT1(ID)/ABSO1(ID) ddm0(id)=(dm(id+1)-dm(id)) chip0(id)=(abso1(id)*dens1(id)+three* * abso1(id+1)*dens1(id+1))*quart*ddm0(id) chim0(id)=(abso1(id)*dens1(id)*three+ * abso1(id+1)*dens1(id+1))*quart*ddm0(id) END DO SA0(ND)=EMIS1(ND)/ABSO1(ND) SS0(ND)=-SCAT1(ND)/ABSO1(ND) C TAUMIN=ABSO1(1)*DEDM1 C C Allowance for wind blanketing C ALB1=0. IF(IWINBL.GT.0) ALB1=TWO*ALBE(IJ)/(UN+ALBE(IJ)) C C quantities for the lower boundary condition C FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 PLAND=BNU/(EXP(HK*FR/TEMP(ND))-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMP(ND-1))-UN)*RRDIL IF(TEMPBD.GT.0.) THEN PLAND=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL ENDIF DPLAN=(PLAND-DPLAN)/DT(ND-1) C C global ALI loop for treating electron scattering C itrali=0 10 itrali=itrali+1 C C total source function C DO ID=1,ND ST0(ID)=SA0(ID)-SS0(ID)*RAD(IJ,ID) RAD1(ID)=0. RDK(ID)=0. ALI1(ID)=0. END DO AH=0. U0=0. QQ0=0. US0=0. c c loop over angle poits c DO I=1,NMU AMU2=AMU(I)*AMU(I)*WTMU(I) do id=1,nd-1 dtau(id)=dt(id)/amu(i) chip(id)=un+chip0(id)/amu(i) chim(id)=un+chim0(id)/amu(i) etap(id)=emis1(id+1)*dens1(id+1)/amu(i)*ddm0(id) etam(id)=emis1(id)*dens1(id)/amu(i)*ddm0(id) enddo c c incoming intensity c ID=1 P0=0. EX=UN C C allowance for non-zero optical depth at the first depth point C c rim(id)=EXTRAD(IJ) rim(id)=EXTINT(IJ,I) IF(IWINBL.EQ.0) THEN TAMM=TAUMIN/AMU(I) EX=EXP(-TAMM) P0=UN-EX QQ0=QQ0+P0*AMU(I)*WTMU(I) U0=U0+EX*WTMU(I) US0=US0+P0/TAMM*WTMU(I) rim(id)=st0(id)*p0 END IF c c incoming intensity c aim(id)=0. do id=1,nd-1 dt0=dtau(id) dtaup1=dt0+un dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=un/(dtau2+bb) aam=un/(un+chim(id)*chip(id)) rim(id+1)=(two*rim(id)+etap(id)*chim(id)+etam(id))*aam rip(id)=(two*rim(id)*chim(id)+etam(id)*chip(id)- * etap(id))*aam aim(id+1)=bb*aa aip(id)=(cc+bb*aim(id))*aa end do do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) dtm=un/(ddm0(id-1)+ddm0(id)) riin(id)=(rim(id)*ddm0(id)+rip(id)*ddm0(id-1))*dtm aiin(id)=(aim(id)*dtau(id)+aip(id)*dtau(id-1))*dtt end do riin(1)=rim(1) riin(nd)=rim(nd) aiin(1)=aim(1) aiin(nd)=aim(nd) C c outgoing intensity c rim(nd)=PLAND+AMU(I)*DPLAN do id=nd-1,1,-1 dt0=dtau(id) dtaup1=dt0+un dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=un/(dtau2+bb) aam=un/(un+chim(id)*chip(id)) rim(id)=(two*rim(id+1)+etam(id)*chip(id)+etap(id))*aam rip(id+1)=(two*rim(id+1)*chip(id)+etap(id)*chim(id)- * etam(id))*aam aim(id)=cc*aa aip(id+1)=(cc+bb*aim(id+1))*aa end do do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) dtm=un/(ddm0(id-1)+ddm0(id)) riup(id)=(rim(id)*ddm0(id-1)+rip(id)*ddm0(id))*dtm aiup(id)=(aim(id)*dtau(id-1)+aip(id)*dtau(id))*dtt end do riup(1)=rim(1) riup(nd)=rim(nd) aiup(1)=aim(1) aiup(nd)=aim(nd) c c final symmetrized (Feautrier) intensity -- (riin+riup)/2 c do id=1,nd u(id)=(riin(id)+riup(id))*half al0(id)=(aiin(id)+aiup(id))*half end do c DO ID=1,ND RAD1(ID)=RAD1(ID)+WTMU(I)*U(ID) RDK(ID)=RDK(ID)+AMU2*U(ID) ALI1(ID)=ALI1(ID)+WTMU(I)*AL0(ID) END DO AH=AH+AMU(I)*WTMU(I)*U(1) c c end of the loop over angle points c END DO C C solution of the transfer equation C Variables: C RAD1 - mean intensity C FAK1 - Eddington factor f(K) = K/J C FH - the "surface" Eddington factor C ALI1 - diagonal element of the lambda operator C IF(IBC.EQ.0) THEN ALI1(ND)=RAD1(ND)/ST0(ND) ALI1(ND-1)=RAD1(ND-1)/ST0(ND-1) END IF C DJTOT=0. DO ID=1,ND DELTAJ=(RAD1(ID)-RAD(IJ,ID))/(UN+SS0(ID)*ALI1(ID)) RAD(IJ,ID)=RAD(IJ,ID)+DELTAJ DJTOT=MAX(DJTOT,ABS(DELTAJ/RAD(IJ,ID))) END DO IF(DJTOT.GT.DJMAX.AND.ITRALI.LE.NTRALI) GO TO 10 C C end of ALI loop for electron scattering C DO ID=1,ND RAD1(ID)=RAD(IJ,ID) FAK1(ID)=RDK(ID)/RAD(IJ,ID) FKK(ID)=FAK1(ID) END DO FLUX(IJ)=AH FH(IJ)=AH/RAD1(1)-HALF*ALB1 FH0=FH(IJ) C C correction of Lambda^star for scattering C IF(ILMCOR.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)*(UN+SS0(ID)) END DO IF(IBC.EQ.4) THEN ALI1(ND)= ALI1(ND)/(UN+SS0(ND)) END IF ELSE IF(ILMCOR.EQ.3) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)/(UN+SS0(ID)*ALI1(ID)) END DO IF(IBC.EQ.4) THEN ALI1(ND)= ALI1(ND)*(UN+SS0(ND)*ALI1(ID)) END IF END IF C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0) RETURN IJE=IJEX(IJ) DO ID=1,ND RADEX(IJE,ID)=RAD1(ID) FAKEX(IJE,ID)=FAK1(ID) END DO Q0(IJE)=QQ0 UU0(IJE)=U0 RETURN END C C C **************************************************************** C C SUBROUTINE RTEFR1(IJ) C ===================== C C Solution of the radiative transfer equation - for one frequency C - for the known source function. C Determination of the radiation field and variable Eddington C factors. C C The numerical method used: C for ISPLIN = 0 - the ordinary Feautrier scheme C = 1 - the spline collocation method C = 2 - Hermitian fourth-order method C = 3 - improved Feautrier scheme C (Rybicki & Hummer 1991, A&A 245, 171.) C C In all cases, the overall matrix system is solved by the standard C Gaussian elimination, analogous to that described in SOLVE C (auxiliary matrix D is called ALF in SOLVE; auxiliary vector ANU C is called BET in SOLVE) C C U0 - derivative of Q0 wrt taumin; C for "fixed" frequencies, U0 has the meaning of C absorption coefficient * second moment H C ( a quantity needed for lower boundary condition of the C hydrostatic equilibrium equation, specifically for C accounting for an effect of fixed-option transitions) C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0) DIMENSION AANU(MDEPTH),DDD(MDEPTH),FKK(MDEPTH), * RDD(MDEPTH),ST0(MDEPTH),SS0(MDEPTH),AB0(MDEPTH), * AA(MMU,MMU),BB(MMU,MMU),CC(MMU,MMU),VL(MMU), * FFD(MMU,MMU),FF0D(MMU,MMU), * FFPD(MMU,MMU),ali0(mdepth),ss0c(mdepth), * AAA(MDEPTH),BBB(MDEPTH),CCC(MDEPTH),EEE(MDEPTH), * ZZZ(MDEPTH),ALRH(MDEPTH),ALRM(MDEPTH),ALRP(MDEPTH), * D(MMU,MMU,MDEPTH),ANU(MMU,MDEPTH),scor(mdepth) DIMENSION rmmu(2*MMU),wmmu(2*MMU),rwmu(2*MMU), * dtau(mdepth),ri(mdepth),ali(mdepth),alij1(mdepth) dimension tau(mdepth) COMMON/OPTDPT/DT(MDEPTH) C WW=W(IJ) ISPL=ISPLIN IF(ISPLIN.GE.5) THEN ISPLIN=ISPL-5 IF(IJALI(IJ).GT.0) THEN IF(IRTE.EQ.0) THEN CALL RTEDF1(IJ) ELSE CALL RTEDF2(IJ) END IF ISPLIN=ISPL if(ifprad.eq.0) return DO ID=1,ND if(.not.lskip(ID,IJ)) * PRADT(ID)=PRADT(ID)+RAD1(ID)*FAK1(ID)*W(ij) END DO if(.not.lskip(1,IJ)) * PRD0=PRD0+ABSO1(1)*W(IJ)*(RAD1(1)*FH(IJ)-HEXTRD(IJ)) DO ID=1,ND PRADA(ID)=PRADA(ID)+RAD1(ID)*FAK1(ID)*WW END DO RETURN END IF END IF C if(icompt.gt.0.and.(iter.gt.1.or.ilam.gt.0)) then call rtecf1(ij) return end if c C FR=FREQ(IJ) C C total source function C AH=0. DO ID=1,ND AB0(ID)=ABSO1(ID) ST0(ID)=EMIS1(ID)/AB0(ID) RAD1(ID)=0. ALI1(ID)=0. END DO C C non-coherent electron scattering by lambda iteration C IF(NELSC.LE.0) THEN DO ID=1,ND SS0(ID)=-SCAT1(ID)/AB0(ID) END DO ELSE DO ID=1,ND ST0(ID)=ST0(ID)+SCAT1(ID)*EMEL1(ID)*RAD1(ID)/AB0(ID) SS0(ID)=0. END DO END IF C C optical depth scale C tau(1)=absot(1)*dm(1) DO ID=1,ND-1 DT(ID)=DELDMZ(ID)*(ABSOT(ID+1)+ABSOT(ID)) tau(id+1)=tau(id)+dt(id) END DO c U0=0. QQ0=0. US0=0. c TAUMIN=ABSO1(1)*DEDM1 taumin=absot(1)*dm(1)/2. ALB1=0. C C Allowance for wind blanketing C IF(IWINBL.GT.0) ALB1=TWO*ALBE(IJ)/(UN+ALBE(IJ)) C C ************** Forward elimination C C Upper boundary condition C ID=1 DTP1=DT(1) P0=0. EX=UN IF(MOD(ISPLIN,3).EQ.0) THEN B=DTP1*HALF C=0. ELSE B=DTP1*THIRD C=B*HALF END IF QQ0=0. US0=0. DO I=1,NMU IF(IDISK.EQ.0) THEN C C allowance for non-zero optical depth at the first depth point C TAMM=TAUMIN/AMU(I) EX=EXP(-TAMM) P0=UN-EX QQ0=QQ0+P0*AMU(I)*WTMU(I) U0=U0+EX*WTMU(I) US0=US0+P0/TAMM*WTMU(I) END IF C BI=B/AMU(I) CI=C/AMU(I) VL(I)=(BI+P0)*ST0(ID)+CI*ST0(ID+1) IF(IWINBL.LT.0) VL(I)=VL(I)+EXTINT(IJ,I) DO J=1,NMU BB(I,J)=SS0(ID)*WTMU(J)*(BI+P0)-ALB1*WTMU(J) CC(I,J)=-CI*SS0(ID+1)*WTMU(J) END DO BB(I,I)=BB(I,I)+AMU(I)/DTP1+UN+BI CC(I,I)=CC(I,I)+AMU(I)/DTP1-CI ANU(I,ID)=0. END DO C IF(ISPLIN.LE.2) THEN CALL MATINV(BB,NMU,MMU) DO I=1,NMU DO J=1,NMU D(I,J,ID)=0. DO K=1,NMU D(I,J,ID)=D(I,J,ID)+BB(I,K)*CC(K,J) END DO ANU(I,1)=ANU(I,1)+BB(I,J)*VL(J) END DO END DO ELSE DO I=1,NMU DO J=1,NMU FF0D(I,J)=BB(I,J)/CC(I,I) END DO FF0D(I,I)=FF0D(I,I)-UN END DO C c CALL MINV3(BB) CALL MATINV(BB,NMU,MMU) DO I=1,NMU ANU(I,ID)=0. DO J=1,NMU D(I,J,ID)=BB(I,J)*CC(J,J) ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) END DO END DO END IF C C Normal depth points 1 < ID < ND C DO ID=2,ND-1 DTM1=DTP1 DTP1=DT(ID) DT0=TWO/(DTM1+DTP1) AL=UN/DTM1*DT0 GA=UN/DTP1*DT0 BE=AL+GA IF(MOD(ISPLIN,3).EQ.0) THEN A=0. C=0. ELSE IF(ISPLIN.EQ.1) THEN A=DTM1*DT0*SIXTH C=DTP1*DT0*SIXTH ELSE A=(UN-HALF*AL*DTP1*DTP1)*SIXTH C=(UN-HALF*GA*DTM1*DTM1)*SIXTH END IF B=UN-A-C VL0=A*ST0(ID-1)+B*ST0(ID)+C*ST0(ID+1) DO I=1,NMU DO J=1,NMU AA(I,J)=-A*SS0(ID-1)*WTMU(J) CC(I,J)=-C*SS0(ID+1)*WTMU(J) BB(I,J)=B*SS0(ID)*WTMU(J) END DO END DO DO I=1,NMU VL(I)=VL0 DIV=AMU(I)*AMU(I) AA(I,I)=AA(I,I)+DIV*AL-A CC(I,I)=CC(I,I)+DIV*GA-C BB(I,I)=BB(I,I)+DIV*BE+B END DO DO I=1,NMU DO J=1,NMU VL(I)=VL(I)+AA(I,J)*ANU(J,ID-1) END DO END DO IF(ISPLIN.LE.2) THEN DO I=1,NMU DO J=1,NMU S=0. DO K=1,NMU S=S+AA(I,K)*D(K,J,ID-1) END DO BB(I,J)=BB(I,J)-S END DO END DO C CALL MATINV(BB,NMU,MMU) DO I=1,NMU DO J=1,NMU D(I,J,ID)=0. DO K=1,NMU D(I,J,ID)=D(I,J,ID)+BB(I,K)*CC(K,J) END DO END DO END DO ELSE DO I=1,NMU BB(I,I)=-AA(I,I)+BB(I,I)-CC(I,I) DO J=1,NMU FFPD(I,J)=AA(I,I)*FF0D(I,J) END DO END DO DO I=1,NMU DO J=1,NMU S=0. DO K=1,NMU S=S+FFPD(I,K)*D(K,J,ID-1) END DO FFD(I,J)=(BB(I,J)+S)/CC(I,I) END DO END DO DO I=1,NMU DO J=1,NMU FF0D(I,J)=FFD(I,J) END DO FFD(I,I)=FFD(I,I)+UN END DO C CALL MATINV(FFD,NMU,MMU) DO I=1,NMU DO J=1,NMU D(I,J,ID)=FFD(I,J) BB(I,J)=FFD(I,J)/CC(J,J) END DO END DO END IF DO I=1,NMU ANU(I,ID)=0. DO J=1,NMU ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) END DO END DO END DO C C Lower boundary condition C ID=ND C C First option: C b.c. is different from stellar atmospheres; expresses symmetry C at the central plane I(taumax,-mu,nu)=I(taumax,+mu,nu) C IF(IFZ0.GE.0.AND.IDISK.EQ.1) THEN B=DTP1*HALF A=0. DO I=1,NMU BI=B/AMU(I) AI=A/AMU(I) VL(I)=ST0(ID)*BI+ST0(ID-1)*AI DO J=1,NMU AA(I,J)=-AI*SS0(ID-1)*WTMU(J) BB(I,J)=BI*SS0(ID)*WTMU(J) END DO AA(I,I)=AA(I,I)+AMU(I)/DTP1-AI BB(I,I)=BB(I,I)+AMU(I)/DTP1+BI END DO DO I=1,NMU S1=0. DO J=1,NMU S=0. S1=S1+AA(I,J)*ANU(J,ID-1) DO K=1,NMU S=S+AA(I,K)*D(K,J,ID-1) END DO BB(I,J)=BB(I,J)-S END DO VL(I)=VL(I)+S1 END DO C C Second option: C b.c. is the same as in stellar atmospheres - the last depth point C is not at the central plane C ELSE FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 PLAND=BNU/(EXP(HK*FR/TEMP(ND ))-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMP(ND-1))-UN)*RRDIL IF(TEMPBD.GT.0.) THEN PLAND=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL END IF DPLAN=(PLAND-DPLAN)/DT(ND-1) IF(IBC.EQ.0.OR.IBC.EQ.4) THEN DO I=1,NMU AA(I,I)=AMU(I)/DTP1 VL(I)=PLAND+AMU(I)*DPLAN+AA(I,I)*ANU(I,ID-1) DO J=1,NMU BB(I,J)=-AA(I,I)*D(I,J,ID-1) END DO BB(I,I)=BB(I,I)+AA(I,I)+UN END DO ELSE DO I=1,NMU A=AMU(I)/DTP1 B=HALF/A AA(I,I)=A VL(I)=B*ST0(ID)+PLAND+AMU(I)*DPLAN+AA(I,I)*ANU(I,ID-1) DO J=1,NMU BB(I,J)=B*SS0(ID)*WTMU(J)-AA(I,I)*D(I,J,ID-1) END DO BB(I,I)=BB(I,I)+A+B+UN END DO END IF END IF C CALL MATINV(BB,NMU,MMU) C DO I=1,NMU ANU(I,ID)=0. DO J=1,NMU D(I,J,ID)=0. ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) END DO END DO C C ***************** Backsolution C FKK(ND)=THIRD AJ=0. AH=0. AK=0. DO I=1,NMU RMU=WTMU(I)*ANU(I,ID) AJ=AJ+RMU AH=AH+RMU*AMU(I) AK=AK+RMU*AMU(I)*AMU(I) END DO RDD(ID)=AJ IF(IBC.EQ.0) THEN FKK(ND)=THIRD ELSE FKK(ID)=AK/AJ FHD(IJ)=AH/AJ END IF C DO ID=ND-1,1,-1 DO I=1,NMU DO J=1,NMU ANU(I,ID)=ANU(I,ID)+D(I,J,ID)*ANU(J,ID+1) END DO END DO AJ=0. AK=0. DO I=1,NMU RMU=WTMU(I)*ANU(I,ID) AJ=AJ+RMU AK=AK+RMU*AMU(I)*AMU(I) END DO C C solution of the transfer equation C Variables: C ANU - Feautrier intensity C RDD - mean intensity C FKK - Eddington factor f(K) = K/J C FKK(ID)=AK/AJ RDD(ID)=AJ END DO C if(idisk.eq.1) then do id=1,nd fak(ij,id)=fkk(id) end do end if C C the "surface" Eddington factor fH C AH=0. DO I=1,NMU AH=AH+WTMU(I)*AMU(I)*ANU(I,1) END DO FH0=AH/AJ-HALF*ALB1 FH(IJ)=FH0 q0(ij)=qq0 uu0(ij)=u0 c q0(ij)=0. c uu0(ij)=0. C C ******************** C C Again solution of the transfer equation, now with Eddington C FKK and FH determined above, to insure strict consistency of the C radiation field and Eddington factors C if(ilmcor.eq.2) then do id=1,nd scor(id)=un/(un+ss0(id)) end do else if(ilmcor.eq.3) then do id=1,nd ss0c(id)=ss0(id) st0(id)=st0(id)-ss0(id)*rdd(id) ss0(id)=0. end do end if C C Upper boundary condition C ID=1 DTP1=DT(ID) IF(MOD(ISPLIN,3).EQ.0) THEN B=DTP1*HALF C=0. ELSE B=DTP1*THIRD C=B*HALF END IF BQ=UN/(B+QQ0) CQ=C*BQ BBB(ID)=(FKK(ID)/DTP1+FH0+B)*BQ+SS0(ID) CCC(ID)=(FKK(ID+1)/DTP1)*BQ-CQ*(UN+SS0(ID+1)) VLL=ST0(ID)+CQ*ST0(ID+1) IF(IWINBL.LT.0) VLL=VLL+HEXTRD(IJ)*BQ if(ilmcor.eq.2) then bbb(id)=bbb(id)*scor(id) ccc(id)=ccc(id)*scor(id) vll=vll*scor(id) end if ZZZ(ID)=UN/BBB(ID) AANU(ID)=VLL*ZZZ(ID) DDD(ID)=CCC(ID)*ZZZ(ID) IF(ISPLIN.GT.2) FFF=BBB(ID)/CCC(ID)-UN C C Normal depth point C DO ID=2,ND-1 DTM1=DTP1 DTP1=DT(ID) DT0=TWO/(DTP1+DTM1) AL=UN/DTM1*DT0 GA=UN/DTP1*DT0 IF(MOD(ISPLIN,3).EQ.0) THEN A=0. C=0. ELSE IF(ISPLIN.EQ.1) THEN A=DTM1*DT0*SIXTH C=DTP1*DT0*SIXTH ELSE A=(UN-HALF*DTP1*DTP1*AL)*SIXTH C=(UN-HALF*DTM1*DTM1*GA)*SIXTH END IF AAA(ID)=AL*FKK(ID-1)-A*(UN+SS0(ID-1)) CCC(ID)=GA*FKK(ID+1)-C*(UN+SS0(ID+1)) BBB(ID)=(AL+GA)*FKK(ID)+(UN-A-C)*(UN+SS0(ID)) VLL=A*ST0(ID-1)+C*ST0(ID+1)+(UN-A-C)*ST0(ID) if(ilmcor.eq.2) then aaa(id)=aaa(id)*scor(id) bbb(id)=bbb(id)*scor(id) ccc(id)=ccc(id)*scor(id) vll=vll*scor(id) end if AANU(ID)=VLL+AAA(ID)*AANU(ID-1) IF(ISPLIN.LE.2) THEN ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) DDD(ID)=CCC(ID)*ZZZ(ID) AANU(ID)=AANU(ID)*ZZZ(ID) ELSE SUM=-AAA(ID)+BBB(ID)-CCC(ID) FFF=(SUM+AAA(ID)*FFF*DDD(ID-1))/CCC(ID) DDD(ID)=UN/(UN+FFF) AANU(ID)=AANU(ID)*DDD(ID)/CCC(ID) END IF END DO C C Lower boundary condition C ID=ND c c stellar atmospheric c IF(IDISK.EQ.0.OR.IFZ0.LT.0) then IF(IBC.EQ.0) THEN BBB(ID)=FKK(ID)/DTP1+HALF AAA(ID)=FKK(ID-1)/DTP1 VLL=HALF*PLAND+THIRD*DPLAN ELSE IF(IBC.LT.4) THEN B=UN/DTP1 A=TWO*B*B BBB(ID)=UN+SS0(ID)+B*TWO*FHD(IJ)+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=ST0(ID)+B*(PLAND+TWOTHR*DPLAN) ELSE B=UN/DTP1 A=TWO*B*B BBB(ID)=B+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=B*(PLAND+TWOTHR*DPLAN) END IF c c accretion disk - symmetric boundary c ELSE B=TWO/DTP1 BBB(ID)=FKK(ID)/DTP1*B+UN+SS0(ND) AAA(ID)=FKK(ID-1)/DTP1*B VLL=ST0(ID) END IF if(ilmcor.eq.2) then aaa(id)=aaa(id)*scor(id) bbb(id)=bbb(id)*scor(id) vll=vll*scor(id) end if EEE(ND)=AAA(ID)/BBB(ID) ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) RAD1(ID)=(VLL+AAA(ID)*AANU(ID-1))*ZZZ(ID) FAK1(ID)=FKK(ND) ALRH(ID)=ZZZ(ID) c C Backsolution C DO ID=ND-1,1,-1 EEE(ID)=AAA(ID)/(BBB(ID)-CCC(ID)*EEE(ID+1)) RAD1(ID)=AANU(ID)+DDD(ID)*RAD1(ID+1) FAK1(ID)=FKK(ID) ALRH(ID)=ZZZ(ID)/(UN-DDD(ID)*EEE(ID+1)) ALRM(ID)=0 ALRP(ID)=0 END DO FLUX(IJ)=FH(IJ)*RAD1(1)-half*hextrd(ij) * -(st0(1)-ss0(1)*rad1(1))*q0(ij) C C evaluate approximate Lambda operator C C a) Rybicki-Hummer Lambda^star operator (diagonal) C (for JALI = 1) C DO ID=1,ND ALIM1(ID)=0. ALIP1(ID)=0. END DO IF(JALI.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALRH(ID) END DO c IF(IBC.EQ.0) THEN ali1(nd-1)=rad1(nd-1)/st0(nd-1) ali1(nd)=rad1(nd)/st0(nd) END IF C C for IFALI>5: C tridiagonal Rybicki-Hummer operator (off-diagonal terms) C IF(IFALI.GE.6) THEN ALIP1(1)=ALRH(2)*DDD(1) DO ID=2,ND-1 ALIM1(ID)=ALRH(ID-1)*EEE(ID) ALIP1(ID)=ALRH(ID+1)*DDD(ID) END DO ALIM1(ND)=ALRH(ND-1)*EEE(ND) IF(IBC.EQ.0) THEN ALIM1(nd)=0. ALIM1(nd-1)=0. ALIP1(nd)=0. ALIP1(nd-1)=0. END IF END IF c C b) diagonal Olson-Kunasz Lambda^star operator, C (for JALI = 2) C ELSE IF(JALI.EQ.2) THEN DO ID=1,ND-1 ALI0(ID)=0. DO I=1,NMU DIV=DT(ID)/AMU(I) ALI0(ID)=ALI0(ID)+(UN-EXP(-DIV))/DIV*WTMU(I) END DO END DO DO ID=2,ND-1 ALI1(ID)=UN-HALF*(ALI0(ID)+ALI0(ID-1)) END DO ALI1(1)=UN-HALF*(ALI0(1)+US0) ALI1(ND)=UN-ALI0(ND-1) ali1(nd-1)=rad1(nd-1)/st0(nd-1) ali1(nd)=rad1(nd)/st0(nd) END IF C C correction of Lambda^star for scattering C IF(ILMCOR.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)*(UN+SS0(ID)) ALIM1(ID)=ALIM1(ID)*(UN+SS0(ID)) ALIP1(ID)=ALIP1(ID)*(UN+SS0(ID)) END DO IF(IBC.EQ.4) THEN ALI1(ND)= ALI1(ND)/(UN+SS0(ND)) ALIM1(ND)= ALIM1(ND)/(UN+SS0(ND)) ALIP1(ND)= ALIP1(ND)/(UN+SS0(ND)) END IF END IF C if(ifalih.gt.0) then c c solution for the individual angles - to get Lambda^star_H C do id=1,nd alih1(id)=0. alij1(id)=0. end do nw=nmu do i=1,nw rmmu(i)=-amu(nw-i+1) rmmu(i+nw)=amu(i) wmmu(i)=wtmu(nw-i+1) wmmu(i+nw)=wtmu(i) end do do i=1,2*nw rwmu(i)=rmmu(i)*wmmu(i)*half end do C c --------------------- loop over angles c do i=1,2*nw do id=1,nd-1 dtau(id)=dt(id)/abs(rmmu(i)) end do c c boundary conditions c c rup=extrad(ij) rup=extint(ij,i) C C diffusion approximation for semi-infinite atmospheres C rdown=pland+rmmu(i)*dplan c c solution of the transfer equation c call rtesol(dtau,st0,rup,rdown,rmmu(i),ri,ali) c DO ID=1,ND alih1(id)=alih1(id)+rwmu(i)*ali(id) alij1(id)=alij1(id)+wmmu(i)*ali(id)*half END DO end do end if C c --------------------- end of loop over angles c ISPLIN=ISPL c if(idisk.ne.0) then iji=nfreq-kij(ij)+1 DO ID=1,ND rad(iji,id)=rad1(id) END DO end if C C radiation pressure C if(ifprad.gt.0) then if(.not.lskip(1,IJ)) * PRD0=PRD0+ABSO1(1)*WW*(RAD1(1)*FH(IJ)-HEXTRD(IJ)) DO ID=1,ND if(.not.lskip(ID,IJ)) * PRADT(ID)=PRADT(ID)+RAD1(ID)*FAK1(ID)*WW PRADA(ID)=PRADA(ID)+RAD1(ID)*FAK1(ID)*WW END DO end if c if(chmax.ge.1.91e-3.and.chmax.le.2.03e-3) then tauij=taumin do id=1,nd if(ilmcor.eq.3) ss0(id)=ss0c(id) if(id.gt.1) tauij=tauij+dt(id-1) write(97,697) ij,id,tauij,rad1(id),st0(id)/(un+ss0(id)),st0(id), * un+ss0(id),ali1(id) end do 697 format(2i4,1p6e12.4) end if C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0) RETURN IJE=IJEX(IJ) DO ID=1,ND RADEX(IJE,ID)=RAD1(ID) FAKEX(IJE,ID)=FAK1(ID) END DO c Q0(IJE)=QQ0 c UU0(IJE)=U0 RETURN END C C C **************************************************************** C C SUBROUTINE RTEINT C ================= C C Solution of the radiative transfer equation - for one frequency C - for the known source function. C C Solution for specific intensities C C The numerical method used: C for ISPLIN = 0 - the ordinary Feautrier scheme C = 1 - the spline collocation method C = 2 - Hermitian fourth-order method C = 3 - improved Feautrier scheme C (Rybicki & Hummer 1991, A&A 245, 171.) C C In all cases, the overall matrix system is solved by the standard C Gaussian elimination, analogous to that described in SOLVE C (auxiliary matrix D is called ALF in SOLVE; auxiliary vector ANU C is called BET in SOLVE) C C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0) PARAMETER (MMA=20) DIMENSION ST0(MDEPTH),SS0(MDEPTH),AB0(MDEPTH), * AA(MMA,MMA),BB(MMA,MMA),CC(MMA,MMA),VL(MMA), * FFD(MMA,MMA),FF0D(MMA,MMA),FFPD(MMA,MMA), * D(MMA,MMA,MDEPTH),ANU(MMA,MDEPTH) DIMENSION tau(mdepth),angl(mma),WANG(MMA) COMMON/OPTDPT/DT(MDEPTH) C nmuf=nmu nmu=intens do imu=1,nmu angl(imu)=0.1+float(imu-1)*0.9/float(nmu-1) wang(imu)=0.9/float(nmu-1) end do wang(1)=wang(1)*0.5 wang(nmu)=WANG(NMU)*0.5 C DO 500 IJO=1,NFREQ IJ=IJO IF(ispodf.eq.0) IJ=JIK(IJO) IF(IJX(IJ).EQ.-1) GO TO 500 call opacf1(IJ) c FR=FREQ(IJ) C C total source function C AH=0. DO ID=1,ND AB0(ID)=ABSO1(ID) ST0(ID)=EMIS1(ID)/AB0(ID) SS0(ID)=-SCAT1(ID)/AB0(ID) RAD1(ID)=0. END DO C C optical depth scale C tau(1)=absot(1)*dm(1) DO ID=1,ND-1 DT(ID)=DELDMZ(ID)*(ABSOT(ID+1)+ABSOT(ID)) tau(id+1)=tau(id)+dt(id) END DO c U0=0. QQ0=0. US0=0. taumin=absot(1)*dm(1)/2. C ALB1=0. C C ************** Forward elimination C C Upper boundary condition C ID=1 DTP1=DT(1) P0=0. EX=UN IF(MOD(ISPLIN,3).EQ.0) THEN B=DTP1*HALF C=0. ELSE B=DTP1*THIRD C=B*HALF END IF QQ0=0. US0=0. DO I=1,NMU IF(IDISK.EQ.0) THEN C C allowance for non-zero optical depth at the first depth point C TAMM=TAUMIN/ANGL(I) EX=EXP(-TAMM) P0=UN-EX QQ0=QQ0+P0*ANGL(I)*WANG(I) U0=U0+EX*WANG(I) US0=US0+P0/TAMM*WANG(I) END IF C BI=B/ANGL(I) CI=C/ANGL(I) VL(I)=(BI+P0)*ST0(ID)+CI*ST0(ID+1) IF(IWINBL.LT.0) VL(I)=VL(I)+EXTRAD(IJ) DO J=1,NMU BB(I,J)=SS0(ID)*WANG(J)*(BI+P0)-ALB1*WANG(J) CC(I,J)=-CI*SS0(ID+1)*WANG(J) END DO BB(I,I)=BB(I,I)+ANGL(I)/DTP1+UN+BI CC(I,I)=CC(I,I)+ANGL(I)/DTP1-CI ANU(I,ID)=0. END DO C IF(ISPLIN.LE.2) THEN CALL MATINV(BB,NMU,MMA) DO I=1,NMU DO J=1,NMU D(I,J,ID)=0. DO K=1,NMU D(I,J,ID)=D(I,J,ID)+BB(I,K)*CC(K,J) END DO ANU(I,1)=ANU(I,1)+BB(I,J)*VL(J) END DO END DO ELSE DO I=1,NMU DO J=1,NMU FF0D(I,J)=BB(I,J)/CC(I,I) END DO FF0D(I,I)=FF0D(I,I)-UN END DO C CALL MATINV(BB,NMU,MMA) DO I=1,NMU ANU(I,ID)=0. DO J=1,NMU D(I,J,ID)=BB(I,J)*CC(J,J) ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) END DO END DO ENDIF C C Normal depth points 1 < ID < ND C DO ID=2,ND-1 DTM1=DTP1 DTP1=DT(ID) DT0=TWO/(DTM1+DTP1) AL=UN/DTM1*DT0 GA=UN/DTP1*DT0 BE=AL+GA IF(MOD(ISPLIN,3).EQ.0) THEN A=0. C=0. ELSE IF(ISPLIN.EQ.1) THEN A=DTM1*DT0*SIXTH C=DTP1*DT0*SIXTH ELSE A=(UN-HALF*AL*DTP1*DTP1)*SIXTH C=(UN-HALF*GA*DTM1*DTM1)*SIXTH END IF B=UN-A-C VL0=A*ST0(ID-1)+B*ST0(ID)+C*ST0(ID+1) DO I=1,NMU DO J=1,NMU AA(I,J)=-A*SS0(ID-1)*WANG(J) CC(I,J)=-C*SS0(ID+1)*WANG(J) BB(I,J)=B*SS0(ID)*WANG(J) END DO END DO DO I=1,NMU VL(I)=VL0 DIV=ANGL(I)*ANGL(I) AA(I,I)=AA(I,I)+DIV*AL-A CC(I,I)=CC(I,I)+DIV*GA-C BB(I,I)=BB(I,I)+DIV*BE+B END DO DO I=1,NMU DO J=1,NMU VL(I)=VL(I)+AA(I,J)*ANU(J,ID-1) END DO END DO IF(ISPLIN.LE.2) THEN DO I=1,NMU DO J=1,NMU S=0. DO K=1,NMU S=S+AA(I,K)*D(K,J,ID-1) END DO BB(I,J)=BB(I,J)-S END DO END DO C CALL MATINV(BB,NMU,MMA) DO I=1,NMU DO J=1,NMU D(I,J,ID)=0. DO K=1,NMU D(I,J,ID)=D(I,J,ID)+BB(I,K)*CC(K,J) END DO END DO END DO ELSE DO I=1,NMU BB(I,I)=-AA(I,I)+BB(I,I)-CC(I,I) DO J=1,NMU FFPD(I,J)=AA(I,I)*FF0D(I,J) END DO END DO DO I=1,NMU DO J=1,NMU S=0. DO K=1,NMU S=S+FFPD(I,K)*D(K,J,ID-1) END DO FFD(I,J)=(BB(I,J)+S)/CC(I,I) END DO END DO DO I=1,NMU DO J=1,NMU FF0D(I,J)=FFD(I,J) END DO FFD(I,I)=FFD(I,I)+UN END DO C CALL MATINV(FFD,NMU,MMA) DO I=1,NMU DO J=1,NMU D(I,J,ID)=FFD(I,J) BB(I,J)=FFD(I,J)/CC(J,J) END DO END DO END IF DO I=1,NMU ANU(I,ID)=0. DO J=1,NMU ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) END DO END DO END DO C C Lower boundary condition C ID=ND C C First option: C b.c. is different from stellar atmospheres; expresses symmetry C at the central plane I(taumax,-mu,nu)=I(taumax,+mu,nu) C IF(IFZ0.GE.0.AND.IDISK.EQ.1) THEN B=DTP1*HALF A=0. DO I=1,NMU BI=B/ANGL(I) AI=A/ANGL(I) VL(I)=ST0(ID)*BI+ST0(ID-1)*AI DO J=1,NMU AA(I,J)=-AI*SS0(ID-1)*WANG(J) BB(I,J)=BI*SS0(ID)*WANG(J) END DO AA(I,I)=AA(I,I)+ANGL(I)/DTP1-AI BB(I,I)=BB(I,I)+ANGL(I)/DTP1+BI END DO DO I=1,NMU S1=0. DO J=1,NMU S=0. S1=S1+AA(I,J)*ANU(J,ID-1) DO K=1,NMU S=S+AA(I,K)*D(K,J,ID-1) END DO BB(I,J)=BB(I,J)-S END DO VL(I)=VL(I)+S1 END DO C C Second option: C b.c. is the same as in stellar atmospheres - the last depth point C is not at the central plane C ELSE FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 PLAND=BNU/(EXP(HK*FR/TEMP(ND ))-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMP(ND-1))-UN)*RRDIL IF(TEMPBD.GT.0.) THEN PLAND=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL END IF DPLAN=(PLAND-DPLAN)/DT(ND-1) IF(IBC.EQ.0.OR.IBC.EQ.4) THEN DO I=1,NMU AA(I,I)=ANGL(I)/DTP1 VL(I)=PLAND+ANGL(I)*DPLAN+AA(I,I)*ANU(I,ID-1) DO J=1,NMU BB(I,J)=-AA(I,I)*D(I,J,ID-1) END DO BB(I,I)=BB(I,I)+AA(I,I)+UN END DO ELSE DO I=1,NMU A=ANGL(I)/DTP1 B=HALF/A AA(I,I)=A VL(I)=B*ST0(ID)+PLAND+ANGL(I)*DPLAN+AA(I,I)*ANU(I,ID-1) DO J=1,NMU BB(I,J)=B*SS0(ID)*WANG(J)-AA(I,I)*D(I,J,ID-1) END DO BB(I,I)=BB(I,I)+A+B+UN END DO END IF END IF C CALL MATINV(BB,NMU,MMA) C DO 230 I=1,NMU ANU(I,ID)=0. DO 230 J=1,NMU D(I,J,ID)=0. ANU(I,ID)=ANU(I,ID)+BB(I,J)*VL(J) 230 CONTINUE C C ***************** Backsolution C DO ID=ND-1,1,-1 DO I=1,NMU DO J=1,NMU ANU(I,ID)=ANU(I,ID)+D(I,J,ID)*ANU(J,ID+1) END DO END DO END DO c sum=0. sua=0. do imu=1,nmu sum=sum+anu(imu,1)*angl(imu)*wang(imu) sua=sua+angl(imu)*wang(imu) end do C wlam=2.997925e18/freq(ij) WRITE(18,641) WLAM,flux(ij),sum,sua,(2.*ANU(IMU,1),IMU=1,NMU) 641 format(f11.3,(1p13e11.3)) c 500 continue nmu=nmuf c return end C C C **************************************************************** C C SUBROUTINE OPACF0(ID,NFRQ) C ========================== C C Absorption, emission, and scattering coefficients C at depth ID C C Input: ID opacity and emissivity is calculated for the C depth point ID C Output: ABSO - array of absorption coefficient C EMIS - array of emission coefficient C SCAT - array of scattering coefficient C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (FRH=3.28805E15, PH2=2.815D29*2., EHB=157802.77355) PARAMETER (CFF1=1.3727D-25,CFF2=4.3748D-10,CFF3=2.5993D-7) PARAMETER (C14=2.99793D14) PARAMETER (SGFF0 = 3.694D8) common/hmolab/anh2(mdepth),anhm(mdepth) DIMENSION FREDG(NLMX),S(NLMX),SUM(NLMX),PRF(MFREQL) C C initialize c C this part is analogous to TDPINI - for one depth only C T=TEMP(ID) T1=UN/T HKT1(ID)=HK*T1 HKT21(ID)=HKT1(ID)*T1 TK1(ID)=HKT1(ID)/H SQT1(ID)=SQRT(T) TEMP1(ID)=T1 CALL GFREE0(ID) EMEL1(ID)=UN LASER=ITER.GT.ITLAS c C this part is analogous to OPAINI - for one depth only C ANE=ELEC(ID) ELEC1(ID)=UN/ANE DENS1(ID)=UN/DENS(ID) DENSI(ID)=DENS1(ID) DENSIM(ID)=DENSI(ID)*WMM(ID) ELSCAT(ID)=ANE*SIGE if(izscal.eq.1) then densi(id)=un densim(id)=0. end if CALL DWNFR0(ID) CALL WNSTOR(ID) CALL SABOLF(ID) c c quantities for the bound-free opacity c DO IBFT=1,NTRANC ITR=ITRBF(IBFT) IF(INDEXP(ITR).NE.0) THEN II=ILOW(ITR) JJ=IUP(ITR) IT=ITRA(JJ,II) IE=IEL(II) NKE=NNEXT(IE) CORR=UN IF(NKE.NE.JJ) CORR=G(NKE)/G(JJ)* * EXP((ENION(NKE)-ENION(JJ))*TK1(ID)) ABTRA(ITR,ID)=POPUL(II,ID) EMTRA(ITR,ID)=POPUL(JJ,ID)*ANE*SBF(II)*WOP(II,ID)*CORR END IF END DO c c quantities for the free-free opacity c IF(IELHM.GT.0) THEN CFFN(ID)=POPUL(NFIRST(IELH),ID)*ANE CFFT(ID)=CFF2-CFF3/T END IF SGFF=SGFF0/SQT1(ID)*ANE DO ION=1,NION SFF2(ION,ID)=EXP(FF(ION)*HKT1(ID)) SFF3(ION,ID)=POPUL(NNEXT(ION),ID)*CHARG2(ION)*SGFF END DO c C this part is analogous to SGMER0 - for one depth only C IMER=0 DO II=1,NLEVEL IF(IFWOP(II).LT.0) THEN IMER=IMER+1 IMRG(II)=IMER IIMER(IMER)=II IE=IEL(II) CH=IZ(IE)*IZ(IE) FRCH(IMER)=FRH*CH SGM0(IMER)=PH2*CH*CH II0=NQUANT(II-1)+1 EX=EHB*CH*TEMP1(ID) DO I=II0,NLMX FREDG(I)=FRCH(IMER)*XI2(I) EXI=EXP(EX*XI2(I)) S(I)=EXI*WNHINT(I,ID)*XI3(I) SUM(I)=0. END DO SUM(NLMX)=S(NLMX) DO I=NLMX-1,II0,-1 SUM(I)=SUM(I+1)+S(I) END DO DO I=1,II0-1 SUM(I)=SUM(II0) END DO SGEM=SGM0(IMER)/GMER(IMER,ID) DO I=1,NLMX SGMSUM(I,IMER,ID)=SUM(I)*SGEM END DO END IF END DO C C initialization of the line opacity C IF(NFRQ.GT.NFREQC) THEN DO 10 ITR=1,NTRANS IF(.NOT.LINE(ITR)) GO TO 10 IF(INTMOD(ITR).EQ.0) GO TO 10 INDXA=IABS(INDEXP(ITR)) IJL0=IFR0(ITR) IJL1=IFR1(ITR) IF(ISPODF.GE.1) THEN IJL0=KFR0(ITR) IJL1=KFR1(ITR) END IF II=ILOW(ITR) JJ=IUP(ITR) IF(INDXA.LT.2.OR.INDXA.GT.4) THEN CALL LINPRO(ITR,ID,PRF) DO IJ=IJL0,IJL1 PRFLIN(ID,IJ)=real(PRF(IJ-IJL0+1)) END DO END IF 10 CONTINUE GG=G(II)/G(JJ) IF(IFWOP(JJ).GE.0) THEN PI=POPUL(II,ID)*WOP(JJ,ID) PJ=POPUL(JJ,ID)*WOP(II,ID)*GG ELSE PI=POPUL(II,ID) PJ=POPUL(JJ,ID)*WOP(II,ID)*G(II)/GMER(IMRG(JJ),ID) END IF ABTRA(ITR,ID)=PI EMTRA(ITR,ID)=PJ*EXP(FR0(ITR)*HKT1(ID)) IF(LASER) THEN qtt=0. if(pi.ne.pj) QTT=PJ/(PI-PJ)*(EXP(FR0(ITR)*HKT1(ID))-UN) lfr=fr0(itr).lt.frtabm.and.iadop(iatm(ii)).gt.0 IF(QTT.LT.0. .OR. QTT.GT.QTLAS .or. lfr) THEN ABTRA(ITR,ID)=0. EMTRA(ITR,ID)=0. END IF END IF END IF C C --------------------------------------------------------- C C loop over frequency points C ICALL=1 DO IJ=1,NFRQ if(icompt.gt.0) ELSCAT(ID)=ELEC(ID)*SIGEC(IJ) ABSO(IJ)=ELSCAT(ID) EMIS(IJ)=0. SCAT(IJ)=ELSCAT(ID) C C basic frequency- and depth-dependent quantities C FR=FREQ(IJ) FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) C C ******** 1. bound-free contribution C DO 30 IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) JJ=IUP(ITR) if(iadop(iatm(ii)).gt.0.and.fr.le.frtabm) go to 30 if(ifdiel.eq.0) then SG=CROSS(IBFT,IJ) else SG=CROSSD(IBFT,IJ,ID) endif IF(IFWOP(II).LT.0) THEN IMER=IMRG(II) CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SG=SGME1 END IF IF(SG.LE.0.) GO TO 30 IF(MCDW(ITR).GT.0) THEN IZZ=IZ(IEL(II)) CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SG=SG*DW1 END IF EMISBF=SG*EMTRA(ITR,ID) ABSO(IJ)=ABSO(IJ)+SG*ABTRA(ITR,ID) EMIS(IJ)=EMIS(IJ)+EMISBF 30 CONTINUE C C ******** 2. free-free contribution C DO 40 ION=1,NION IT=ITRA(NNEXT(ION),NNEXT(ION)) if(iadop(iatm(nnext(ioon))).gt.0.and.fr.le.frtabm) go to 40 C C hydrogenic with Gaunt factor = 1 C IF(IT.EQ.1) THEN SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) ABSOFF=SF1*SF2 ABSO(IJ)=ABSO(IJ)+ABSOFF EMIS(IJ)=EMIS(IJ)+ABSOFF C C hydrogenic with exact Gaunt factor C ELSE IF(IT.EQ.2) THEN SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) X=C14*CHARG2(ION)/FR SF2=SF2-UN+GFREE1(ID,X) ABSOFF=SF1*SF2 ABSO(IJ)=ABSO(IJ)+ABSOFF EMIS(IJ)=EMIS(IJ)+ABSOFF C C H minus free-free opacity C ELSE IF(IT.EQ.3) THEN c ABSOFF=(CFF1+CFFT(ID)*FRINV)*CFFN(ID)*FRINV ABSOFF=SFFHMI(POPUL(NFIRST(IELH),ID),FR,TEMP(ID))* * ELEC(ID) ABSO(IJ)=ABSO(IJ)+ABSOFF EMIS(IJ)=EMIS(IJ)+ABSOFF C C special evaluation of the cross-section C ELSE IF(IT.LT.0) THEN ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)* * POPUL(NNEXT(ION),ID)*ELEC(ID) ABSO(IJ)=ABSO(IJ)+ABSOFF EMIS(IJ)=EMIS(IJ)+ABSOFF END IF 40 CONTINUE C C ******** 3. - additional continuum opacity (OPADD) C IF(IOPADD.NE.0) THEN CALL OPADD(0,ICALL,IJ,ID) ABSO(IJ)=ABSO(IJ)+ABAD EMIS(IJ)=EMIS(IJ)+EMAD SCAT(IJ)=SCAT(IJ)+SCAD END IF C C ******** 4. - opacity and emissivity in lines C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) iad=iadop(iatm(ilow(itr))) if(iad.eq.0.or.(lfre.and.iad.gt.0)) then SG=PRFLIN(ID,IJ) ABSO(IJ)=ABSO(IJ)+SG*ABTRA(ITR,ID) EMIS(IJ)=EMIS(IJ)+SG*EMTRA(ITR,ID) end if END IF IF(NLINES(IJ).LE.0) GO TO 110 C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 100 if(linexp(itr)) go to 100 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 X=UN/(FREQ(IJ1)-FREQ(IJ0)) A1=(FR-FREQ(IJ0))*X X=UN/(FREQ(IJ1)-FREQ(IJ0)) A2=(FREQ(IJ1)-FR)*X SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) ABSO(IJ)=ABSO(IJ)+SG*ABTRA(ITR,ID) EMIS(IJ)=EMIS(IJ)+SG*EMTRA(ITR,ID) 100 CONTINUE 110 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 400 DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 300 KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO ID=1,ND SG=PRFLIN(ID,KJ) ABSO(IJ)=ABSO(IJ)+SG*ABTRA(ITR,ID) EMIS(IJ)=EMIS(IJ)+SG*EMTRA(ITR,ID) END DO ELSE DO ID=1,ND KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))* * SIGFE(KJD+1,KJ)) ABSO(IJ)=ABSO(IJ)+SG*ABTRA(ITR,ID) EMIS(IJ)=EMIS(IJ)+SG*EMTRA(ITR,ID) END DO END IF 300 CONTINUE 400 CONTINUE END IF C C ---------------------------- C total opacity and emissivity C ---------------------------- C ABSO(IJ)=ABSO(IJ)-EMIS(IJ)*XKF(ID) EMIS(IJ)=EMIS(IJ)*XKFB(ID) c c -------------------------------------------------------- c contribution from precalculated background opacity table c --------------------------------------------------------` c if(ioptab.gt.0) then call opact1(ij) end if c END DO RETURN END C C C **************************************************************** C C SUBROUTINE SRTFRQ C ================= C C Sort the frequency sets, and assign to each frequency C a list of contributing transitions C Select final frequency set. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (SIXTH=UN/6.,FTH=4./3.,V0X=4.D-4,VCX=10.*V0X) DIMENSION SX(500) C DIMENSION SGZ(MTRANS) C if(ioptab.lt.0) return if(ispodf.ge.1) return C C Sort frequencies and assign primary line C CALL INDEXX(NFREQ,FREQ,NLINES) DO IJ=1,NFREQ KIJ(NLINES(IJ))=NFREQ-IJ+1 END DO DO IT=1,NTRANS IF(.NOT.LINEXP(IT)) THEN KFR0(IT)=KIJ(IFR0(IT)) KFR1(IT)=KIJ(IFR1(IT)) DO IJ=IFR0(IT),IFR1(IT) IJLIN(IJ)=IT END DO END IF END DO DO IJ=1,NFREQ JIK(KIJ(IJ))=IJ END DO JK1=JIK(1) IF(IJLIN(JK1).NE.0) * CALL QUIT(' Largest freq. is a line freq. - (SRTFRQ)', * JK1,IJLIN(JK1)) JK1=JIK(NFREQ) IF(IJLIN(JK1).NE.0) * CALL QUIT(' Smallest freq. is a line freq. - (SRTFRQ)', * JK1,IJLIN(JK1)) C C lines or ODFs associated with each frequency C NLIMAX=0 DO IJ=1,NFREQ NLINES(IJ)=0 DO 50 IT=1,NTRANS IF(LINEXP(IT)) GO TO 50 IF(KIJ(IJ).LT.KFR0(IT)) GO TO 50 IF(KIJ(IJ).GT.KFR1(IT)) GO TO 50 IF(IJLIN(IJ).EQ.IT) GOTO 50 NLINES(IJ)=NLINES(IJ)+1 IF(NLINES(IJ).GT.MITJ) * CALL QUIT('Too many overlappins-nlines(ij).gt.mitj', * nlines(ij),mitj) ITRLIN(NLINES(IJ),IJ)=int2(IT) c write(6,653) ij,it,nlines(ij) c 653 format('nlines',3i7) 50 CONTINUE IF(NLINES(IJ).GT.NLIMAX) NLIMAX=NLINES(IJ) END DO WRITE(6,611) NLIMAX 611 FORMAT(/' MAXIMUM NUMBER OF OVERLAPPING TRANSITIONS: ',I3/) C C Select final set of frequencies: C IJX = 1 : included frequency C IJX =-1 : rejected frequency C IJX = 0 : used for rates, but no contribution of primary C transition to opacity C NPPX=NFREQ-NFREQC DO 310 IT=1,NTRANS IF(LINEXP(IT)) GO TO 310 IF(ABS(INDEXP(IT)).NE.3) GO TO 310 IF(PROF(IFR0(IT)+1).GT.PROF(IFR1(IT)-1)) THEN DO IJ=IFR0(IT)+5,IFR1(IT)-1 IJX(IJ)=-1 NPPX=NPPX-1 END DO ELSE DO IJ=IFR0(IT)+1,IFR1(IT)-5 IJX(IJ)=-1 NPPX=NPPX-1 END DO END IF 310 CONTINUE ISX=0 DO 320 IJ=1,NFREQ ISX=ISX-1 IF(ISX.GT.0) GO TO 320 IJP=JIK(IJ) DX0=0. IF(IJX(IJP).EQ.1) GO TO 320 IF(PROF(IJP).EQ.0.) GO TO 320 DX0=V0X*FREQ(IJP) DNUX=ABS(FREQ(JIK(IJ-1))-FREQ(IJP)) IF(DNUX.GT.DX0) THEN IJX(IJP)=1 NPPX=NPPX+1 ELSE NPX=0 DO WHILE (DNUX.LT.DX0 .AND. IJX(JIK(IJ+NPX)).EQ.-1) ITRX=IJLIN(JIK(IJ+NPX)) PSX0=PROF(IFR0(ITRX+1)) IF(PSX0.GT.0.) THEN SX0=PROF(JIK(IJ+NPX))/PSX0 SX(NPX+1)=PROF(JIK(IJ+NPX))/PROF(IJP)*SX0 ELSE SX(NPX+1)=0. ENDIF NPX=NPX+1 DNUX=ABS(FREQ(JIK(IJ-1))-FREQ(JIK(IJ+NPX))) END DO IF(NPX.EQ.1) THEN IJX(IJP)=1 NPPX=NPPX+1 ELSE SXX=-1. DO IPX=1,NPX IF(SX(IPX).GT.SXX) THEN SXX=SX(IPX) ISX=IPX END IF END DO IJX(JIK(IJ+ISX))=1 NPPX=NPPX+1 END IF END IF 320 CONTINUE DO 330 IJ=1,NFREQ IJP=JIK(IJ) IF(IJP.GT.NFREQC) GOTO 330 IF(IJX(IJP).EQ.1) THEN NPPX=NPPX+1 GOTO 330 ENDIF DX0=VCX*FREQ(IJP) NIXA=0 DO WHILE (IJX(JIK(IJ-NIXA)).NE.1) NIXA=NIXA+1 ENDDO NIXB=0 DO WHILE (IJX(JIK(IJ+NIXB)).NE.1) NIXB=NIXB+1 ENDDO DNUXA=ABS(FREQ(JIK(IJ-NIXA))-FREQ(IJP)) DNUXB=ABS(FREQ(JIK(IJ+NIXB))-FREQ(IJP)) IF(DNUXA.GT.DX0 .AND. DNUXB.GT.DX0) THEN IJX(IJP)=1 NPPX=NPPX+1 ELSE IJX(IJP)=-1 ENDIF 330 CONTINUE c c correction c if(icompt.eq.0) then do ij=1,nfreqc ijx(ij)=1 end do do ije=1,nfreqe ijx(ijfr(ije))=1 end do end if C C weights C DO 100 IJ=1,NFREQ W(IJ)=0. KJ0=KIJ(IJ) IF(IJX(JIK(KJ0)).EQ.-1) GO TO 100 IF(KJ0.GE.2 .AND. KJ0.LT.NFREQ) THEN IK1=KJ0-1 DO WHILE (IJX(JIK(IK1)).EQ.-1) IK1=IK1-1 END DO IK2=KJ0+1 DO WHILE (IJX(JIK(IK2)).EQ.-1) IK2=IK2+1 END DO W(IJ)=HALF*ABS(FREQ(JIK(IK1))-FREQ(JIK(IK2))) ELSE IF(KJ0.EQ.1) THEN W(IJ)=HALF*ABS(FREQ(JIK(KJ0))-FREQ(JIK(KJ0+1))) ELSE IF(KJ0.EQ.NFREQ) THEN W(IJ)=HALF*ABS(FREQ(JIK(KJ0-1))-FREQ(JIK(KJ0))) END IF 100 CONTINUE C C Correction for Simpson weights C JK1=JIK(1) DO IJ=2,NFREQ,2 JK2=JIK(IJ) JK3=JIK(IJ+1) IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GO TO 130 IF(WCH(JK2).NE.0.) GO TO 130 W(JK1)=W(JK1)-SIXTH*W(JK2) W(JK3)=W(JK3)-SIXTH*W(JK2) W(JK2)=W(JK2)*FTH JK1=JK3 END DO 130 JK1=JIK(NFREQ) DO IJ=NFREQ-1,3,-2 JK2=JIK(IJ) JK3=JIK(IJ-1) IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GOTO 150 IF(WCH(JK2).NE.0.) GOTO 150 W(JK1)=W(JK1)-SIXTH*W(JK2) W(JK3)=W(JK3)-SIXTH*W(JK2) W(JK2)=W(JK2)*FTH JK1=JK3 END DO 150 CONTINUE C C check accuracy of weights for integration C c 190 Z0=0. Z0=0. Z1=0. Z2=0. ZH=0. T1=TEFF T2=TWO*TEFF T3=HALF*TEFF X1=HK/T1 X2=HK/T2 X3=HK/T3 DO IJ=1,NFREQ Z0=Z0+W(IJ) X15=FREQ(IJ)*1.D-15 BNZ=BN*X15*X15*X15 FX1=FREQ(IJ)*X1 IF(FX1.LE.100.) THEN Z1=Z1+W(IJ)*BNZ/(EXP(FREQ(IJ)*X1)-1) Z2=Z2+W(IJ)*BNZ/(EXP(FREQ(IJ)*X2)-1) ZH=ZH+W(IJ)*BNZ/(EXP(FREQ(IJ)*X3)-1) END IF END DO T1S=SQRT(SQRT(0.25*Z1/SIG4P)) T1ER=T1S/T1-UN T2S=SQRT(SQRT(0.25*Z2/SIG4P)) T2ER=T2S/T2-UN T3S=SQRT(SQRT(0.25*ZH/SIG4P)) T3ER=T3S/T3-UN JK1=JIK(1) JK2=JIK(NFREQ) Z00=FREQ(JK1)-FREQ(JK2) WRITE(6,601) FREQ(JK1),FREQ(JK2),Z00,Z0,T3,T3ER,T1,T1ER,T2,T2ER 601 FORMAT(/' ACCURACY OF INTEGRATIONS:',/, * ' Interval:',1p4e16.8,/, * 15x,' Planck functions:',9x,0pf12.0,4x,1pe12.4,/, * 42x,0pf12.0,4x,1pe12.4,/,42x,0pf12.0,4x,1pe12.4,/) WRITE(6,602) NFREQ,NPPX 602 FORMAT(' TOTAL NUMBER OF FREQUENCIES:',I8,/, * ' SELECTED FREQUENCIES: ',I8) C RETURN END C C C **************************************************************** C C SUBROUTINE INIFRC(IALIEX) C ========================= C C Setup continuum frequencies, including frequencies around C ionization limits C IALIEX=0 : setup frequencies, all ALI C IALIEX=1 : change IJALI for explicit frequencies C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' common/ijflar/ijfl(mlevel) PARAMETER (THIRD=UN/3.,FTH=4./3.,TENLG = 2.302585093) DIMENSION FRLEV(MLEVEL),IENS(MLEVEL),IJXCO(MFREQC), * FREQCO(MFREQC),WCO(MFREQC),WCHCO(MFREQC) C if(ioptab.lt.0) return C dfedg=0.000001 if(icompt.gt.0) dfedg=0.01 DFEDG=0.01 IF(IALIEX.EQ.1) THEN C if(nffix.lt.0) then do ij=1,nfreqc ijali(ij)=0 end do return end if c IF(NFFIX.EQ.2) RETURN DO 10 IT=1,NTRANS IF(LINE(IT)) GOTO 10 IF(IFC1(IT).EQ.0) GOTO 10 if(iadop(iatm(ilow(it))).gt.0) go to 10 IJFL0=IJFL(ILOW(IT))+1 IF(IFC1(IT).LT.100) THEN DO IJ=IFC0(IT),IFC1(IT) IJFLS=IJFL0-IJ IF(IJFLS.GE.1) THEN IJALI(IJFLS)=0 IJX(IJFLS)=1 END IF END DO ELSE DO IJ=IJFL0,1,-1 IJALI(IJ)=0 IJX(IJ)=1 END DO END IF 10 CONTINUE C IF(ICOMPT.GT.0.AND.FRLCOM.GT.0) THEN DO IJ=1,NFREQ IF(FREQ(IJ).GT.FRLCOM) THEN IJALI(IJ)=0 IJX(IJ)=1 END IF END DO END IF RETURN END IF C NEND=NFTAIL DIVEND=DFTAIL NJC=NFREQC/5 DNX=UN-UN/FLOAT(NJC) CALL INDEXX(NLEVEL,ENION,IENS) DO IL=1,NLEVEL ILS=IENS(NLEVEL-IL+1) FRLEV(IL)=ENION(ILS)/H IJFL(IL)=0 END DO IF(FRCMAX.LE.0.) THEN FREQCO(1)=8.D11*TEFF ELSE FREQCO(1)=FRCMAX END IF IL0=1 IF(FREQCO(1).LT.CFRMAX*FRLEV(IL0) .AND. CFRMAX.GT.UN) THEN FREQCO(1)=CFRMAX*FRLEV(IL0) GO TO 20 END IF DO WHILE (FREQCO(1).LT.FRLEV(IL0) .AND. IL0.LT.NLEVEL) ILS=IENS(NLEVEL-IL0+1) ILN=NNEXT(IEL(ILS)) ITR0=ITRA(ILS,ILN) INDEXP(ITR0)=0 IFR0(ITR0)=0 IFR1(ITR0)=0 IF(FRLEV(IL0).GT.0.) WRITE(10,159) IL0,FRLEV(IL0),ILS,ILN,ITR0 159 FORMAT(' Edge at frequency larger than FRCMAX',I5,E12.4,3I7) IL0=IL0+1 END DO 20 CONTINUE C if(nftail.le.0) then if(nftail.eq.-1.or.dftail.eq.0.) then NEND1=NFREQC FREQCO(NEND1)=FRCMIN IJXCO(1)=1 IJXCO(NEND1)=1 XEND=UN/FLOAT(NEND1-1) D121=(FREQCO(1)/FREQCO(NEND1))**XEND DO IJ=2,NEND1-1 FREQCO(IJ)=FREQCO(IJ-1)/D121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(1)-FREQCO(2)) DO IJ=2,NEND1-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO else c NEND1=-NFTAIL FREQCO(NEND1)=DFTAIL*FREQCO(1) IJXCO(1)=1 IJXCO(NEND1)=1 XEND=UN/FLOAT(NEND1-1) D121=(FREQCO(1)/FREQCO(NEND1))**XEND DO IJ=2,NEND1-1 FREQCO(IJ)=FREQCO(IJ-1)/D121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(1)-FREQCO(2)) DO IJ=2,NEND1-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO C NEND2=NFREQC IJXCO(NEND1)=1 IJXCO(NEND1+1)=1 XEND=UN/FLOAT(NEND2-NEND1) d121=(freqco(nend1)/frcmin)**xend DO IJ=NEND1+1,NEND2 freqco(ij)=freqco(ij-1)/d121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(NEND1)-FREQCO(NEND1+1)) DO IJ=NEND1+1,NEND2-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO end if C else C NEND=NFTAIL DIVEND=DFTAIL NJC=NFREQC/5 DNX=UN-UN/FLOAT(NJC) NFREQC=NEND+1 FREQCO(NEND)=(un+dfedg)*FRLEV(il0) FREQCO(NEND+1)=(un-dfedg)*FRLEV(il0) NEND1=NEND/2+1 XEND=UN/FLOAT(NEND1-1) FREQCO(NEND1)=FREQCO(1)-(UN-DIVEND)*(FREQCO(1)-FREQCO(NEND)) IJXCO(NEND+1)=1 C C high-frequency tail of the spectrum - a two-part Simpson integration C C 1st part - from the highest frequency FRCMAX to a division freq. C IJXCO(1)=1 IJXCO(NEND1)=1 D121=XEND*(FREQCO(1)-FREQCO(NEND1)) if(icompt.gt.0) d121=(freqco(1)/freqco(nend1))**xend DO IJ=2,NEND1-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 if(icompt.gt.0) freqco(ij)=freqco(ij-1)/d121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(1)-FREQCO(2)) DO IJ=2,NEND1-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO C C 2nd part - from the division freq to the first discontinuity C if(nend1.lt.nend) then IJXCO(NEND)=1 IJXCO(NEND+1)=1 D121=XEND*(FREQCO(NEND1)-FREQCO(NEND)) if(icompt.gt.0) d121=(freqco(nend1)/freqco(nend))**xend DO IJ=NEND1+1,NEND-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 if(icompt.gt.0) freqco(ij)=freqco(ij-1)/d121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(NEND1)-FREQCO(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO end if C C the 1st discontinuity - the one with the highest frequency C HAEND=HALF*(FREQCO(NEND)-FREQCO(NEND+1)) XEND=UN/FLOAT(NEND-1) WCO(NEND)=WCO(NEND)+HAEND WCO(NEND+1)=WCO(NEND+1)+HAEND WCHCO(1)=0. WCHCO(NEND)=HAEND ILS=IENS(NLEVEL) IJFL(ILS)=NEND write(*,*) 'ils,ijfl',ils,ijfl(ils),freqco(nend) IL0=NLEVEL IF(FRCMIN.LE.0.) FRCMIN=1.D12 FRCLST=FRLEV(IL0) DO WHILE(FRCLST.LT.FRCMIN) IF(FRLEV(IL0).GT.0.) WRITE(10,160) IL0,FRLEV(IL0) 160 FORMAT(' Edge at frequency smaller than 1.d12',i5,e12.4) IL0=IL0-1 FRCLST=FRLEV(IL0) END DO IL0=2 C 100 FRC0=DNX*FREQCO(NFREQC) IF(FRC0.LT.FRCLST) THEN NFREQC=NFREQC+2 FREQCO(NFREQC-1)=(un+dfedg)*FRCLST FREQCO(NFREQC)=(un-dfedg)*FRCLST IJXCO(NFREQC-1)=1 IJXCO(NFREQC)=1 WCO(NFREQC)=WCO(NFREQC)+ * HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC)) WCO(NFREQC-2)=WCO(NFREQC-2)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-2)=HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IF(IL0.LT.NLEVEL) THEN DO IL=IL0+1,NLEVEL ILS=IENS(NLEVEL-IL+1) IJFL(ILS)=NFREQC-1 IF(FRLEV(IL).LT.FRCMIN) IJFL(ILS)=0 END DO END IF D121=XEND*(FREQCO(NFREQC)-FRCMIN) DO IJ=NFREQC+1,NFREQC+NEND-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 IJXCO(IJ)=2 WCHCO(IJ)=0. END DO IJXCO(NFREQC+NEND-1)=1 DO IJ=NFREQC+1,NFREQC+NEND-2,2 WCO(IJ)=FTH*D121 WCO(IJ-1)=WCO(IJ-1)+THIRD*D121 WCO(IJ+1)=WCO(IJ+1)+THIRD*D121 END DO WCHCO(NFREQC)=THIRD*D121 NFREQC=NFREQC+NEND-1 GO TO 200 END IF DF0=FRLEV(IL0)+0.1*(FREQCO(NFREQC)-FRC0) FRTL=(un+dfedg)*FRLEV(IL0) IF(FRC0.GT.DF0) THEN NFREQC=NFREQC+1 FREQCO(NFREQC)=FRC0 IJXCO(NFREQC)=2 WCO(NFREQC)=WCO(NFREQC)+ * HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) ELSE IF(FRTL.LT.FREQCO(NFREQC)) THEN NFREQC=NFREQC+2 FREQCO(NFREQC-1)=FRTL FREQCO(NFREQC)=(un-dfedg)*FRLEV(IL0) IJXCO(NFREQC-1)=1 IJXCO(NFREQC)=1 WCO(NFREQC)=WCO(NFREQC)+ * HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC)) WCO(NFREQC-2)=WCO(NFREQC-2)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-2)=HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IL0=IL0+1 ELSE ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IL0=IL0+1 END IF GO TO 100 end if C 200 SUMWC=0. C IF(NFREAD.GT.0) THEN DO IJ=NFREQ,1,-1 FREQ(IJ+NFREQC)=FREQ(IJ) W(IJ+NFREQC)=W(IJ) PROF(IJ+NFREQC)=PROF(IJ) IJALI(IJ+NFREQC)=IJALI(IJ) END DO DO IJ=1,NFREQC FREQ(IJ)=FREQCO(IJ) W(IJ)=WCO(IJ) WCH(IJ)=WCHCO(IJ) IJALI(IJ)=1 IJX(IJ)=IJXCO(IJ) PROF(IJ)=0. END DO DO 320 ITR=1,NTRANS IF(.NOT.LINE(ITR).OR.INDEXP(ITR).EQ.0) GO TO 320 IF(IFR0(ITR).GT.0) IFR0(ITR)=IFR0(ITR)+NFREQC IF(IFR1(ITR).GT.0) IFR1(ITR)=IFR1(ITR)+NFREQC 320 CONTINUE NFREQ=NFREQ+NFREQC END IF C C determination of the first (IFR0) and the last (IFR1) frequency C for each explicit continuum - only if they were not already read C DO 340 ITR=1,NTRANS IF(LINE(ITR)) GO TO 340 IF(IFR0(ITR).LE.0) IFR0(ITR)=1 IF(IFR1(ITR).GT.0) GO TO 340 IF1=0 FR01=FR0(ITR) MODE=INDEXP(ITR) IF(IABS(MODE).EQ.5.OR.IABS(MODE).EQ.15) FR01=FR0PC(ITR) DO 330 IJ=1,NFREQC IF(FREQ(IJ).GE.FR01) IF1=IJ 330 CONTINUE IFR1(ITR)=IF1 340 CONTINUE if(nfrecl.gt.nfreq) nfrecl=nfreq nfreqe=nfrecl do ij=1,nfreqe ijali(ij)=0 end do c RETURN END C C C **************************************************************** C C SUBROUTINE INIFRS C ================= C C Setup frequencies in opacity sampling mode C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (THIRD=UN/3.,FTH=4./3.) DIMENSION FRLEV(MLEVEL),IENS(MLEVEL),ITRL(MLEVEL) DIMENSION FRL0(MTRANS),FRL1(MTRANS),FRLC(5*MTRANS) DIMENSION IKC(5*MTRANS),ITKC(5*MTRANS),ITJNU(5*MTRANS) DIMENSION FLNU(2*MATOM+3),DLNU(2*MATOM+3),ILNU(2*MATOM+3) DIMENSION XMASS(30) DATA XMASS/ 1.008, 4.003, 6.941, 9.012,10.810,12.011,14.007, & 16.000,18.918,20.179,22.990,24.305,26.982,28.086, & 30.974,32.060,35.453,39.948,39.098,40.080,44.956, & 47.900,50.941,51.996,54.938,55.847,58.933,58.700, & 63.546,65.380/ C IF(TSNU.EQ.0.) TSNU=TEFF IF(VTNU.EQ.0.) VTNU=VTB IF(VTNU.LT.1.D4) VTNU=VTNU*1.D5 FRS1=CNU1*1.D11*TSNU FRS2=3.28805D15/CNU2/CNU2 C DO IAT=1,NATOM CDOP=TWO*BOLK/AMASS(IAT) DLNU(IAT)=0.375/2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) DLNU(IAT+NATOM)=20.*DLNU(IAT) FLNU(IAT)=DLOG(FRS1) FLNU(IAT+NATOM)=DLOG(FRS1) END DO C XPNU=24. CDOP=TWO*BOLK/XMASS(1)/HMASS DLNU(2*NATOM+1)=50./2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) DLNU(2*NATOM+2)=5.*DLNU(2*NATOM+1) FLNU(2*NATOM+1)=DLOG(FRS2) FLNU(2*NATOM+2)=DLOG(FRCMIN) NNU=2*NATOM+3 IF(ISPODF.EQ.1 .AND. DDNU.GT.0.) THEN CDOP=TWO*BOLK/AMASS(NATOM) IF(IELNU.GT.0) CDOP=TWO*BOLK/XMASS(IELNU)/HMASS DLNU(NNU)=DDNU/2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) FLNU(NNU)=DLOG(FRS2) ELSE DLNU(NNU)=DLNU(2*NATOM+2) FLNU(NNU)=DLOG(FRS1) END IF CALL INDEXX(NNU,DLNU,ILNU) C C Store line and continua frequencies C NLIC=0 DO 10 ITR=1,NTRANS IJTC(ITR)=0 INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.EQ.0) GO TO 10 IF(INDXPA.EQ.3 .OR. INDXPA.EQ.4) GO TO 10 IF(FR0(ITR).EQ.0.) GO TO 10 IF(LINE(ITR)) THEN ILV0=ILOW(ITR) IAT=IATM(ILV0) ITC=ITRA(ILV0,NNEXT(IEL(ILV0))) IF(ITC.EQ.0) ITC=ITRA(ILV0,NNEXT(IEL(ILV0))+1) IF(INDXPA.NE.2) THEN FRLC(NLIC+1)=FR0(ITR) ITKC(NLIC+1)=ITR IJTC(ITR)=NLIC+1 ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=FREQ(IFR0(ITR)) FRL0(ITR)=FRLC(NLIC+2) ITKC(NLIC+2)=ITR IF(ITC.GT.0 .AND. FREQ(IFR0(ITR)).GT.FR0(ITC) .AND. * FR0(ITC).GT.FR0(ITR)) FRLC(NLIC+2)=0.999999*FR0(ITC) ITJNU(NLIC+2)=IAT FRLC(NLIC+3)=FREQ(IFR1(ITR)) FRL1(ITR)=FRLC(NLIC+3) ITKC(NLIC+3)=ITR ITJNU(NLIC+3)=2*NATOM+1 NLIC=NLIC+3 D0=DLOG(FRL0(ITR))-DLOG(FRL1(ITR)) IF(D0.GT.XPNU*DLNU(IAT)) THEN ITJNU(NLIC-1)=IAT+NATOM FRLC(NLIC+1)=EXP(DLOG(FR0(ITR))+XPNU*DLNU(IAT)) ITKC(NLIC+1)=ITR ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=EXP(DLOG(FR0(ITR))-XPNU*DLNU(IAT)) ITKC(NLIC+2)=ITR ITJNU(NLIC+2)=IAT+NATOM NLIC=NLIC+2 END IF ELSE FRLC(NLIC+1)=0.999999*FR0(ITC) FRL0(ITR)=FRLC(NLIC+1) ITKC(NLIC+1)=ITR ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=FREQ(IFR1(ITR-1)) FRL1(ITR)=FRLC(NLIC+2) ITKC(NLIC+2)=ITR ITJNU(NLIC+2)=2*NATOM+1 NLIC=NLIC+2 END IF ELSE NLIC=NLIC+1 FRLC(NLIC)=FR0(ITR) ITKC(NLIC)=ITR IJTC(ITR)=NLIC ITJNU(NLIC)=0 END IF 10 CONTINUE C IKC(1)=1 IF(NLIC.GT.1) CALL INDEXX(NLIC,FRLC,IKC) DO IJ=1,MFREQ FREQ(IJ)=0. W(IJ)=0. WCH(IJ)=0. NLINES(IJ)=0 END DO C C Sort continuum limits C CALL INDEXX(NLEVEL,ENION,IENS) DO IL=1,NLEVEL ILS=IENS(NLEVEL-IL+1) FRLEV(IL)=ENION(ILS)/H ITRL(IL)=ITRA(ILS,NNEXT(IEL(ILS))) END DO IF(FRCMAX.LT.1.01*FRLEV(1) .AND. FRCMAX.GT.0.) THEN ILS=IENS(NLEVEL) ILN=NNEXT(IEL(ILS)) ITR0=ITRA(ILS,ILN) WRITE(10,640) FRLEV(1),ILS,ILN,ITR0 640 FORMAT(1PE12.4,3I7) CALL QUIT(' Edge at frequency larger than FRCMAX; ii,itr:', * ils,itr0) END IF C C Highest frequency tail C IF(FRCMAX.LE.0.) FRCMAX=FRLEV(1)*CFRMAX IF(FRS1.GT.FRCMAX) THEN FRCMAX=FRS1 NFTAIL=0 END IF IF(NFTAIL.GT.0) THEN NFTA1=NFTAIL/2+1 FREQ(1)=FRCMAX NEND=0 IL=1 KJ=1 DO WHILE(FRLEV(IL).GT.FRS1) NEND1=NEND+NFTA1 NEND=NEND+NFTAIL ITR=ITRL(IL) IFR0(ITR)=1 IFR1(ITR)=NEND FREQ(NEND)=1.000001*FRLEV(IL) FREQ(NEND+1)=0.999999*FRLEV(IL) FREQ(NEND1)=FREQ(KJ)-(UN-DFTAIL)*(FREQ(KJ)-FREQ(NEND)) XEND=UN/FLOAT(NFTA1-1) D121=XEND*(FREQ(KJ)-FREQ(NEND1)) DO IJ=KJ+1,NEND1-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(KJ)-FREQ(KJ+1)) DO IJ=KJ+1,NEND1-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=XEND*(FREQ(NEND1)-FREQ(NEND)) DO IJ=NEND1+1,NEND-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(NEND1)-FREQ(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=HALF*(FREQ(NEND)-FREQ(NEND+1)) W(NEND)=W(NEND)+D121 W(NEND+1)=W(NEND+1)+D121 IL=IL+1 KJ=NEND+1 END DO NEND1=NEND+NFTA1 NEND=NEND+NFTAIL FREQ(NEND)=FRS1 FREQ(NEND1)=FREQ(KJ)-(UN-DFTAIL)*(FREQ(KJ)-FREQ(NEND)) XEND=UN/FLOAT(NFTA1-1) D121=XEND*(FREQ(KJ)-FREQ(NEND1)) DO IJ=KJ+1,NEND1-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(KJ)-FREQ(KJ+1)) DO IJ=KJ+1,NEND1-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=XEND*(FREQ(NEND1)-FREQ(NEND)) DO IJ=NEND1+1,NEND-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(NEND1)-FREQ(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO ELSE FREQ(1)=FRS1 NEND=1 END IF NFREQC=NEND DO IJ=1,NFREQC IFREQB(IJ)=IJ END DO NFRS1=NFREQC C C Setup frequency points C DO IT=1,NTRANS IFR0(IT)=0 IFR1(IT)=0 END DO C IL=NLIC DO WHILE(FRLC(IKC(IL)).GT.FRS1) IL=IL-1 END DO NFREQ=NEND XFRA=DLOG(FRS1) DO WHILE(IL.GT.0) ITR=ITKC(IKC(IL)) NFS=0 XFRB=DLOG(FRLC(IKC(IL))) IF(XFRA.GT.XFRB) THEN IKNU=ITJNU(IKC(IL)) IDN=1 DO WHILE(FLNU(ILNU(IDN)).GE.XFRA .AND. IDN.LT.NNU) IDN=IDN+1 END DO DXNU=DLNU(ILNU(IDN)) IF(IKNU.EQ.0) XFRB=DLOG(1.000001*FRLC(IKC(IL))) NFS=INT((XFRA-XFRB)/DXNU)+1 XFS0=(XFRA-XFRB)/FLOAT(NFS) DO IJ=NFREQ+1,NFREQ+NFS XFR=DLOG(FREQ(IJ-1))-XFS0 FREQ(IJ)=EXP(XFR) END DO NFREQ=NFREQ+NFS IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ IF(IKNU.EQ.0) THEN IFR0(ITR)=1 IFR1(ITR)=NFREQ NFREQ=NFREQ+1 FREQ(NFREQ)=0.999999*FRLC(IKC(IL)) XFRB=DLOG(FREQ(NFREQ)) ELSE IF(IKNU.LE.2*NATOM) THEN IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ D0=DLOG(FR0(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 IF(IABS(INDEXP(ITR)).EQ.2) THEN D0=DLOG(FR0(ITR-1)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF ELSE IFR1(ITR)=NFREQ IF(IKNU.LE.NATOM) THEN IAT=IATM(ILOW(ITR)) D0=DLOG(FR0(ITR))-XPNU*DLNU(IAT) D1=DLOG(FRL1(ITR)) IF(D1.GT.D0) D0=D1 IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 ELSE D0=DLOG(FRL1(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF END IF ELSE IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ ELSE IFR1(ITR)=NFREQ END IF END IF ELSE IF(XFRA.EQ.XFRB) THEN IKNU=ITJNU(IKC(IL)) IF(IKNU.EQ.0) THEN FREQ(NFREQ)=1.000001*FRLC(IKC(IL)) FREQ(NFREQ+1)=0.999999*FRLC(IKC(IL)) IFR0(ITR)=1 IFR1(ITR)=NFREQ NFREQ=NFREQ+1 XFRB=DLOG(FREQ(NFREQ)) ELSE IF(IKNU.LE.2*NATOM) THEN IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ D0=DLOG(FR0(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 IF(IABS(INDEXP(ITR)).EQ.2) THEN D0=DLOG(FR0(ITR-1)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF ELSE IFR1(ITR)=NFREQ IF(IKNU.LE.NATOM) THEN IAT=IATM(ILOW(ITR)) D0=DLOG(FR0(ITR))-XPNU*DLNU(IAT) D1=DLOG(FRL1(ITR)) IF(D1.GT.D0) D0=D1 IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 ELSE D0=DLOG(FRL1(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ END IF ELSE IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ ELSE IFR1(ITR)=NFREQ IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ END IF END IF END IF IL=IL-1 XFRA=XFRB IF(XPNU.EQ.24. .AND. FREQ(NFREQ).LT.FRS2) THEN XPNU=HALF*XPNU DO IAT=1,NATOM DLNU(IAT)=TWO*DLNU(IAT) DLNU(IAT+NATOM)=TWO*DLNU(IAT+NATOM) END DO END IF END DO C XFRB=DLOG(FRCMIN) IF(XFRA.GT.XFRB) THEN DXNU=DLNU(NNU-1) NFS=INT((XFRA-XFRB)/DXNU)+1 XFS0=(XFRA-XFRB)/FLOAT(NFS) DO IJ=NFREQ+1,NFREQ+NFS XFR=DLOG(FREQ(IJ-1))-XFS0 FREQ(IJ)=EXP(XFR) END DO NFREQ=NFREQ+NFS END IF FREQ(NFREQ)=FRCMIN DO 20 ITR=1,NTRANS IF(LINEXP(ITR)) GO TO 20 DO IJ=IFR0(ITR),IFR1(ITR) NLINES(IJ)=NLINES(IJ)+1 END DO 20 CONTINUE C C Choose continuum frequency points in the global set C FRLEV(NLEVEL+1)=FRCMIN IL=1 DO WHILE(FRLEV(IL).GT.FRS1) IL=IL+1 END DO IB0=NFRS1 NUB=2*NATOM+1 XFRA=DLOG(FRS1) DO WHILE(IL.LE.NLEVEL+1) IF(FRLEV(IL).LT.FRCMIN) GO TO 490 IF(IL.GT.1 .AND. IL.LE.NLEVEL) THEN IF(FRLEV(IL).GE.FRLEV(IL-1)) GO TO 490 END IF IF(IL.LE.NLEVEL) ITR=ITRL(IL) FRLV0=FRLEV(IL) IB1=IB0 DO WHILE(FREQ(IB1).GT.FRLV0) IB1=IB1+1 XFRB=DLOG(FREQ(IB1)) IF(IFREQB(NFREQC).LT.IB1) THEN IF(NLINES(IB1).EQ.0 .AND. ISPODF.GT.1) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 XFRA=XFRB ELSE IF((XFRA-XFRB).GT.DLNU(NUB)) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 XFRA=XFRB END IF END IF END DO IF(IL.LE.NLEVEL) THEN IFR0(ITR)=1 IFR1(ITR)=IB1-1 IJTC(ITR)=IFR1(ITR) END IF IF(IFREQB(NFREQC).LT.(IB1-1)) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1-1 END IF IF(IFREQB(NFREQC).LT.IB1) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 END IF XFRA=DLOG(FREQ(IB1)) IB0=IB1 490 IL=IL+1 IF(FRLEV(IL).LT.FRS2) NUB=2*NATOM+2 END DO C IF(IFREQB(NFREQC).LT.NFREQ) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=NFREQ END IF C NFREQL=0 XBL=DLOG(FRS1) NFLX=0 DO 410 IT=1,NTRANS IF(LINEXP(IT)) GO TO 410 IF(FR0(IT).LT.FRCMIN) GO TO 410 INDXPA=ABS(INDEXP(IT)) IF(INDXPA.GT.2 .AND. INDXPA.LE.4) GO TO 410 IL0=ILOW(IT) ITC=ITRA(IL0,NNEXT(IEL(IL0))) IF(ITC.EQ.0) ITC=ITRA(IL0,NNEXT(IEL(IL0))+1) IF(IFR1(IT).LE.IFR1(ITC)) GO TO 411 IF(IFR0(IT).LE.IFR1(ITC) .AND. ITC.GT.0) IFR0(IT)=IFR1(ITC)+1 411 NF=IFR1(IT)-IFR0(IT)+1 KFR0(IT)=NFREQL+1 KFR1(IT)=NFREQL+NF NFREQL=NFREQL+NF IF(INDXPA.EQ.2) THEN FR02H=HALF*(FREQ(IFR0(IT))+FREQ(IFR1(IT))) IJTC(IT)=IFR1(IT) DO WHILE(FR02H.GT.FREQ(IJTC(IT)) .AND. IJTC(IT).GT.1) IJTC(IT)=IJTC(IT)-1 END DO END IF al=2.997926e18/fr0(it) io=iel(il0) write(42,642) it,typion(io),il0,iup(it),iatm(il0), * il0-nfirst(io)+1,iup(it)-nfirst(io)+1,al, * ifr0(it),ifr1(it),nf 642 format(i7,a6,2i7,3i5,f12.3,3i7) IF(NF.GT.MFREQL) THEN WRITE(10,*) IL0,IT,NF CALL QUIT('Too many frequencies in a line - nf.gt.mfreql', * nf,mfreql) END IF IF(NF.GT.NFLX) NFLX=NF IF(KFR1(IT).GT.MFREQP) * CALL QUIT('Too many cross-sections to store in PRFLIN', * kfr1(it),mfreqp) 410 CONTINUE C DO IT=1,NTRANS MODW=IABS(INDEXP(IT)) IF(MODW.EQ.5 .OR. MODW.EQ.15) THEN IJTC(IT)=IFR1(IT) FRLV0=FR0PC(IT) IB1=NFRS1 DO WHILE(FREQ(IB1).GT.FRLV0) IB1=IB1+1 END DO IFR0(IT)=1 IFR1(IT)=IB1-1 END IF END DO C C Weights C DO IJ=NFRS1+1,NFREQ D121=HALF*(FREQ(IJ-1)-FREQ(IJ)) W(IJ-1)=W(IJ-1)+D121 W(IJ)=W(IJ)+D121 END DO C DO IJ=1,NFREQ IJALI(IJ)=1 IJX(IJ)=1 JIK(IJ)=IJ END DO NPPX=NFREQ C write(10,*) nfreq,nfreqc,nfreql,nflx IF(NFREQ.GT.MFREQ) THEN WRITE(10,1000) NFREQ 1000 FORMAT(' Number of frequencies:',I10) CALL QUIT('nfreq.gt.mfreq',nfreq,mfreq) END IF C RETURN END C C C **************************************************************** C C SUBROUTINE INIFRT C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C DIMENSION FREQCO(MFREQC),WCO(MFREQC),FRLEV(MLEVEL),IENS(MLEVEL) dimension WCHCO(MFREQC),IJXCO(MFREQC) common/ijflar/ijfl(mlevel) C DFEDG=0.01 NEND=NFTAIL DIVEND=DFTAIL NJC=NFREQC/5 DNX=UN-UN/FLOAT(NJC) CALL INDEXX(NLEVEL,ENION,IENS) DO IL=1,NLEVEL ILS=IENS(NLEVEL-IL+1) FRLEV(IL)=ENION(ILS)/H IJFL(IL)=0 END DO C IF(FRCMAX.LE.0.) THEN FREQCO(1)=8.E11*TEFF ELSE FREQCO(1)=FRCMAX END IF C IL0=1 IF(FREQCO(1).LT.CFRMAX*FRLEV(IL0) .AND. CFRMAX.GT.UN) THEN FREQCO(1)=CFRMAX*FRLEV(IL0) GO TO 10 END IF DO WHILE (FREQCO(1).LT.FRLEV(IL0) .AND. IL0.LT.NLEVEL) ILS=IENS(NLEVEL-IL0+1) ILN=NNEXT(IEL(ILS)) ITR0=ITRA(ILS,ILN) INDEXP(ITR0)=0 IFR0(ITR0)=0 IFR1(ITR0)=0 IF(FRLEV(IL0).GT.0.) WRITE(10,159) IL0,FRLEV(IL0),ILS,ILN,ITR0 159 FORMAT(' Edge at frequency larger than FRCMAX',I5,E12.4,3I7) IL0=IL0+1 END DO 10 CONTINUE C NFREQC=NEND+1 FREQCO(NEND)=(un+dfedg)*FRLEV(il0) FREQCO(NEND+1)=(un-dfedg)*FRLEV(il0) NEND1=NEND/2+1 XEND=UN/FLOAT(NEND1-1) FREQCO(NEND1)=FREQCO(1)-(UN-DIVEND)*(FREQCO(1)-FREQCO(NEND)) IJXCO(NEND+1)=1 C C high-frequency tail of the spectrum - a two-part Simpson integration C C 1st part - from the highest frequency FRCMAX to a division freq. C IJXCO(1)=1 IJXCO(NEND1)=1 D121=XEND*(FREQCO(1)-FREQCO(NEND1)) if(icompt.gt.0) d121=(freqco(1)/freqco(nend1))**xend DO IJ=2,NEND1-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 if(icompt.gt.0) freqco(ij)=freqco(ij-1)/d121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(1)-FREQCO(2)) DO IJ=2,NEND1-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO C C 2nd part - from the division freq to the first discontinuity C if(nend1.lt.nend) then IJXCO(NEND)=1 IJXCO(NEND+1)=1 D121=XEND*(FREQCO(NEND1)-FREQCO(NEND)) if(icompt.gt.0) d121=(freqco(nend1)/freqco(nend))**xend DO IJ=NEND1+1,NEND-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 if(icompt.gt.0) freqco(ij)=freqco(ij-1)/d121 IJXCO(IJ)=2 END DO D121=THIRD*(FREQCO(NEND1)-FREQCO(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 WCO(IJ)=4.*D121 WCO(IJ-1)=WCO(IJ-1)+D121 WCO(IJ+1)=WCO(IJ+1)+D121 WCHCO(IJ)=0. END DO end if C C the 1st discontinuity - the one with the highest frequency C HAEND=HALF*(FREQCO(NEND)-FREQCO(NEND+1)) XEND=UN/FLOAT(NEND-1) WCO(NEND)=WCO(NEND)+HAEND WCO(NEND+1)=WCO(NEND+1)+HAEND WCHCO(1)=0. WCHCO(NEND)=HAEND ILS=IENS(NLEVEL) IJFL(ILS)=NEND IL0=NLEVEL IF(FRCMIN.LE.0.) FRCMIN=1.D12 FRCLST=FRLEV(IL0) DO WHILE(FRCLST.LT.FRCMIN) IF(FRLEV(IL0).GT.0.) WRITE(10,160) IL0,FRLEV(IL0) 160 FORMAT(' Edge at frequency smaller than 1.d12',i5,e12.4) IL0=IL0-1 FRCLST=FRLEV(IL0) END DO IL0=2 C 100 CONTINUE FRC0=DNX*FREQCO(NFREQC) IF(FRC0.LT.FRCLST) THEN NFREQC=NFREQC+2 FREQCO(NFREQC-1)=(un+dfedg)*FRCLST FREQCO(NFREQC)=(un-dfedg)*FRCLST IJXCO(NFREQC-1)=1 IJXCO(NFREQC)=1 WCO(NFREQC)=WCO(NFREQC)+HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC)) WCO(NFREQC-2)=WCO(NFREQC-2)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-2)=HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IF(IL0.LT.NLEVEL) THEN DO IL=IL0+1,NLEVEL ILS=IENS(NLEVEL-IL+1) IJFL(ILS)=NFREQC-1 IF(FRLEV(IL).LT.FRCMIN) IJFL(ILS)=0 END DO END IF D121=XEND*(FREQCO(NFREQC)-FRCMIN) DO IJ=NFREQC+1,NFREQC+NEND-1 FREQCO(IJ)=FREQCO(IJ-1)-D121 IJXCO(IJ)=2 WCHCO(IJ)=0. END DO IJXCO(NFREQC+NEND-1)=1 DO IJ=NFREQC+1,NFREQC+NEND-2,2 WCO(IJ)=FTH*D121 WCO(IJ-1)=WCO(IJ-1)+THIRD*D121 WCO(IJ+1)=WCO(IJ+1)+THIRD*D121 END DO WCHCO(NFREQC)=THIRD*D121 NFREQC=NFREQC+NEND-1 GO TO 200 END IF DF0=FRLEV(IL0)+0.1*(FREQCO(NFREQC)-FRC0) FRTL=(UN+DFEDG)*FRLEV(IL0) IF(FRC0.GT.DF0) THEN NFREQC=NFREQC+1 FREQCO(NFREQC)=FRC0 IJXCO(NFREQC)=2 WCO(NFREQC)=WCO(NFREQC)+HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) ELSE IF(FRTL.LT.FREQCO(NFREQC)) THEN NFREQC=NFREQC+2 FREQCO(NFREQC-1)=FRTL FREQCO(NFREQC)=(un-dfedg)*FRLEV(IL0) IJXCO(NFREQC-1)=1 IJXCO(NFREQC)=1 WCO(NFREQC)=WCO(NFREQC)+HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCO(NFREQC-1)=WCO(NFREQC-1)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC)) WCO(NFREQC-2)=WCO(NFREQC-2)+ * HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) WCHCO(NFREQC-1)=HALF*(FREQCO(NFREQC-1)-FREQCO(NFREQC)) WCHCO(NFREQC-2)=HALF*(FREQCO(NFREQC-2)-FREQCO(NFREQC-1)) ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IL0=IL0+1 ELSE ILS=IENS(NLEVEL-IL0+1) IJFL(ILS)=NFREQC-1 IL0=IL0+1 END IF GO TO 100 200 CONTINUE C nend2=nfreqc IF(IFRSET.EQ.0) THEN DO IJ=1,NUMFREQ FREQCO(IJ+NEND2)=FRTAB(IJ) END DO NFR=NUMFREQ+NEND2 ELSE IF(IFRSET.GT.0) THEN NFRTAB=IFRSET DO IJ=1,NFRTAB FR=LOG(FRTAB(NUMFREQ))+ * LOG(FRTAB(1)/FRTAB(NUMFREQ))*(IJ-1)/(NFRTAB-1) FREQCO(NEND2+NFRTAB-IJ+1)=EXP(FR) NFR=NFRTAB+NEND2 END DO END IF C IF(FRTAB(NUMFREQ).GT.FRCMIN) THEN DO IJ=1,NEND FR=LOG(FRCMIN)+(LOG((UN-DFEDG)*FRTAB(NUMFREQ)/FRCMIN)* * (IJ-1)/(NEND-1)) FREQCO(NFR+NEND-IJ+1)=EXP(FR) END DO NFR=NFR+NEND END IF NFREQC=NFR C WCO(1)=0.5*(FREQCO(1)-FREQCO(2)) WCO(NFR)=0.5*(FREQCO(NFR-1)-FREQCO(NFR)) DO IJ=2,NFR-1 WCO(IJ)=0.5*(FREQCO(IJ-1)-FREQCO(IJ+1)) END DO C DO IJ=NFREQ,1,-1 FREQ(IJ+NFREQC)=FREQ(IJ) W(IJ+NFREQC)=W(IJ) PROF(IJ+NFREQC)=PROF(IJ) IJALI(IJ+NFREQC)=IJALI(IJ) END DO DO IJ=1,NFREQC FREQ(IJ)=FREQCO(IJ) W(IJ)=WCO(IJ) IJALI(IJ)=1 IJX(IJ)=1 PROF(IJ)=0. END DO DO 20 ITR=1,NTRANS IF(.NOT.LINE(ITR).OR.INDEXP(ITR).EQ.0) GO TO 20 IF(IFR0(ITR).GT.0) IFR0(ITR)=IFR0(ITR)+NFREQC IF(IFR1(ITR).GT.0) IFR1(ITR)=IFR1(ITR)+NFREQC 20 CONTINUE NFREQ=NFREQ+NFREQC C C determination of the first (IFR0) and the last (IFR1) frequency C for each explicit continuum - only if they were not already read C DO 30 ITR=1,NTRANS IF(LINE(ITR)) GO TO 30 IF(IFR0(ITR).LE.0) IFR0(ITR)=1 IF(IFR1(ITR).GT.0) GO TO 30 IF1=0 FR01=FR0(ITR) MODE=INDEXP(ITR) IF(IABS(MODE).EQ.5.OR.IABS(MODE).EQ.15) FR01=FR0PC(ITR) DO IJ=1,NFREQC IF(FREQ(IJ).GE.FR01) IF1=IJ END DO IFR1(ITR)=IF1 30 CONTINUE RETURN END C C C **************************************************************** C C FUNCTION CROSS(IBFT,IJ) C ======================= C C Evaluation of the photoionization cross-section C IBF - index ot the b-f transition C IJ - frequency index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C IJ0=IJBF(IJ) A1=AIJBF(IJ) CROSS=A1*BFCS(IBFT,IJ0)+(UN-A1)*BFCS(IBFT,IJ0+1) c RETURN END C C C **************************************************************** C C FUNCTION CROSSD(IBFT,IJ,ID) C =========================== C C Evaluation of the photoionization cross-section C IBF - index ot the b-f transition C IJ - frequency index C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C IJ0=IJBF(IJ) A1=AIJBF(IJ) CROSSD=A1*BFCS(IBFT,IJ0)+(UN-A1)*BFCS(IBFT,IJ0+1) c c contribution from dielectronic recombination c if(ifdiel.eq.0) return ITR=ITRBF(IBFT) if(idiel(itr).gt.0.and.id.gt.0) then i=ilow(itr) ion=iel(i) if(i.eq.nfirst(ion).and.iup(itr).eq.nnext(ion)) then if(freq(ij).ge.fr0(itr).and.freq(ij).le.fr0(itr)*1.1) * crossd=crossd+diesig(ion,id) end if end if c RETURN END C C C **************************************************************** C C SUBROUTINE DIETOT C ================= C C modification of the photoionization cross-section C for taking into account dielectronic recombination C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C do ion=1,nion i=nfirst(ion) ia=numat(iatm(i)) io=iz(ion) do id=1,nd t=temp(id) xpx=dens(id)/wmm(id)/ytot(id) call dielrc(ia,io,t,xpx,dirt,sig0) diesig(ion,id)=sig0 if(id.eq.1.or.id.eq.35.or.id.eq.nd) then write(99,699) ion,ia,io,id,i,nnext(ion),dirt,sig0 end if end do end do 699 format(6i5,1p2e12.4) return end C C C **************************************************************** C C SUBROUTINE RADPRE C ================= C C radiative acceleration C C exclude automatically the strongest lines of total C radiation pressure (Keyword XGRAD) C C depth-dependent criterion C C automatic explicit frequencies if XGRAD>=0 C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION GRADA(MDEPTH),PRID(MDEPTH),GRADI(MFREQ) DIMENSION PGT(MDEPTH),GGRT(MDEPTH),XGRD(MDEPTH),XGRD0(10) DIMENSION XGRD1(20),XGRD2(20) DIMENSION IIGR(MFREQ) PARAMETER(PGRD=4.1916825D-10) DATA XGRD0/0.1,0.3,0.5,0.7,0.9,0.92,0.94,0.96,0.98,0.99/ DATA XGRD1/0.1,0.2,0.3,0.4,0.5,0.6,0.65,0.7,0.75,0.8, & 0.85,0.9,0.92,0.94,0.96,0.98,0.99,0.99,0.99,0.99/ DATA XGRD2/0.1,0.2,0.3,0.4,0.45,0.5,0.55,0.6,0.65,0.7, & 0.75,0.8,0.84,0.87,0.9,0.93,0.95,0.97,0.98,0.99/ IF(XGRAD.EQ.0) THEN DO ID=1,10 XGRD(ID)=XGRD0(ID) END DO DO ID=11,ND XGRD(ID)=XGRD(ID-1) END DO ELSE IF(XGRAD.EQ.-1.) THEN DO ID=1,20 XGRD(ID)=XGRD1(ID) END DO DO ID=21,ND XGRD(ID)=XGRD(ID-1) END DO ELSE IF(XGRAD.EQ.-2.) THEN DO ID=1,20 XGRD(ID)=XGRD2(ID) END DO DO ID=21,ND XGRD(ID)=XGRD(ID-1) END DO ELSE DO ID=1,ND XGRD(ID)=XGRAD END DO END IF C Acceleration due to gas and turbulent pressure DO ID=1,ND PGAS=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) PGT(ID)=PGAS+HALF*DENS(ID)*VTURB(ID)*VTURB(ID) END DO DO ID=2,ND GGRT(ID)=(PGT(ID)-PGT(ID-1))/(DM(ID)-DM(ID-1)) END DO GGRT(1)=GGRT(2) C Compute total radiative acceleration at every depth points DO ID=1,ND GRAD(ID)=0. GRADA(ID)=0. PRADT(ID)=0. END DO PRD0=0. DO ID=2,ND PRID(ID)=PGRD/(DM(ID)-DM(ID-1)) END DO PGRD1=PGRD/DENS(1) DO IJ=1,NFREQ CALL OPACF1(IJ) CALL RTEFR1(IJ) FLUXW=W(IJ)*(RAD1(1)*FH(IJ)-HEXTRD(IJ)) GRADF(1,IJ)=FLUXW*ABSO1(1)*PGRD1 GRADA(1)=GRADA(1)+GRADF(1,IJ) DO ID=2,ND FRD=FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1) GRADF(ID,IJ)=W(IJ)*FRD*PRID(ID) GRADA(ID)=GRADA(ID)+GRADF(ID,IJ) END DO END DO DO ID=1,ND GGRT(ID)=GRADA(ID)+GGRT(ID) END DO C C radiation pressure C DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK END DO PRD0=PRD0/DENS1(1)*DM(1)*PCK C C Depth-dependent rejection: set up LSKIP(ID,IJ) C only if XGRAD<=0 NFE=0 DO ID=1,ND XGR0=GRAV*ABS(XGRD(ID)) DO IJ=1,NFREQ GRADI(IJ)=GRADF(ID,IJ) LSKIP(ID,IJ)=.FALSE. END DO if(ifprad.eq.0) then do ij=1,nfreq lskip(id,ij)=.true. end do end if CALL INDEXX(NFREQ,GRADI,IIGR) GRAD(ID)=GRADA(ID) GGRT0=GGRT(ID) IF(XGRAD.GT.0. .AND. ID.GT.1) THEN DO IJ=1,NFREQ LSKIP(ID,IJ)=LSKIP(1,IJ) IF(LSKIP(ID,IJ)) THEN GGRT0=GGRT0-GRADI(IJ) GRAD(ID)=GRAD(ID)-GRADI(IJ) END IF END DO GO TO 110 END IF IF(ID.GE.ND-1) GO TO 110 IJR=NFREQ NSK=0 DO WHILE(GRAD(ID).GT.XGR0 .AND. IJR.GT.0) IJ=IIGR(IJR) IF(IJLIN(IJ).EQ.0 .AND. NLINES(IJ).EQ.0) GO TO 99 LSKIP(ID,IJ)=.TRUE. GGRT0=GGRT0-GRADI(IJ) GRAD(ID)=GRAD(ID)-GRADI(IJ) NSK=NSK+1 IF(XGRD(ID).GE.0.) GO TO 99 IF(NFE.LT.10) THEN IF(ISPODF.EQ.0) THEN ITR=IJLIN(IJ) IF(ITR.EQ.0) GO TO 99 INDXPA=IABS(INDEXP(ITR)) DX=(FREQ(IJ)-FREQ(IJ+1))*0.25 DZ=ABS(FREQ(IJ)-FR0(ITR)) IF(DZ.LT.DX .AND. INDXPA.EQ.1) THEN IF(INDEXP(ITR).LT.0) THEN INDEXP(ITR)=-9 ELSE INDEXP(ITR)=9 END IF IF(.NOT.LEXP(ITR)) THEN LEXP(ITR)=.TRUE. NFREQE=NFREQE+1 if(nfreqe.gt.mfrex) * CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex) NN=NN+1 IJALI(IJ)=0 IJEX(IJ)=NFREQE IJFR(NFREQE)=IJ IJX(IJ)=1 WC(IJ)=0. WRITE(10,612) FREQ(IJ),ITR,IJ,NFREQE NFE=NFE+1 END IF END IF ELSE DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) INDXPA=IABS(INDEXP(ITR)) DX=(FREQ(IJ)-FREQ(IJ+1))*0.25 DZ=ABS(FREQ(IJ)-FR0(ITR)) IF(DZ.GT.DX .OR. INDXPA.NE.1) GOTO 100 IF(INDEXP(ITR).LT.0) THEN INDEXP(ITR)=-9 ELSE INDEXP(ITR)=9 END IF IF(.NOT.LEXP(ITR)) THEN LEXP(ITR)=.TRUE. NFREQE=NFREQE+1 if(nfreqe.gt.mfrex) * CALL QUIT('nfreqe.gt.mfrex',nfreqe,mfrex) NN=NN+1 IJALI(IJ)=0 IJEX(IJ)=NFREQE IJFR(NFREQE)=IJ IJX(IJ)=1 WC(IJ)=0. WRITE(10,612) FREQ(IJ),ITR,IJ,NFREQE NFE=NFE+1 END IF 100 CONTINUE END IF END IF 99 IJR=IJR-1 END DO 110 IF(ID.EQ.1) THEN TAUR=HALF*DEDM1*ABROSD(ID)*DENS(ID) ELSE DTAUR=DELDM(ID-1)*(ABROSD(ID)+ABROSD(ID-1)) TAUR=TAUR+DTAUR END IF rgrt=ggrt(id)/ggrt0 if(rgrt.gt.0.) then rgrt=dlog10(rgrt) else rgrt=-9. end if END DO 612 FORMAT(' AUTOMATIC EXPLICIT FREQ. ',1PE12.6,3I8) RETURN END C C C **************************************************************** C C SUBROUTINE LINSEL C ================= C C Exclude weakest lines C (i.e. set them to detailed radiative balance, and C exclude their frequencies) C C Selection of lines based on ratio of line core flux to C continuum flux C C Non-standard parameters: STRL1 (default value 0.001) C STRL2 ( 0.02) C C STRL2 allows to reduce the number of frequency points in C "intermediate-strength" lines C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' DIMENSION PRFTMP(MDEPTH) C parameter (SIXTH=UN/6.,FTH=4./3.) C NLSW=0 NLSI=0 NLSS=0 NLSTO=0 C IF(ISPODF.GE.1) GO TO 190 C CALL OPAINI(1) C C Normal lines C DO 10 ITR=1,NTRANS IF(LINEXP(ITR)) GO TO 10 IF(LEXP(ITR) .OR. IEL(ILOW(ITR)).EQ.IELH) THEN NLSTO=NLSTO+1 NLSS=NLSS+1 GO TO 10 ENDIF MODE=IABS(INDEXP(ITR)) IF(MODE.GE.2 .AND. MODE.LE.4) GO TO 10 IKA=IFR0(ITR) IF(IKA.EQ.0) GO TO 10 IKB=IFR1(ITR) CALL OPACF1(IKA) CALL RTEFR1(IKA) FLUXA=FH(IKA)*RAD1(1) CALL OPACF1(IKB) CALL RTEFR1(IKB) FLUXB=FH(IKB)*RAD1(1) IK0=(IKA+IKB)/2 IF(MODE.EQ.2) IK0=IFR1(ITR)-1 CALL OPACF1(IK0) CALL RTEFR1(IK0) FLUX0=FH(IK0)*RAD1(1) RHAB=UN-TWO*FLUX0/(FLUXA+FLUXB) NFK0=IKB-IKA+1 NLSTO=NLSTO+1 IF(ABS(RHAB).LT.STRL1) THEN NLSW=NLSW+1 LINEXP(ITR)=.TRUE. INDEXP(ITR)=0 DO IJ=IFR0(ITR),IFR1(ITR) IJX(IJ)=-1 IJLIN(IJ)=0 END DO IFR0(ITR)=0 IFR1(ITR)=0 KFR0(ITR)=0 KFR1(ITR)=0 LALI(ITR)=.FALSE. ELSE IF(ABS(RHAB).LT.STRL2) THEN NLSI=NLSI+1 IFR0(ITR)=IKA+3 IFR1(ITR)=IKB-3 KFR0(ITR)=KIJ(IFR0(ITR)) KFR1(ITR)=KIJ(IFR1(ITR)) DO IJ=IKA,IFR0(ITR) IJX(IJ)=-1 IJLIN(IJ)=0 DO ID=1,ND PRFLIN(ID,IJ)=0. END DO END DO IJX(IFR0(ITR))=1 IJLIN(IFR0(ITR))=ITR DO IJ=IFR1(ITR),IKB IJX(IJ)=-1 IJLIN(IJ)=0 DO ID=1,ND PRFLIN(ID,IJ)=0. END DO END DO IJX(IFR1(ITR))=1 IJLIN(IFR1(ITR))=ITR ELSE NLSS=NLSS+1 ENDIF NFK1=IFR1(ITR)-IFR0(ITR) IF(NFK1.GT.0) NFK1=NFK1+1 WRITE(82,601) ITR,ILOW(ITR),IUP(ITR), * NFK0,NFK1,RHAB 601 FORMAT(I6,2I5,2I7,1PE12.4) 10 CONTINUE C C superlines C DO 20 ITR=1,NTRANS IF(LINEXP(ITR)) GO TO 20 MODE=IABS(INDEXP(ITR)) IF(MODE.NE.3 .AND. MODE.NE.4) GO TO 20 IF(LEXP(ITR)) THEN NLSTO=NLSTO+1 NLSS=NLSS+1 GO TO 20 ENDIF IKA=IFR0(ITR) IF(IKA.EQ.0) GO TO 20 IKB=IFR1(ITR) NFK0=IFR1(ITR)-IFR0(ITR)+1 NFK1=NFK0 RHAB=0. RHABMX=0. PRFA=PRFLIN(1,IKA+1) PRFB=PRFLIN(1,IKB-1) IF(PRFA.GT.PRFB) THEN IK2=IKB-1 DO WHILE (IK2.GT.IKA .AND. RHAB.LT.STRL1) CALL OPACF1(IK2) CALL RTEFR1(IK2) FLUX2=FH(IK2)*RAD1(1) DO ID=1,ND PRFTMP(ID)=PRFLIN(ID,IK2) PRFLIN(ID,IK2)=0. END DO CALL OPACF1(IK2) CALL RTEFR1(IK2) FLUX1=FH(IK2)*RAD1(1) RHAB=ABS(UN-FLUX2/FLUX1) IF(RHAB.GT.RHABMX) RHABMX=RHAB IK20=IK2 IF(RHAB.LT.STRL1) THEN IJX(IK2+1)=-1 IJLIN(IK2+1)=0 IK2=IK2-1 ELSE IK2=IK2+1 IFR1(ITR)=IK2 KFR1(ITR)=KIJ(IK2) DO ID=1,ND PRFLIN(ID,IK20)=real(PRFTMP(ID)) END DO END IF END DO NFK1=IFR1(ITR)-IFR0(ITR)+1 IF(IK2.EQ.IKA) NFK1=0 ELSE IK2=IKA+1 DO WHILE (IK2.LT.IKB .AND. RHAB.LT.STRL1) CALL OPACF1(IK2) CALL RTEFR1(IK2) FLUX2=FH(IK2)*RAD1(1) DO ID=1,ND PRFTMP(ID)=PRFLIN(ID,IK2) PRFLIN(ID,IK2)=0. END DO CALL OPACF1(IK2) CALL RTEFR1(IK2) FLUX1=FH(IK2)*RAD1(1) RHAB=ABS(UN-FLUX2/FLUX1) IF(RHAB.GT.RHABMX) RHABMX=RHAB IK20=IK2 IF(RHAB.LT.STRL1) THEN IJX(IK2-1)=-1 IJLIN(IK2-1)=0 IK2=IK2+1 ELSE IK2=IK2-1 IFR0(ITR)=IK2 KFR0(ITR)=KIJ(IK2) DO ID=1,ND PRFLIN(ID,IK20)=real(PRFTMP(ID)) END DO END IF END DO NFK1=IFR1(ITR)-IFR0(ITR)+1 IF(IK2.EQ.IKB) NFK1=0 END IF IF(NFK1.EQ.0) THEN NLSW=NLSW+1 LINEXP(ITR)=.TRUE. INDEXP(ITR)=0 IFR0(ITR)=0 IFR1(ITR)=0 KFR0(ITR)=0 KFR1(ITR)=0 DO IJ=IKA,IKB IJX(IJ)=-1 IJLIN(IJ)=0 END DO LALI(ITR)=.FALSE. ELSE IF(NFK1.EQ.NFK0) THEN NLSS=NLSS+1 ELSE NLSI=NLSI+1 END IF NLSTO=NLSTO+1 WRITE(82,601) ITR,ILOW(ITR),IUP(ITR), * NFK0,NFK1,RHABMX 20 CONTINUE C WRITE(6,602) NLSTO,NLSW,NLSI,NLSS 602 FORMAT(' Total number of lines :',i8,/, * ' Number of weak lines :',i8,/, * ' Intermediate lines :',i8,/, * ' Number of strong lines:',i8/) C C lines or ODFs associated with each frequency C NLIMAX=0 DO IJ=1,NFREQ NLINES(IJ)=0 DO 50 IT=1,NTRANS IF(LINEXP(IT)) GO TO 50 IF(KIJ(IJ).LT.KFR0(IT)) GO TO 50 IF(KIJ(IJ).GT.KFR1(IT)) GO TO 50 IF(IJLIN(IJ).EQ.IT) GO TO 50 NLINES(IJ)=NLINES(IJ)+1 IF(NLINES(IJ).GT.MITJ) * CALL QUIT('Too many overlappins-nlines(ij).gt.mitj', * nlines(ij),mitj) ITRLIN(NLINES(IJ),IJ)=int2(IT) 50 CONTINUE IF(NLINES(IJ).GT.NLIMAX) NLIMAX=NLINES(IJ) END DO WRITE(6,603) NLIMAX 603 FORMAT(' MAXIMUM NUMBER OF OVERLAPPING TRANSITIONS: ',I3/) C C recalculate weights for frequency integration C after the exclusion of some frequencies C NPPX=0 DO 100 IJ=1,NFREQ IF(IJX(IJ).GT.0) NPPX=NPPX+1 W(IJ)=0. KJ0=KIJ(IJ) IF(IJX(JIK(KJ0)).EQ.-1) GO TO 100 IF(KJ0.GE.2 .AND. KJ0.LT.NFREQ) THEN IK1=KJ0-1 DO WHILE (IJX(JIK(IK1)).EQ.-1) IK1=IK1-1 END DO IK2=KJ0+1 DO WHILE (IJX(JIK(IK2)).EQ.-1) IK2=IK2+1 END DO W(IJ)=HALF*ABS(FREQ(JIK(IK1))-FREQ(JIK(IK2))) ELSE IF(KJ0.EQ.1) THEN W(IJ)=HALF*ABS(FREQ(JIK(KJ0))-FREQ(JIK(KJ0+1))) ELSE IF(KJ0.EQ.NFREQ) THEN W(IJ)=HALF*ABS(FREQ(JIK(KJ0-1))-FREQ(JIK(KJ0))) END IF 100 CONTINUE C C Correction for Simpson weights C JK1=JIK(1) DO IJ=2,NFREQ,2 JK2=JIK(IJ) JK3=JIK(IJ+1) IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GO TO 130 IF(WCH(JK2).NE.0.) GO TO 130 W(JK1)=W(JK1)-SIXTH*W(JK2) W(JK3)=W(JK3)-SIXTH*W(JK2) W(JK2)=W(JK2)*FTH JK1=JK3 END DO 130 JK1=JIK(NFREQ) DO IJ=NFREQ-1,3,-2 JK2=JIK(IJ) JK3=JIK(IJ-1) IF(IJLIN(JK2).NE.0 .OR. IJLIN(JK3).NE.0) GO TO 150 IF(WCH(JK2).NE.0.) GO TO 150 W(JK1)=W(JK1)-SIXTH*W(JK2) W(JK3)=W(JK3)-SIXTH*W(JK2) W(JK2)=W(JK2)*FTH JK1=JK3 END DO 150 CONTINUE C DO IJ=1,NFREQ W0E(IJ)=W(IJ)*PI4H/FREQ(IJ) IF(IJALI(IJ).GT.0) WC(IJ)=W(IJ) END DO C C check accuracy of weights for integration C 190 Z0=0. Z1=0. Z2=0. ZH=0. T1=TEFF T2=TWO*TEFF T3=HALF*TEFF X1=HK/T1 X2=HK/T2 X3=HK/T3 DO 200 IJ=1,NFREQ Z0=Z0+W(IJ) X15=FREQ(IJ)*1.D-15 BNZ=BN*X15*X15*X15 FX1=FREQ(IJ)*X1 IF(FX1.GT.100.) GO TO 200 Z1=Z1+W(IJ)*BNZ/(EXP(FREQ(IJ)*X1)-1) Z2=Z2+W(IJ)*BNZ/(EXP(FREQ(IJ)*X2)-1) ZH=ZH+W(IJ)*BNZ/(EXP(FREQ(IJ)*X3)-1) 200 CONTINUE T1S=SQRT(SQRT(0.25*Z1/SIG4P)) T1ER=T1S/T1-UN T2S=SQRT(SQRT(0.25*Z2/SIG4P)) T2ER=T2S/T2-UN T3S=SQRT(SQRT(0.25*ZH/SIG4P)) T3ER=T3S/T3-UN JK1=JIK(1) JK2=JIK(NFREQ) Z00=FREQ(JK1)-FREQ(JK2) WRITE(6,701) FREQ(JK1),FREQ(JK2),Z00,Z0,T3,T3ER,T1,T1ER,T2,T2ER 701 FORMAT(/' ACCURACY OF INTEGRATIONS:',/, * ' Interval:',1p4e16.8,/, * 15x,' Planck functions:',9x,0pf12.0,4x,1pe12.4,/, * 42x,0pf12.0,4x,1pe12.4,/,42x,0pf12.0,4x,1pe12.4,/) IF(ISPODF.GT.0) NPPX=NFREQ WRITE(6,702) NFREQ,NPPX 702 FORMAT(' TOTAL NUMBER OF FREQUENCIES:',I8,/, * ' SELECTED FREQUENCIES: ',I8) C RETURN END C C C ******************************************************************** C C SUBROUTINE PRINC C ================ C C Auxiliary output routine, which enables printing C more detailed information about chosen individual transitions C C Input: NCT - number of transitions for which information is C printed C ICTR(I) - index of the I-the considered transition C INFR(I) - index of the characteristic frequency point for C the I-th transition (i.e., standardly, the point just C shortward of edge for continua; or the line center C for lines) C - if =0, then the program choses the characteristic C frequency itself, in the standard manner C C The printed table contains for each transition the following functions C of depth: C C depth index; C optical depth at the characteristic frequency; C partial radiation force (actually, acceleration) - g(rad) - C produced by the transition C b-factor of the lower level; C b-factor of the upper level; C upward radiative rate; C downward radiative rate; C mean intensity at the characteristic frequency; C Planck function at the characteristic frequency; C total source function at the characteristic frequency; C net line (or continuum) source function at the characteristic frequency; C net heating rate (i.e heating minus cooling rate); C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (NPTR=30,CCOR=0.09,SIXTH=UN/6.) DIMENSION ST(NPTR,MDEPTH),TAU(NPTR,MDEPTH), * ABST(NPTR,MDEPTH),EMIT(NPTR,MDEPTH),SCTR(NPTR,MDEPTH), * INFR(NPTR),ICTR(NPTR),ABM(NPTR),PRF(MFREQ), * DWF(MFREQ) C DIMENSION RADM(MFREQ),ABSM(MFREQ),FAK0(MFREQ),RAD0(MFREQ) c READ(44,*,END=200,ERR=200) NCT READ(44,*,END=200,ERR=200) (ICTR(I),I=1,NCT) READ(44,*,END=200,ERR=200) (INFR(I),I=1,NCT) c DO IC=1,NCT ITR=ICTR(IC) IFR=INFR(IC) IF(LINE(ITR)) THEN IF(IFR.EQ.0) * INFR(IC)=(IFR0(ITR)+IFR1(ITR))/2 ELSE IF(IFR.EQ.0) INFR(IC)=IFR1(ITR) END IF IFR=INFR(IC) CALL OPACF1(IFR) DO ID=1,ND ABST(IC,ID)=ABSO1(ID) EMIT(IC,ID)=EMIS1(ID) SCTR(IC,ID)=SCAT1(ID) END DO END DO C DO ID=1,ND T=TEMP(ID) ANE=ELEC(ID) SQT=SQRT(T) ANES=EXP(SIXTH*LOG(ANE)) AACOR=CCOR*ANES/SQT CALL SABOLF(ID) DO I=1,NLEVEL POP(I)=POPUL(I,ID) END DO DO IC=1,NCT ITR=ICTR(IC) IFR=INFR(IC) I=ILOW(ITR) J=IUP(ITR) IF(LINE(ITR)) THEN CALL LINPRO(ITR,ID,PRF) GG=G(I)/G(J) SG=PRF(IFR) ELSE GG=ANE*SBF(I)*EXP(-HK*FREQ(IFR)/T) QZ=IZ(IEL(I)) MW=MCDW(ITR) CALL DWNFR(MW,NFREQ,FR0(ITR),AACOR,ANE,QZ,FREQ,DWF) SG=CROSS(ITRA(J,I),IFR)*DWF(IFR) END IF IJE=IJEX(IFR) ESCT=SCTR(IC,ID)*RAD(IFR,ID) ST(IC,ID)=(EMIT(IC,ID)+ESCT)/ABST(IC,ID) IF(ID.EQ.1) THEN TAU(IC,ID)=HALF *ABST(IC,ID)/DENS(ID)*DM(ID) ELSE TAU(IC,ID)=TAU(IC,ID-1)+(ABST(IC,ID)/DENS(ID)+ABM(IC))* * (DM(ID)-DM(ID-1))*HALF END IF ABM(IC)=ABST(IC,ID)/DENS(ID) END DO END DO C DO IC=1,NCT ITR=ICTR(IC) I=ILOW(ITR) J=IUP(ITR) K=NNEXT(IEL(I)) IFR=INFR(IC) IJE=IJEX(IFR) FR=FREQ(IFR) FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 WRITE(16,600) ITR,IFR,FR,2.997925d18/fr DO ID=1,ND T=TEMP(ID) TK=BOLK*T SB=2.0706D-16/T/SQRT(T)*G(I)/G(K)*EXP(ENION(I)/TK) IF(J.LT.K) * SJ=2.0706D-16/T/SQRT(T)*G(J)/G(K)*EXP(ENION(J)/TK) PI=POPUL(I,ID) X=EXP(-HK*FR/T) PLTE=SB*ELEC(ID)*POPUL(K,ID) BI=PI/PLTE BJ=1. IF(J.LT.K) BJ=POPUL(J,ID)/SJ/ELEC(ID)/POPUL(K,ID) PLANCK=BNU/(UN/X-UN) IF(LINE(ITR)) THEN RD=RRD(ITR,ID)*G(I)/G(J) GG=G(I)/G(J)*POPUL(J,ID) ELSE GG=PLTE*X RD=RRD(ITR,ID) END IF SL=BNU*GG/(PI-GG) ggrad=0. heat=0. WRITE(16,601) ID,TAU(IC,ID),GGRAD, * BI,BJ,RRU(ITR,ID),RD, * RAD(IFR,ID),PLANCK,ST(IC,ID),SL, * HEAT END DO END DO C 600 FORMAT(/ * ' PARAMETERS FOR TRANSITION',I5,' IFR =' ,I5, * ' FREQ =',1PD15.5,' Wavelength =',0pf11.3/ * 1H ,8X,'TAU',6X,'GR ',6X,'B-I',6X,'B-J',6X,' RU', * 6X,' RD',6X,'RAD',5X,'PLANCK',5X,'STOT',6X,'SL', * 5X,'HEAT'/) 601 FORMAT(1H ,I3,1P13D9.2) 200 RETURN END C C C **************************************************************** C C SUBROUTINE LUCY C =============== C C NLTE Lucy-Unsold temperature correction scheme, following C Werner & Dreizler C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' DIMENSION HEAT(MDEPTH),ABSZ(MDEPTH),ABSP(MDEPTH),ABSH(MDEPTH), * TOTJ(MDEPTH),TOTH(MDEPTH),TOTB(MDEPTH),DELH(MDEPTH), * EDDF(MDEPTH),DELTAT(MDEPTH),dt1(mdepth),dt2(mdepth), * ANTC(MDEPTH),XE(MDEPTH),heab(mdepth),tau(mdepth), * TEM0(MDEPTH),TEM1(MDEPTH),TEM2(MDEPTH),TEM3(MDEPTH) DIMENSION COL(MTRANS),CLOC(MTRANS) PARAMETER (THIRD=1./3.) DATA ILINIT /0/ C c IF(ILINIT.EQ.0) THEN ILINIT=1 do itr=1,ntrans iluctr(itr)=0 end do ntrl=0 read(2,*,end=5,err=5) ntrl 5 continue if(ntrl.gt.0) then do i=1,ntrl read(2,*,end=6,err=6) itrl iluctr(itrl)=1 end do end if 6 continue end if c c IF(MOD(ILAM,4).NE.3) RETURN if(itlucy.le.0) return LAC2T=.FALSE. iacc0t=IACLT-3 C ilucy=1 10 continue CALL OPAINI(0) C DO ID=1,ND HEAT(ID)=0. heab(id)=0. ABSZ(ID)=0. ABSP(ID)=0. ABSH(ID)=0. TOTJ(ID)=0. TOTH(ID)=0. TOTB(ID)=0. EDDF(ID)=0. END DO EDDH=0. C DO IJ=1,NFREQ W0=W(IJ) FR=FREQ(IJ) FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 CALL OPACFL(IJ) CALL RTEFR1(IJ) tau(1)=abso1(1)/dens(1)*dm(1) DO ID=1,ND if(id.ge.2) tau(id)=tau(id-1)+half*(abso1(id)/dens(id)+ * abso1(id-1)/dens(id-1))*(dm(id)-dm(id-1)) PLAND=BNU/(EXP(HK*FR/TEMP(ID))-UN) ABSOT0=ABSO1L(ID)-SCAT1(ID) HEAT(ID)=HEAT(ID)+W0*(ABSOT0*RAD1(ID)-EMIS1L(ID)) HEAB(ID)=HEAB(ID)+W0*(ABSOT0*RAD1(ID)-EMIS1L(ID))/ * (ABSOT0*PLAND) ABSP(ID)=ABSP(ID)+W0*ABSOT0*PLAND TOTJ(ID)=TOTJ(ID)+W0*RAD1(ID) TOTB(ID)=TOTB(ID)+W0*PLAND EDDF(ID)=EDDF(ID)+W0*FAK1(ID)*RAD1(ID) END DO C ID=1 EDDH=EDDH+W0*RAD1(ID)*FH(IJ) TOTH(ID)=TOTH(ID)+W0*(RAD1(ID)*FH(IJ)-HEXTRD(IJ)) ABSOT0=ABSO1(ID) ABSH(ID)=ABSH(ID)+W0*ABSOT0*(RAD1(ID)*FH(IJ)-HEXTRD(IJ)) DO ID=2,ND ABSOT0=HALF*(ABSO1(ID)+ABSO1(ID-1)) DTM=DELDM(ID-1)*(ABSO1(ID)*DENS1(ID)+ABSO1(ID-1)*DENS1(ID-1)) FLUZ=(RAD1(ID)*FAK1(ID)-RAD1(ID-1)*FAK1(ID-1))/DTM TOTH(ID)=TOTH(ID)+W0*FLUZ ABSH(ID)=ABSH(ID)+W0*ABSOT0*FLUZ END DO END DO C EDDH=EDDH/TOTJ(1) TEF4=SIG4P*TEFF**4 TOTH(ND)=TEF4 HEAT(ND)=0. HEAT(ND-1)=0. DO ID=1,ND ABSZ(ID)=(HEAT(ID)+ABSP(ID))/TOTJ(ID) ABSP(ID)=ABSP(ID)/TOTB(ID) ABSH(ID)=ABSH(ID)/TOTH(ID) EDDF(ID)=EDDF(ID)/TOTJ(ID) DELH(ID)=-TOTH(ID)+TEF4 END DO DHHMX1=0. DO ID=1,ND-1 DHH=ABS(DELH(ID)/TOTH(ID)) IF(DHH.GT.DHHMX1) DHHMX1=DHH END DO C ID=1 TP3=TEMP1(ID)*TEMP1(ID)*TEMP1(ID) XX=EDDF(ID)/EDDH*DELH(ID) XX1=XX DT1(id)=HEAT(ID)/16./SIG4P*TP3/ABSP(ID) DT2(id)=ABSZ(ID)/EDDF(ID)*XX/16./SIG4P*TP3/ABSP(ID) DELTAT(ID)=dt1(id)+dt2(id) DO ID=2,ND TP3=TEMP1(ID)*TEMP1(ID)*TEMP1(ID) XX=XX+DELDM(ID)*(ABSH(ID)*DENS1(ID)*DELH(ID)+ * ABSH(ID+1)*DENS1(ID+1)*DELH(ID+1)) DT1(id)=HEAT(ID)/16./SIG4P*TP3/ABSP(ID) DT2(id)=ABSZ(ID)/EDDF(ID)*XX/16./SIG4P*TP3/ABSP(ID) DELTAT(ID)=dt1(id)+dt2(id) END DO C C New temperature C DO ID=1,ND TEMP(ID)=TEMP(ID)+DELTAT(ID) tem0(id)=temp(id) AOLD=DENS(ID)/WMM(ID)+ELEC(ID) XE(ID)=UN-ELEC(ID)/AOLD END DO c c acceleration c if(itlucy.lt.IACLT .or. ilucy.lt.iacc0t) go to 20 ipng=1 if(IACLDT.gt.0) ipng=mod((ilucy-IACLT),IACLDT) if(.not.lac2t) then IPT=MOD(ILUCY,3) IPT0=MOD(IACLT,3) IPT1=MOD((IACLT+1),3) IPT2=MOD((IACLT+2),3) IF(ILUCY.EQ.IACC0T) THEN DO ID=1,ND TEM3(ID)=TEM0(ID) END DO ELSE IF(IPT.EQ.IPT1) THEN DO ID=1,ND TEM2(ID)=TEM0(ID) END DO ELSE IF(IPT.EQ.IPT2) THEN DO ID=1,ND TEM1(ID)=TEM0(ID) END DO ENDIF else if (ipng.ne.0) then DO ID=1,ND TEM3(ID)=TEM2(ID) END DO DO ID=1,ND TEM2(ID)=TEM1(ID) END DO DO ID=1,ND TEM1(ID)=TEM0(ID) END DO GO TO 20 end if IF(ILUCY.LT.IACLT) go to 20 C A1=0. B1=0. B2=0. C1=0. C2=0. DO ID=1,ND WT=0. IF(TEM0(ID).NE.0.) WT=1./ABS(TEM0(ID)) D0=TEM0(ID)-TEM1(ID) D1=D0-TEM1(ID)+TEM2(ID) D2=D0-TEM2(ID)+TEM3(ID) A1=A1+WT*D1*D1 B1=B1+WT*D1*D2 B2=B2+WT*D2*D2 C1=C1+WT*D0*D1 C2=C2+WT*D0*D2 END DO AB=B2*A1-B1*B1 IF(AB.EQ.0.) THEN WRITE(6,601) ILUCY,AB IACLT=IACLT+IACLDT IACC0T=IACLT-3 GO TO 20 ENDIF A0=(B2*C1-B1*C2)/AB B0=(A1*C2-B1*C1)/AB DO ID=1,ND TEM0(ID)=(1.-A0-B0)*TEM0(ID)+A0*TEM1(ID)+ * B0*TEM2(ID) TEMP(ID)=TEM0(ID) END DO LAC2T=.TRUE. 601 FORMAT(/,' **** ACCELT, ITER=',I4,' AB = ',F7.3,/) 20 CONTINUE CALL TDPINI C C Integrate hydrostatic equilibrium C IF(IHECOR.GE.1) THEN ID=1 PTUR=HALF*VTURB(ID)*VTURB(ID)*DENS(ID) ANTC(ID)=(DM(ID)*GRAV-PRD0-PTUR)/BOLK/TEMP(ID) IF(ANTC(ID).LE.0) ANTC(ID)=DENS(ID)/WMM(ID)+ELEC(ID) DO ID=2,ND PTUR=HALF*VTURB(ID)*VTURB(ID)*DENS(ID) PTURM=HALF*VTURB(ID-1)*VTURB(ID-1)*DENS(ID-1) ANTC(ID)=(GRAV*(DM(ID)-DM(ID-1))+ * BOLK*TEMP(ID-1)*ANTC(ID-1)- * PRADT(ID)+PRADT(ID-1)-PTUR+PTURM)/ * BOLK/TEMP(ID) END DO DO ID=1,ND ELEC(ID)=(UN-XE(ID))*ANTC(ID) DENS(ID)=WMM(ID)*(ANTC(ID)-ELEC(ID)) dens1(id)=un/dens(id) END DO END IF C C Other depth-dependent quantities C DO ID=1,ND PGS(ID)=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) CALL WNSTOR(ID) IF(LTE) GO TO 60 CALL SABOLF(ID) CALL COLIS(ID,TEMP(ID),COL,CLOC) DO I=1,NTRANS COLRAT(I,ID)=COL(I) COLTAR(I,ID)=CLOC(I) END DO 60 CONTINUE END DO C C new populations C DO ID=1,ND CALL STEQEQ(ID,POP,1) IF(.NOT.LCHC.and.iter.lt.ielcor) CALL ELCOR(ID) END DO C CALL CONCOR CALL ODFMER ilucy=ilucy+1 if(ilucy.le.itlucy) go to 10 C RETURN END C C C ******************************************************************** C C C SUBROUTINE IROSET C ================= C C Initialization of opacity sampling for iron-peak lines C C IOBS = 2 : ALL lines except lines to autoionized levels C IOBS = 1 : ALL lines C IOBS = 0 : only lines between observed levels C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' REAL*4 VDOP,AGAM,SIG0,SIGT PARAMETER (CSIG=0.0149736) COMMON/LINED/WAVE(MLINE),VDOP(MLINE,MDODF), & AGAM(MLINE,MDODF),SIG0(MLINE,MDODF), & JTR(MLINE,2) DIMENSION SIGT(MDODF,MFREQ),DML(MDEPTH) C JIDR(1)=1 IF(JIDS.EQ.0) THEN JIDR(2)=INT(0.7*ND) JIDR(3)=ND JIDN=3 JIDC=2 ELSE I=1 DO WHILE(JIDR(I).LT.ND) I=I+1 JIDR(I)=JIDR(I-1)+JIDS IF(JIDR(I).LE.INT(0.7*ND)) JIDC=JIDR(I) END DO JIDN=I IF(JIDR(I).GT.ND) THEN IF(JIDR(I-1).GE.ND-5) JIDN=JIDN-1 JIDR(JIDN)=ND END IF IF(JIDN.GT.MDODF) & CALL QUIT(' Too many depths for Fe x-sections',JIDN,MDODF) END IF c DO ID=1,ND DML(ID)=LOG(DM(ID)) END DO DO I=1,JIDN-1 DXI=DML(JIDR(I+1))-DML(JIDR(I)) DO ID=JIDR(I)+1,JIDR(I+1) JIDI(ID)=I XJID(ID)=(DML(JIDR(I+1))-DML(ID))/DXI END DO END DO JIDI(1)=1 XJID(1)=1. XFRMA=DLOG(FRS1) IJD=INT(9./DDNU) IF(IJD.LT.2) IJD=2 NFTT=0 NFTMX=0 C DO 500 ION=1,NION IND=INODF1(ION) IF(IND.LE.0) GO TO 500 IF(NLLIM(ION).GE.NLEVS(ION)) THEN DO ID=1,ND DO I=NFIRST(ION),NLAST(ION) WOP(I,ID)=UN END DO END DO GO TO 500 END IF C C Set up superlevels and read line data C IOBS=IKOBS(ION) CALL LEVCD(ION,IOBS) CALL INKUL(ION,IOBS) c write(6,610) ion,typion(ion),nlinku 610 format(/' *** superlines for ',i4,': ',a4, * ' selected internal lines:',i10) if(nlinku.gt.mline) * call quit('too many internal lines',nlinku,mline) C C Assign line to supertransition and compute cross-section C N1=NFIRST(ION) NLII=NLAST(ION)-N1+1 DO IL=1,NLII-1 KEVL=0 KODL=0 IF(JEN(IL).LE.NEVKU(ION)) THEN KEVL=JEN(IL) ELSE KODL=JEN(IL)-NEVKU(ION) END IF ILOK=N1+IL-1 DO IU=IL+1,NLII IUPK=N1+IU-1 ITR=ITRA(ILOK,IUPK) INDXPA=ABS(INDEXP(ITR)) W1=0. W2=0. IFRKU=0 NFT=0 NLT=0 KEVU=0 KODU=0 IF(JEN(IU).LE.NEVKU(ION)) THEN KEVU=JEN(IU) ELSE KODU=JEN(IU)-NEVKU(ION) END IF IF(KEVL.NE.0) THEN KEV=KEVL KOD=KODU IEO=0 GSUPER=YMKU(JEN(IL),1) ELSE KEV=KEVU KOD=KODL IEO=1 GSUPER=YMKU(JEN(IL)-NEVKU(ION),2) END IF DO IJ=1,MFREQ DO I=1,MDODF SIGT(I,IJ)=0. END DO END DO FCOL=0. DO 10 K=1,NLINKU IF(KSEV(JTR(K,1)).NE.KEV) GO TO 10 IF(KSOD(JTR(K,2)).NE.KOD) GO TO 10 NLT=NLT+1 FRL=CAS/WAVE(K) IJL=NINT((XFRMA-DLOG(FRL))/DXNU)+NFRS1 D0=ABS((FREQ(IJL)-FRL)/(FREQ(IJL)-FREQ(IJL+1))) IF(D0.GT.HALF) THEN DO WHILE(FRL.GT.FREQ(IJL)) IJL=IJL-1 END DO DO WHILE(FRL.LT.FREQ(IJL)) IJL=IJL+1 END DO D1=FRL-FREQ(IJL) D2=FREQ(IJL-1)-FRL IF(D2.LT.D1) IJL=IJL-1 END IF IJ0=IJL-IJD IJ1=IJL+IJD IF(IJ0.LT.1) IJ0=1 IF(IJ1.GT.NFREQ) IJ1=NFREQ IF(IFRKU.EQ.0) IFRKU=IJ0 NFT=IJ1-IFRKU+1 DO IJ=IJ0,IJ1 DNU=FREQ(IJ)-FRL DO I=1,JIDN VV=DNU*dble(VDOP(K,I)) PRFK=VOIGTE(real(VV),AGAM(K,I))/GSUPER SIGT(I,IJ)=SIGT(I,IJ)+SIG0(K,I)*real(PRFK) END DO END DO FCOL=FCOL+SIG0(K,JIDC)/VDOP(K,JIDC) 10 CONTINUE OSC0(ITR)=0. IF(INDXPA.EQ.3 .OR. INDXPA.EQ.4) OSC0(ITR)=STRLX IF(FCOL.GT.0.) OSC0(ITR)=FCOL/GSUPER/CSIG IF(NLT.GT.0) THEN W1=CAS/FREQ(IFRKU) W2=CAS/FREQ(IFRKU+NFT-1) END IF IF(NFT.GT.0) THEN IFR0(ITR)=IFRKU IFR1(ITR)=IFRKU+NFT-1 KFR0(ITR)=NFTT+1 KFR1(ITR)=NFTT+NFT NFTT=NFTT+NFT itrl=itr DO IJ=IFR0(ITR),IFR1(ITR) KJ=IJ-IFR0(ITR)+KFR0(ITR) DO I=1,JIDN sxx=log(dble(sigt(i,ij))+1.d-40) SIGFE(I,KJ)=real(sxx) END DO END DO END IF IF(KJ.GT.MCFE) & CALL QUIT(' Too many Fe cross-sect. to store', & KJ,MCFE) WRITE(41,313) IL,IU,W1,W2,IFRKU,NFT,NLT,OSC0(ITR) IF(NFT.GT.NFTMX) NFTMX=NFT END DO END DO 500 CONTINUE WRITE(10,*) ' Max. number of freq. per transition:',NFTMX WRITE(10,*) ' Number of iron line cross-sections: ',NFTT 313 FORMAT(2I4,2F12.3,3I10,1PE12.3) C CALL IJALI2 RETURN END C C C *************************************************************** C C SUBROUTINE LEVCD(ION,IOBS) C ========================== C C Mean energy and statistical weights of superlevels. C Read atomic data from Kurucz CD-ROM file (gf*.gam) C C Setup collisional strengths between superlevels, using C Eissner-Seaton formula for each possible individual C transition. Assumes Gamma(T)=0.05, and T=Teff C Contributions from allowed transitions will be superseded C in routine INKUL. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' C PARAMETER (BOLCM=1.D8/HK/CAS,CCOR=0.09,SIXTH=UN/6.,GES=0.05) DIMENSION GWE(MDEPTH,MLEVEL,2),GWB(MDEPTH,MLEVEL,2),AA(MDEPTH) DIMENSION E0FE(10),E0NI(10),E0CR(10) COMMON/COLKUR/OMES(100,100),EKU(15000),GKU(15000),GST, & KKU(15000) DATA E0FE/63480.,130563.,247220.,442000.,605000.,799000., & 1008000.,1218380.,1884000.,2114000./ DATA E0NI/61590.,146560.,283700.,443000.,613500.,871000., & 1070000.,1310000.,1560000.,1812000./ DATA E0CR/54576.,132966.,249700.,396500.,560200.,731020., & 1291900.,1490000.,1688000.,1971000./ C C Initialization C IF(IOBS.NE.1 .AND. IOBS.NE.2) IOBS=0 DO I=1,NEVKU(ION) YMKU(I,1)=0. EMKU(I,1)=0. DO ID=1,ND GWE(ID,I,1)=0. GWB(ID,I,1)=0. END DO END DO DO I=1,NODKU(ION) YMKU(I,2)=0. EMKU(I,2)=0. DO ID=1,ND GWE(ID,I,2)=0. GWB(ID,I,2)=0. END DO END DO NEVOD=NEVKU(ION)+NODKU(ION) IF(NEVOD.GT.100) & CALL QUIT(' Too many superlevels in a single Fe ion', & NEVKU(ION),NODKU(ION)) DO I=1,NEVOD DO J=1,NEVOD OMES(I,J)=0. END DO END DO IWSUP=IFWOP(NFIRST(ION)) IF(IWSUP.GE.2) THEN DO ID=1,ND TEMP1(ID)=UN/TEMP(ID) AA(ID)=CCOR*EXP(SIXTH*LOG(ELEC(ID)))/SQRT(TEMP(ID)) END DO ZZ=IZ(ION) IF(IZ(ION).GT.10) * CALL QUIT(' Too high Fe, Ni or Cr ion: ion,iz',ion,iz(ion)) IAT=IATM(NFIRST(ION)) E0=E0FE(IZ(ION)) IF(NUMAT(IAT).EQ.28) E0=E0NI(IZ(ION)) IF(NUMAT(IAT).EQ.24) E0=E0CR(IZ(ION)) END IF C C CD-ROM format: Read energy levels C IUN1=31 OPEN(IUN1,FILE=FIODF1(ION),STATUS='OLD') READ(IUN1,170) NLINKU,KEVE,KODD IF(KEVE+KODD.GT.15000) & CALL QUIT(' Too many levels in Kurucz file',keve,kodd) C C Even parity C DO K=1,KEVE KSL=0 READ(IUN1,171) YJ,E,AR,SR,WR GEV=(TWO*YJ+UN) IF(E.LT.0.) THEN E=-E IF(IOBS.EQ.0) GO TO 10 END IF IF(E.LE.XEV(1,ION)) KSL=1 DO I=2,NEVKU(ION) IF(E.LE.XEV(I,ION) .AND. E.GT.XEV(I-1,ION)) KSL=I END DO IF(KSL.EQ.0) WRITE(10,*) ' Error with even levels',E,YJ KKU(K)=KSL GKU(K)=GEV EKU(K)=E YMKU(KSL,1)=YMKU(KSL,1)+GEV EMKU(KSL,1)=EMKU(KSL,1)+GEV*E IF(IWSUP.EQ.2) THEN EBCM=E/BOLCM DO ID=1,ND GWX=GEV*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,1)=GWB(ID,KSL,1)+GWX GWE(ID,KSL,1)=GWE(ID,KSL,1)+GWX*E END DO ELSE IF(IWSUP.EQ.3) THEN EBCM=E/BOLCM IF(E.LT.E0) THEN XN=SQRT(E0/(E0-E)) DO ID=1,ND WID=WN(XN,AA(ID),ELEC(ID),ZZ) GWX=GEV*WID*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,1)=GWB(ID,KSL,1)+GWX GWE(ID,KSL,1)=GWE(ID,KSL,1)+GWX*E END DO ELSE DO ID=1,ND WID=UN GWX=GEV*WID*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,1)=GWB(ID,KSL,1)+GWX GWE(ID,KSL,1)=GWE(ID,KSL,1)+GWX*E END DO END IF END IF 10 EEV(K)=E AEV(K)=AR SEV(K)=SR WEV(K)=WR KSEV(K)=KSL END DO DO I=1,NEVKU(ION) IF(YMKU(I,1).EQ.0.) * call quit(' No levels in even superlevel',i,i) EMKU(I,1)=EMKU(I,1)/YMKU(I,1) END DO C C Odd parity C DO K=1,KODD KSL=0 READ(IUN1,171) YJ,E,AR,SR,WR GOD=(TWO*YJ+UN) IF(E.LT.0.) THEN E=-E IF(IOBS.EQ.0) GO TO 20 END IF IF(E.LE.XOD(1,ION)) KSL=1 DO I=2,NODKU(ION) IF(E.LE.XOD(I,ION) .AND. E.GT.XOD(I-1,ION)) KSL=I END DO IF(KSL.EQ.0) WRITE(10,*) ' Error with odd levels',E,YJ KKU(K+KEVE)=KSL+NEVKU(ION) GKU(K+KEVE)=GOD EKU(K+KEVE)=E YMKU(KSL,2)=YMKU(KSL,2)+GOD EMKU(KSL,2)=EMKU(KSL,2)+GOD*E IF(IWSUP.EQ.2) THEN EBCM=E/BOLCM DO ID=1,ND GWX=GOD*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,2)=GWB(ID,KSL,2)+GWX GWE(ID,KSL,2)=GWE(ID,KSL,2)+GWX*E END DO ELSE IF(IWSUP.EQ.3) THEN EBCM=E/BOLCM IF(E.LT.E0) THEN XN=SQRT(E0/(E0-E)) DO ID=1,ND WID=WN(XN,AA(ID),ELEC(ID),ZZ) GWX=GOD*WID*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,2)=GWB(ID,KSL,2)+GWX GWE(ID,KSL,2)=GWE(ID,KSL,2)+GWX*E END DO ELSE DO ID=1,ND WID=UN GWX=GOD*WID*EXP(-EBCM*TEMP1(ID)) GWB(ID,KSL,2)=GWB(ID,KSL,2)+GWX GWE(ID,KSL,2)=GWE(ID,KSL,2)+GWX*E END DO END IF END IF 20 EOD(K)=E AOD(K)=AR SOD(K)=SR WOD(K)=WR KSOD(K)=KSL END DO DO I=1,NODKU(ION) IF(YMKU(I,2).EQ.0.) * call quit(' No levels in odd superlevel',I,I) EMKU(I,2)=EMKU(I,2)/YMKU(I,2) END DO CLOSE(IUN1) C C Collisional strengths of transitions between super-levels C Eissner-Seaton formula (Gamma=0.05) C GST=8.63E-6*GES/SQRT(TEFF) TK0=UN/BOLCM/TEFF DO I=1,KEVE+KODD-1 KI=KKU(I) DO J=I+1,KEVE+KODD KJ=KKU(J) U0=ABS(EKU(I)-EKU(J))*TK0 OMES(KI,KJ)=OMES(KI,KJ)+GST*EXP(-U0) OMES(KJ,KI)=OMES(KI,KJ) END DO END DO C C Sort superlevel energies C NLEVKU=NEVKU(ION)+NODKU(ION) DO I=1,NEVKU(ION) EU(I)=EMKU(I,1) END DO DO I=1,NODKU(ION) EU(I+NEVKU(ION))=EMKU(I,2) END DO CALL INDEXX(NLEVKU,EU,JEN) C C Superlevel generalized occupation probabilities C IF(IWSUP.GE.2) THEN DO I=1,NLEVKU II=NFIRST(ION)+I-1 JJ=JEN(I) JK=1 IF(JJ.GT.NEVKU(ION)) THEN JJ=JEN(I)-NEVKU(ION) JK=2 END IF DO ID=1,ND ESUP=GWE(ID,JJ,JK)/GWB(ID,JJ,JK) WSUP=EXP(ESUP/BOLCM*TEMP1(ID))/YMKU(JJ,JK) WOP(II,ID)=WSUP*GWB(ID,JJ,JK) END DO END DO END IF C 170 FORMAT(I7,13X,I6,12X,I6) 171 FORMAT(8X,F4.1,4X,F13.3,18X,3E9.2) C RETURN END C C C *************************************************************** C C SUBROUTINE INKUL(ION,IOBS) C ========================== C C Read line list from Kurucz CD-ROM files (gf*.lin) C C INPUT: Unit 18 C WMIN : Min. wavelength (lines at smaller wave are NOT selected) C WMAX : Max. wavelength (lines at larger wave are NOT selected) C IOBS : Type of selected lines C C OUTPUT: fill up common/lined/ C ******* C - WAVE : wavelength in ANGSTROMS C - SIG0 : 0.02654/sqrt(pi)*gf/VDOP (divided by g(super) later) C - VDOP : Doppler width C - AGAM : Damping parameter C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' REAL*4 VDOP,AGAM,SIG0 C PARAMETER (TEN=10.,TENLG=2.302585093,GES=0.05) PARAMETER (BOL2=2.76108D-16,BOLCM=1.D8/HK/CAS) PARAMETER (CSTK=3.54,PSTK=2./3.,TSTK=UN/6.) PARAMETER (CVDW=3.74,PVDW=0.4,TVDW=0.3) PARAMETER (PI4V=0.25/3.141592654,CSIG=0.0149736) PARAMETER (EXPIA1=-0.57721566,EXPIA2=0.99999193, * EXPIA3=-0.24991055,EXPIA4=0.05519968, * EXPIA5=-0.00976004,EXPIA6=0.00107857, * EXPIB1=0.2677734343,EXPIB2=8.6347608925, * EXPIB3=18.059016973,EXPIB4=8.5733287401, * EXPIC1=3.9584969228,EXPIC2=21.0996530827, * EXPIC3=25.6329561486,EXPIC4=9.5733223454) DIMENSION E0FE(10),E0NI(10),E0CR(10) DIMENSION VT0(MDEPTH),GT0(MDEPTH) COMMON/COLKUR/OMES(100,100),EKU(15000),GKU(15000),GST, & KKU(15000) COMMON/LINED/WAVE(MLINE),VDOP(MLINE,MDODF), & AGAM(MLINE,MDODF),SIG0(MLINE,MDODF), & JTR(MLINE,2) DATA E0FE/63480.,130563.,247220.,442000.,605000.,799000., & 1008000.,1218380.,1884000.,2114000./ DATA E0NI/61590.,146560.,283700.,443000.,613500.,871000., & 1070000.,1310000.,1560000.,1812000./ DATA E0CR/54576.,132966.,249700.,396500.,560200.,731020., & 1291900.,1490000.,1688000.,1971000./ C IAT=IATM(NFIRST(ION)) E0=E0FE(IZ(ION)) IF(NUMAT(IAT).EQ.28) E0=E0NI(IZ(ION)) IF(NUMAT(IAT).EQ.24) E0=E0CR(IZ(ION)) CDOP=BOL2/AMASS(IAT) TK35=UN/BOLCM/TEMP(JIDR(2)) CVR=19.7363/TEMP(JIDR(2))/SQRT(TEMP(JIDR(2))) if(jidn.gt.3) then TK35=UN/BOLCM/TEFF CVR=19.7363/TEFF/SQRT(TEFF) end if TK357=TK35*1.E7 XION=0. DO K=1,JIDN XIONI=0. XIATI=0. ID=JIDR(K) DO I=NFIRST(ION),NLAST(ION) XIONI=XIONI+POPUL(I,ID) END DO DO I=N0A(IAT),NKA(IAT) XIATI=XIATI+POPUL(I,ID) END DO XIONK=XIONI/XIATI IF(XIONK.GT.XION) XION=XIONK VT0(ID)=1.E-8/SQRT(CDOP*TEMP(ID)+VTURBS(ID)*VTURBS(ID)) GT0(ID)=TSTK*DLOG10(TEMP(ID)) END DO NLINKU=0 WMIN=CAS/FRS1/TEN WMAX=CAS/FRS2/TEN IUN2=32 OPEN(IUN2,FILE=FIODF2(ION),STATUS='OLD') 10 READ(IUN2,180,ERR=20,END=20) WA,GFR,JEVR,JODR,IFPLI GF=EXP(TENLG*GFR) IF(WA.GT.WMAX) GO TO 11 IF(WA.LT.WMIN) GO TO 11 IF(IOBS.EQ.0 .AND. IFPLI.EQ.1) GO TO 10 IF(IOBS.EQ.2 .AND. EOD(JODR).GT.E0) GO TO 10 IF(IOBS.EQ.2 .AND. EEV(JEVR).GT.E0) GO TO 10 E00=EEV(JEVR) IF(EOD(JODR).LT.EEV(JEVR)) E00=EOD(JODR) XLSTR=XION*GF*EXP(-E00*TK35) if(jidn.gt.3) XLSTR=XION*GF*EXP(-E00*8./E0) IF(XLSTR.LT.STRLX) GO TO 10 NLINKU=NLINKU+1 WAVE(NLINKU)=WA*TEN JTR(NLINKU,1)=JEVR JTR(NLINKU,2)=JODR GR=AEV(JEVR)+AOD(JODR) C4=SEV(JEVR) C4P=SOD(JODR) SMX=DMAX1(ABS(C4P-C4),DMIN1(ABS(C4),ABS(C4P))) GSLOG0=CSTK+PSTK*DLOG10(SMX) DO I=1,JIDN ID=JIDR(I) VDOP(NLINKU,I)=real(WAVE(NLINKU)*VT0(ID)) GS=EXP(TENLG*(GSLOG0+GT0(ID))) AGAM(NLINKU,I)=real((GR+GS*ELEC(ID))*PI4V*VDOP(NLINKU,I)) SIG0(NLINKU,I)=real(CSIG*GF*VDOP(NLINKU,I)) END DO 11 KA=KKU(JEVR) KB=KKU(JODR+KEVE) IF(KA.LE.KB) THEN K1=KA K2=KB ELSE K1=KB K2=KA END IF IF(K1.EQ.K2) GO TO 10 U0=TK357/WA IF(U0.LE.UN) THEN EXPIU0=-LOG(U0)+EXPIA1+U0*(EXPIA2+U0*(EXPIA3+U0*(EXPIA4+ * U0*(EXPIA5+U0*EXPIA6)))) ELSE EXPIU0=EXP(-U0)*((EXPIB1+U0*(EXPIB2+U0*(EXPIB3+ * U0*(EXPIB4+U0))))/(EXPIC1+U0*(EXPIC2+ * U0*(EXPIC3+U0*(EXPIC4+U0)))))/U0 END IF GB=0.276*EXP(U0)*EXPIU0 IF(GB.LT.0.25) GB=0.25 OMES(K1,K2)=OMES(K1,K2)+(CVR/U0*GF*GB-GST)*EXP(-U0) GO TO 10 20 CLOSE(IUN2) WRITE(10,600) NUMAT(IAT),IZ(ION),NLINKU C C Store collisional excitation strengths C NLEVKU=NEVKU(ION)+NODKU(ION) DO I=1,NLEVKU-1 II=NFIRST(ION)+I-1 I1=JEN(I) IF(I1.LE.NEVKU(ION)) THEN GSUP=YMKU(I1,1) ELSE GSUP=YMKU(I1-NEVKU(ION),2) END IF DO J=I+1,NLEVKU JJ=NFIRST(ION)+J-1 J1=JEN(J) IT=ITRA(II,JJ) C2=CPAR(IT) OMECOL(II,JJ)=OMES(I1,J1)/GSUP*C2/GES OMECOL(JJ,II)=OMECOL(II,JJ) END DO END DO c RETURN C 180 FORMAT(F11.4,F7.3,2I4,I1) 600 FORMAT(' Ion',2I3,' : ',I9,' Lines included') END C C C *************************************************************** C C C SUBROUTINE OPACFL(IJ) C ===================== C C Absorption, emission, and scattering coefficients C at frequency IJ and for all depths C C Input: IJ opacity and emissivity is calculated for the C frequency points with index IJ C Output: ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient (all scattering C mechanisms except electron scattering) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (C14=2.99793D14, CFF1=1.3727D-25) C C initialize c DO ID=1,ND ABSO1(ID)=ELSCAT(ID) EMIS1(ID)=0. SCAT1(ID)=ELSCAT(ID) ABSO1L(ID)=0. EMIS1L(ID)=0. END DO C C basic frequency- and depth-dependent quantities C FR=FREQ(IJ) FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV DO ID=1,ND XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) END DO lfre=fr.gt.frtabm C C ******** 1a. bound-free contribution - without dielectronic rec. C if(ifdiel.eq.0) then DO IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) II=ILOW(ITR) JJ=IUP(ITR) idp=iadop(iatm(ii)) if(sg.gt.0.and.(idp.eq.0.or.(idp.gt.0.and.lfre))) then IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF if(iluctr(itr).gt.0) then ABSO1L(ID)=ABSO1L(ID)+SGD*ABTRA(ITR,ID) EMIS1L(ID)=EMIS1L(ID)+EMISBF end if END DO END IF END DO else C C ******** 1. bound-free contribution - with dielectronic rec. C DO IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) II=ILOW(ITR) JJ=IUP(ITR) idp=iadop(iatm(ii)) if(sg.gt.0.and.(idp.eq.0.or.(idp.gt.0.and.lfre))) then IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SG=CROSSD(IBFT,IJ,ID) IF(SG.GT.0.) THEN SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF if(iluctr(itr).eq.0) then ABSO1L(ID)=ABSO1L(ID)+SGD*ABTRA(ITR,ID) EMIS1L(ID)=EMIS1L(ID)+EMISBF endif END IF END DO END IF END DO end if C C ******** 2. free-free contribution C DO 40 ION=1,NION IT=ITRA(NNEXT(ION),NNEXT(ION)) idp=iadop(iatm(nnext(ion))) if(idp.gt.0.and..not.lfre) go to 40 C C hydrogenic with Gaunt factor = 1 C IF(IT.EQ.1) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO C C hydrogenic with exact Gaunt factor C ELSE IF(IT.EQ.2) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) X=C14*CHARG2(ION)/FR SF2=SF2-UN+GFREE1(ID,X) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO C C H minus free-free opacity C ELSE IF(IT.EQ.3) THEN DO ID=1,ND ABSOFF=SFFHMI(POPUL(NFIRST(IELH),ID),FR,TEMP(ID))* * ELEC(ID) ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO C C special evaluation of the cross-section C ELSE IF(IT.LT.0) THEN DO ID=1,ND ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)* * POPUL(NNEXT(ION),ID)*ELEC(ID) ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF END DO END IF 40 CONTINUE C C ******** 3. - additional continuum opacity (OPADD) C IF(IOPADD.NE.0) THEN ICALL=1 DO ID=1,ND CALL OPADD(0,ICALL,IJ,ID) ABSO1(ID)=ABSO1(ID)+ABAD EMIS1(ID)=EMIS1(ID)+EMAD SCAT1(ID)=SCAT1(ID)+SCAD END DO END IF C C ******** 4. - opacity and emissivity in lines C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) iad=iadop(iatm(ilow(itr))) if(iad.eq.0.or.(lfre.and.iad.gt.0)) then DO ID=1,ND SG=PRFLIN(ID,IJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO if(iluctr(itr).gt.0) then DO ID=1,ND SG=PRFLIN(ID,IJ) ABSO1L(ID)=ABSO1L(ID)+SG*ABTRA(ITR,ID) EMIS1L(ID)=EMIS1L(ID)+SG*EMTRA(ITR,ID) END DO end if end if END IF IF(NLINES(IJ).LE.0) GO TO 200 C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 100 if(linexp(itr)) go to 100 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 DO ID=1,ND SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO 100 CONTINUE 200 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 400 DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 300 c IF(LINEXP(ITR)) GO TO 300 C IF(IJ.LT.IFR0(ITR) .OR. IJ.GT.IFR1(ITR)) GO TO 300 KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO ID=1,ND SG=PRFLIN(ID,KJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO ELSE DO ID=1,ND KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+ * (UN-XJID(ID))*SIGFE(KJD+1,KJ)) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) END DO END IF 300 CONTINUE 400 CONTINUE END IF C C ---------------------------- C total opacity and emissivity C ---------------------------- C DO ID=1,ND ABSO1(ID)=ABSO1(ID)-EMIS1(ID)*XKF(ID) EMIS1(ID)=EMIS1(ID)*XKFB(ID) ABSO1L(ID)=ABSO1L(ID)-EMIS1L(ID)*XKF(ID) EMIS1L(ID)=EMIS1L(ID)*XKFB(ID) ABSO1L(ID)=ABSO1(ID)-ABSO1L(ID) EMIS1L(ID)=EMIS1(ID)-EMIS1L(ID) END DO RETURN END C C C *************************************************************** C C subroutine rdatax(itr,ic,iunit) c =============================== c c for itr, itrx ne 0 - read input data for an individual transition c and prepare necessary auxiliary arrays c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' c parameter (mtrx=1000) dimension iex(mtrx),itrind(mtrx),izx0(mtrx),izx1(mtrx), * nmaxx(mtrx),izx(mtrx),nshx(mtrx),nax(mtrx),icx(mtrx), * etx(mtrx),ssx(mtrx),dx(mtrx), * aphx(11,5,mtrx),bphx(5,mtrx),a(11,5),b(5) c if(itr.gt.0) then itrx=itrx+1 ntrx=itrx ii=ilow(itr) ie=iel(ii) jj=iup(itr) iex(itrx)=ie icx(itrx)=ic itrind(itrx)=itr izx0(itrx)=iz(ie) izx1(itrx)=jj-1000 c c read inner-shell photoionization data from Omer's tables c read(iunit,*) etx(itrx) read(iunit,*) nmaxx(itrx),izx(itrx),nshx(itrx) read(iunit,*) ssx(itrx) read(iunit,*) nax(itrx) read(iunit,*) dx(itrx) do i=1,nax(itrx) read(iunit,*) bphx(i,itrx) end do do j=1,nax(itrx) do i=1,11 read(iunit,*) aphx(i,j,itrx) end do end do else if(itr.eq.0) then c c for itr=0 - set up array BFCS with actual cross-sections c if(ntrx.gt.0) then do itx=1,ntrx ie=iex(itx) it=itrind(itx) ii=ilow(it) ia=iatm(ii) iz1=izx1(itx) ic=icx(itx) jj=0 do i=1,nlevel if(iatm(i).eq.ia) then if(iz(iel(i)).eq.iz1) then jj=i go to 10 end if end if end do 10 continue if(jj.eq.0) then if(iz1.eq.iz(iel(nka(ia)-1))+1) jj=nka(ia) end if if(jj.eq.0) indexp(it)=0 c if(indexp(it).ne.0) then iup(it)=jj fr0(it)=etx(itx)/4.1357e-15 line(it)=.false. itrcon(it)=ic if(icol(it).ne.99) then itra(ii,jj)=it itra(jj,ii)=ic end if c write(6,601) itx,it,ii,jj,ia, * itra(ii,jj),itra(jj,ii), * icol(it),fr0(it),etx(itx) 601 format(8i4,1pe12.4,0pf10.2) end if end do end if c else nfreqb=nfreq if(ibfint.gt.0) nfreqb=nfreqc if(ntrx.gt.0) then do itx=1,ntrx it=itrind(itx) ic=icx(itx) if(indexp(it).ne.0) then na=nax(itx) do i=1,na b(i)=bphx(i,itx) end do do j=1,na do i=1,11 a(i,j)=aphx(i,j,itx) end do end do c do ij=1,nfreqb call bkhsgo(freq(ij),etx(itx),dx(itx),b,na,a, * ssx(itx),nmaxx(itx),izx(itx),nshx(itx),sg) bfcs(ic,ij)=real(sg) end do write(97,681) it,ic,ilow(it),iup(it),bfcs(ic,1) 681 format(4i5,1p1e15.5) end if end do end if end if return end C C C ************************************************************************ C C subroutine bkhsgo(freq,et,d,b,na,a,ss,nmax,iz,nsh,sg) c ===================================================== c c c subroutine to calculate K and L shell photoionization cross-sections c -based on Tim Kallman's bkhsgo subroutine from XSTAR, modified c by Omer Blaes 5-7-98. c -na.ne.2 bug corrected on 2/24/00 by Omer Blaes c c freq is photon frequency in Hz (note that this subroutine immediately c converts it into eV) c c et is threshold energy in eV c c iz is the ionization stage of the species being photoionized (1=neutral etc.) c c ss is the iz'th element of the array ss(nmax) in Tim's original version c c sg is returned as the contribution to the photoionization cross-section c in cm^2 due to whatever process is being considered. c c this routine does the work in computing cross sections by the c method of barfield, et. al. c c c INCLUDE 'IMPLIC.FOR' dimension b(5),a(11,5) c data sigth/1.e-34/ c tmp1 = 0. jj = 1 epii = 4.1357e-15*freq sg=0. if ( epii.gt.et ) then xx = epii*(1.e-3) - d if ( xx.le.0. ) return do nna=1,na if ( xx.ge.b(nna) ) jj = jj + 1 enddo if ( jj.le.na ) then if(xx.lt.0.) xx=0. yy = log10(xx) tmp = 0. do kkk = 1,11 kk = 12 - kkk tmp = a(kk,jj) + yy*tmp end do if(tmp.lt.-50.) tmp=-50. if(tmp.gt.24.) tmp=24. sgtmp = 10.**(tmp-24.) nelec=nmax+1-iz if(nelec.gt.nsh) nelec=nsh enelec = float(nelec) tmp1o = tmp1 tmp1=sgtmp*ss if(tmp1.lt.sigth*enelec) tmp1=sigth*enelec if ( epii.ge.5.e+4 ) then if(tmp1.gt.tmp1o) tmp1 = tmp1o end if sg = sg + tmp1 endif endif return end C C C ************************************************************************ C C c function cion(n,j,e,t) c c collisional ionization rate from Raymond c rate is returned in units cm^3/s c inputs are: n=nuclear charge, c j=ion stage c e=valence shell ionization threshold (in eV) c t=temperature in K. c c Tim Kallman's routine for calculating collisional ionization rates. c Note that this routine only accounts for valence shell ionization. c It should be called only once for each ion stage and the valence c shell ionization threshold should be the lowest one (e.g. the 2p c ionization potential for CI). c c INCLUDE 'IMPLIC.FOR' c c sm younger jqsrt 26, 329; 27, 541; 29, 61 with moores for undone c a0 for b-like ion has twice 2s plus one 2p as in summers et al c chi = kt / i c dimension a0(30),a1(30),a2(30),a3(30),b0(30),b1(30), & b2(30),b3(30),c0(30),c1(30),c2(30),c3(30), & d0(30),d1(30),d2(30),d3(30) c data a0/13.5,27.0,9.07,11.80,20.2,28.6,37.0,45.4, & 53.8,62.2,11.7,38.8,37.27,46.7,57.4,67.0, & 77.8,90.1,106.,120.8,135.6,150.4,165.2,180.0, & 194.8,209.6,224.4,239.2,154.0,268.8/ data a1/ - 14.2,-60.1,4.30,27*0./ data a2/40.6,140.,7.69,27*0./ data a3/ - 17.1,-89.8,-7.53,27*0./ c data b0/ - 4.81,-9.62,-2.47,-3.28,-5.96,-8.64,-11.32, & -14.00,-16.68,-19.36,-4.29,-16.7,-14.58,-16.95, & -19.93,-23.05,-26.00,-29.45,-34.25,-38.92, & -43.59,-48.26,-52.93,-57.60,-62.27,-66.94, & -71.62,-76.29,-80.96,-85.63/ data b1/9.77,33.1,-3.78,27*0./ data b2/ - 28.3,-82.5,-3.59,27*0./ data b3/11.4,54.6,3.34,27*0./ c data c0/1.85,3.69,1.34,1.64,2.31,2.984,3.656,4.328, & 5.00,5.672,1.061,1.87,3.26,5.07,6.67,8.10, & 9.92,11.79,7.953,8.408,8.863,9.318,9.773, & 10.228,10.683,11.138,11.593,12.048,12.505,12.96/ data c1/0.,4.32,.343,27*0./ data c2/0.,-2.527,-2.46,27*0./ data c3/0.,.262,1.38,27*0./ c data d0/ - 10.9,-21.7,-5.37,-7.58,-12.66,-17.74, & -22.82,-27.9,-32.98,-38.06,-7.34,-28.8,-24.87, & -30.5,-37.9,-45.3,-53.8,-64.6,-54.54,-61.70, & -68.86,-76.02,-83.18,-90.34,-97.50,-104.66, & -111.82,-118.98,-126.14,-133.32/ data d1/8.90,42.5,-12.4,27*0./ data d2/ - 35.7,-131.,-8.09,27*0./ data d3/16.5,87.4,1.23,27*0./ c cion = 0. chir = t/(11590.*e) if ( chir.le..0115 ) return chi=chir if(chi.lt.0.1) ch=0.1 ch2 = chi*chi ch3 = ch2*chi alpha = (.001193+.9764*chi+.6604*ch2+.02590*ch3) & /(1.0+1.488*chi+.2972*ch2+.004925*ch3) beta = (-.0005725+.01345*chi+.8691*ch2+.03404*ch3) & /(1.0+2.197*chi+.2457*ch2+.002503*ch3) j2 = j*j j3 = j2*j iso = n - j + 1 c a = a0(iso) + a1(iso)/j + a2(iso)/j2 + a3(iso)/j3 b = b0(iso) + b1(iso)/j + b2(iso)/j2 + b3(iso)/j3 c = c0(iso) + c1(iso)/j + c2(iso)/j2 + c3(iso)/j3 d = d0(iso) + d1(iso)/j + d2(iso)/j2 + d3(iso)/j3 c c fe ii experimental ionization montague et al: d. neufeld fit if ( n.eq.26 .and. j.eq.2 ) then a = -13.825 b = -11.0395 c = 21.07262 d = 0. endif c ch = 1./chi fchi = 0.3*ch*(a+b*(1.+ch)+(c-(a+b*(2.+ch))*ch)*alpha+d*beta*ch) cion = 2.2e-6*sqrt(chir)*fchi*expo(-1./chir)/(e*sqrt(e)) return end C C C ************************************************************************ C C c c subroutine dielrc(iatom,iont,temp,xpx,dirt,sig0) c ================================================ c INCLUDE 'IMPLIC.FOR' c c c Modification of Tim Kallman's XSTAR routine rrrec to calculate dielectronic c recombination rates (only) to individual ionic species (modified by Omer c Blaes 5-8-98) c c Here temp=temperature in K, xpx is the number density of atomic nuclei in c cm^{-3} (hydrogen density=xpx/1.1, helium density=xpx*0.1/1.1), c dirt =the dielectronic rate in cm^3/s, c sig0 = the value of sigma_0, the corresponding pseudo-cross-section c iatom - atomic number (1=H, 2=He, 6=C, etc.) c iont - ionization stage (1 for neutrals, 2 for once ionized, etc.) c c this routine computes radiative recombination rates, both rr c and dr. rates are output in units of cm**3/s for each ion c stage, where ions are numbered from 1-168: c 1=HI, 2=HeI, 3=HeII, 4=C I, 5=C II, ..., 9=C VI, 10=N I, ..., c 16=N VII, 17=O I, ..., 24=O VIII, 25=Ne I, ..., 34=Ne X, c 35=Mg I, ..., 46=Mg XII, 47=Si I, ..., 60=Si XIV, 61=S I, ..., c 76=S XVI, 77=Ar I, ..., 94=Ar XVIII, 95=Ca I, ... 114=Ca XX, c 115=Fe I, ..., 140=Fe XXVI, 141=Ni I, ... 168=Ni XXVIII. c inputs are rate coefficients from Aldrovandi and Pequignot, Storey, c and from Arnaud and Raymond for iron c parameter (nni=168) parameter (cons=0.1239529*3.28805e15/13.595) dimension inid(28,28),uu(28,28) dimension adi(nni),bdi(nni),t0(nni),t1(nni),cdd(nni) dimension dcfe(26,4),defe(26,4) dimension gli(20),gfe(26),gni(28) dimension istorey(13),rstorey(5,13) c c c Each non-indented line in the following data statements corresponds c to each of the elements H, He, C, N, O, Ne, Mg, Si, S, Ar, Ca, Fe, c and Ni. c data inid/1, 27*0, * 2, 3, 26*0, * 28*0, * 28*0, * 28*0, * 4, 5, 6, 7, 8, 9, 22*0, * 10,11,12,13,14,15,16, 21*0, * 17,18,19,20,21,22,23,24, 20*0, * 28*0, * 25,26,27,28,29,30,31,32,33,34, 18*0, * 28*0, * 35,36,37,38,39,40,41,42,43,44,45,46, 16*0, * 28*0, * 47,48,49,50,51,52,53,54,55,56,57,58,59,60,14*0, * 28*0, * 61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,12*0, * 28*0, * 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94, * 10*0, * 28*0, * 95,96,97,98,99,100,101,102,103,104,105,106,107,108,109, * 110,111,112,113,114,8*0, * 28*0, * 28*0, * 28*0, * 28*0, * 28*0, * 115,116,117,118,119,120,121,122,123,124,125,126,127,128, * 129,130,131,132,133,134,135,136,137,138,139,140,2*0, * 28*0, * 141,142,143,144,145,146,147,148,149,150,151,152,153,154, * 155,156,157,158,159,160,161,162,163,164,165,166,167,168/ data adi/0., % 1.9E-03,0., % 6.9E-04,7.0E-03,3.8E-03,4.8E-02,4.8E-02,0., % 5.2E-04,1.7E-03,1.2E-02,5.5E-03,7.6E-02,6.6E-02,0., % 1.4E-03,1.4E-03,2.8E-03,1.7E-02,7.1E-03,1.1E-01,8.6E-02, % 0.0, % 1.3E-03,3.1E-03,7.5E-03,5.7E-03,1.0E-02,4.0E-02,1.1E-02, % 1.8E-01,1.3E-01,0., % 1.7E-3,3.5E-3,3.9E-3,9.3E-3,1.5E-2,1.2E-2, % 1.4E-2,3.8E-2,1.4E-2,2.6E-1,1.7E-1,0., % 6.2E-03,1.4E-02,1.1E-02,1.4E-02,7.8E-03,1.6E-02,2.3E-02, % 1.1E-02,1.1E-02,4.8E-02,1.8E-02,3.4E-01,2.1E-01,0., % 7.3E-05,4.9E-03,9.1E-03,4.3E-02,2.5E-02,3.1E-02,1.3E-02, % 2.1E-02,3.5E-02,3.0E-02,3.1E-02,6.3E-02,2.3E-02, % 4.2E-01,2.5E-01,0., % .0001,.011,.034,.0685,.090,.0635,.0260,.017, % .0210,.0350,.0540,.0713,.0960,.0850,.0170, % .476,.297,0., % 3.28E-4,5.84E-02,1.12E-01,1.32E-01,1.33E-01,1.26E-01, % 1.39E-01,9.55E-02,4.02E-01,4.19E-02,2.57E-02,4.45E-02, % 5.48E-02,7.13E-02,9.03E-02,1.10E-01,2.05E-02,5.49E-01, % 3.55E-01,0., % 1.8E-3,3.6E-2,7.8E-2,2.2E-1,1.4E-1,1.4E-1, % 1.1E-1,6.3E-1,5.5E-1,3.6E-1,2.6E-1,1.6E-1, % 6.6E-2,2.5E-1,1.2E-1,5.0E+0,3.7E-2,6.3E-2, % 7.0E-2,1.1E-1,1.0E-1,1.1E-1,3.6E-2,7.5E-1, % 5.2E-1,0., % 1.41E-03, 5.20E-03, 1.38E-02, 2.30E-02, 4.19E-02, % 6.83E-02, 1.22E-01, 3.00E-01, 1.50E-01, 6.97E-01, % 7.09E-01, 6.44E-01, 5.25E-01, 4.46E-01, 3.63E-01, % 3.02E-01, 1.02E-01, 2.70E-01, 4.67E-02, 8.35E-02, % 9.96E-02, 1.99E-01, 2.40E-01, 1.15E-01, 3.16E-02, % 8.03E-01, 5.75E-01, 0./ data bdi/0., % 0.3,0., % 3.0, 0.5, 2.0, 0.2, 0.2, 0., % 3.8, 4.1, 1.4, 3.0, 0.2, 0.2, 0., % 2.5, 3.3, 6.0, 2.0, 3.2, 0.2, 0.2, % 0., % 1.9, 0.6, 0.7, 4.3, 4.8, 1.6, 5.0, % 0.2, 0.2, 0., % 0., 0., 3., 3.2, 3.2, 6.7, % 4.4, 3.5, 10., 0.2, 0.2, 0., % 0., 0., 0., 0., 10., 4., 8., % 6.3, 6., 5., 10.5, 0.2, 0.2, 0., % 0., 2.5, 6.0, 0., 0., 0., 22., % 6.4, 13., 6.8, 6.3, 4.1, 12., 0.2, % 0.2, 0., % .005, .045, .057, .087, .0769, .140, .120, .100, 1.92, % 1.66, 1.67, 1.40, 1.31, 1.02, .245, .294, .277, 0., % 0.0907,.110,.0174,.132,.114,.162,.0878,.263,.0627, % .0616,2.77,2.23,2.00,1.82,.424,.243,.185,.292,.275, % 0., % 6*0.,1.3,4*0.4, 0.8, 2.7, 0.1, 1.9, 0.1, % 26., 23., 17., 8., 11.7, 15.4, 29., % 0.3, 0.3, 0., % .469, .357, .281, .128, .0417, .0558, .0346, 0., % 1.90, .277, .135, .134, .192, .332, .337, .121, % .0514, .183, 7.56, 4.55, 4.87, 2.19, 1.15, 1.23, % .132, .289, .286, 0./ data t0/0., % 47.,0., % 11., 15., 9.1, 340., 410., 0., % 13., 14., 18., 11., 470., 540., 0., % 17., 17., 18., 22., 13., 620., 700., % 0., % 31., 29., 26., 24., 24., 29., 17., % 980., 1100., 0., % 5.1, 61., 44., 39., 34., 31., % 31., 36., 21., 1400., 1500., 0., % 11., 12., 10., 120., 55., 49., % 42., 38., 37., 42., 25., 1900., % 2000., 0., % 11., 12., 13., 18., 15., 190., % 67., 59., 55., 47., 42., 50., % 30., 2400., 2500., 0., % 32., 29., 23.9, 25.6, 25.0, 21.0, 18., 270., 83., % 69.5, 60.5, 66.8, 65.0, 53.0, 35.5, 3010.,3130.,0., % 3.46,38.5,40.8,38.2,35.3,31.9,32.2,24.7,22.9,373.,92.6, % 79.6,69.0,67.0,47.2,56.7,42.1,3650.,3780.,0., % 5.8, 13., 28., 37., 49., 63., % 68., 77., 73., 71., 68., 61., 59., % 43., 35., 770., 100., 87., 62., 69., % 68., 67., 41., 5800., 5900., 0., % 9.82, 20.1, 30.5, 42.0, 55.6, 67.2, 79.3, 90.0, 100., % 78.1, 76.4, 74.4, 66.5, 59.7, 52.4, 49.6, 44.6, 849., % 136., 123., 106., 125., 123., 33.2, 64.5, 6650., % 6810., 0./ data t1/0., % 9.4,0., % 4.9, 23., 37., 51., 76., 0., % 4.8, 6.8, 38., 59., 72., 98., 0., % 13., 5.8, 9.1, 59., 80., 95., 130., % 0., % 15., 17., 45., 17., 35., 110., 130., % 140., 260., 0., % 0., 0., 41., 87., 100., 54., % 36., 160.,210.,240.,350., 0., % 0., 0., 0., 0., 100., 130., 170., % 60., 110., 250., 280., 310., 440., 0., % 0., 8.8, 15., 0., 0., 0., % 180., 200., 230., 120., 130., 340., % 360., 460., 550., 0., % 31., 55., 60., 38.1, 33., 21.5, 21.5, 330., 350., % 360., 380., 290., 360., 280., 110., 605., 654., 0., % 1.64,24.5,42.7,69.2,87.8,74.3,69.9,44.3,28.1,584., % 489.,462.,452.,332.,137.,441.,227.,725.,768.,0., % 6*0.,36.,63., 85., 89., 100., 120., 190., % 190., 250., 90., 630., 770., 620., 510., % 870., 990., 1000., 980., 1200., 0., % 10.1, 19.1, 23.2, 31.8, 45.5, 55.1, 52.8, 0.00, 55.0, % 88.7, 180.,125., 189., 88.4, 129., 62.4, 159., 801., % 932., 945., 945., 801., 757., 264., 193., 1190., % 908., 0./ data gli /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9.,6.,1., * 2.,1./ data gfe /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9., * 6.,1.,10.,21.,28.,25.,6.,25.,30.,25./ data gni /2.,1.,2.,1.,6.,9.,4.,9.,6.,1.,2.,1.,6.,9.,4.,9., * 6.,1.,10.,21.,28.,25.,6.,25.,28.,21.,10.,21./ c c parameters for calculating density dependent correction ap from Raymond c DATA cdd/.24E-02,.1430E-01,.9094E-03,.3500E-01,.3050E-01, $ .9043E-02,.1077E-01,.2585E-03,.1953E-03,.8000E-01, $ .8715E-02,.1346E-01,.4753E-02,.6304E-02,.1601E-03, $ .1574E-03,.5600E-01,.1610E-01,.4081E-02,.7718E-02, $ .2910E-02,.4070E-02,.1059E-03,.1306E-03,.3370E-01, $ .1023E-01,.4726E-02,.3410E-02,.1660E-02,.3649E-02, $ .1412E-02,.2040E-02,.5280E-04,12*0.,.9555E-04,.8100E-01, $ .4168E-01,.2792E-01,.2585E-01,.2137E-02,.7325E-03, $ .8059E-03,.7821E-03,.6306E-03,.1501E-02,.5546E-03, $ .7711E-03,.1760E-04,.5965E-04,.6600E-01,.2842E-01, $ .1740E-01,.1579E-01,.1355E-01,.1221E-01,.1272E-02, $ .3673E-03,.4921E-03,.4976E-03,.4592E-03,.1108E-02, $ .3973E-03,.5326E-03,.1098E-04,.4948E-04,18*0.,20*0.,9*0., $ .2030E-02,.2299E-02,.2313E-02,.2233E-02,.2734E-02, $ .2934E-02,.2319E-02,.3406E-03,.5245E-04,.1246E-03, $ .1320E-03,.1711E-03,.4206E-03,.1339E-03,.1461E-03, $ .1015E-05,.2508E-04,28*0./ c data dcfe/2.2e-4,2.3e-3,1.5e-2,3.8e-2,8.0e-2,9.2e-2, & 0.16,0.18,0.14,0.1,0.225,0.24,0.26,0.19, & 0.12,1.23,2.53e-3,5.67e-3,1.6e-2,1.85e-2,9.2e-4, & 0.131,1.1e-2,0.256,0.43,0.,1.e-4,2.7e-3, & 4.7e-3,1.6e-2,2.4e-2,4.1e-2,3.6e-2,0.07,0.26, & 0.28,0.231,0.17,0.16,0.09,0.12,0.,3.36e-2, & 7.82e-2,7.17e-2,9.53e-2,0.129,8.49e-2,4.88e-2, & 0.452,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., & 0.,0.,0.,0.,0.,0.,0.6,0.,0.181,3.18e-2, & 9.06e-2,7.9e-2,0.192,0.613,8.01e-2,0.,0.,0., & 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., & 0.,0.,0.,0.,1.92,1.26,0.739,1.23,0.912,0., & 0.529,0.,0.,0./ data defe/5.12,16.7,28.6,37.3,54.2,45.5,66.7,66.1, & 21.6,22.2,59.6,75.,36.3,39.4,24.6,560.,22.5, & 16.2,23.7,13.2,39.1,73.2,0.1,4.625e3,5.3e3, & 0.,12.9,31.4,52.1,67.4,100.,360.,123.,129., & 136.,144.,362.,205.,193.,198.,248.,0.,117., & 96.,85.1,66.6,80.3,316.,36.2,6.e3,0.,0., & 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., & 0.,0.,560.,0.,341.,330.,329.,297.,392., & 877.,306.,0.,0.,0.,0.,0.,0.,0.,0.,0., & 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,683., & 729.,787.,714.,919.,0.,928.,0.,0.,0./ c data istorey/5,6,7,11,12,13,14,18,19,20,21,22,0/ data rstorey/ 0.0108,-0.1075, 0.2810,-0.0193,-0.1127, $ 1.8267, 4.1012, 4.8443, 0.2261, 0.5960, $ 2.3196,10.7328, 6.8830,-0.1824, 0.4101, $ 0.0000, 0.6310, 0.1990,-0.0197, 0.4398, $ 0.0320,-0.6624, 4.3191, 0.0003, 0.5946, $ -0.8806,11.2406,30.7066,-1.1721, 0.6127, $ 0.4134,-4.6319,25.9172,-2.2290,-0.2360, $ 0.0000, 0.0238, 0.0659, 0.0349, 0.5334, $ -0.0036, 0.7519, 1.5252,-0.0838, 0.2769, $ 0.0000,21.8790,16.2730,-0.7020, 1.1899, $ 0.0061, 0.2269,32.1419, 1.9939,-0.0646, $ -2.8425, 0.2283,40.4072,-3.4956, 1.7558, $ 5*0./ c data uu/109.6787, 27*0., * 198.3108,438.9089,26*0., * 28*0., * 28*0., * 28*0., * 90.82,196.665,386.241,520.178,3162.395,3952.06, * 22*0., * 117.225,238.751,382.704,624.866,789.537,4452.758, * 5380.089,21*0., * 109.837,283.24,443.086,624.384,918.657,1114.008, * 5963.135,7028.393,20*0., * 28*0., * 173.93,330.391,511.8,783.3,1018.,1273.8,1671.792, * 1928.462,9645.005,10986.876,18*0., * 28*0., * 61.671,121.268,646.41,881.1,1139.4,1504.3,1814.3,2144.7, * 2645.2,2964.4,14210.261,15829.951,16*0., * 28*0., * 65.748,131.838,270.139,364.093,1345.1,1653.9,1988.4, * 2445.3,2831.9,3237.8,3839.8,4222.4,19661.693,21560.63, * 14*0., * 28*0., * 83.558,188.2,280.9,381.541,586.2,710.184,2265.9,2647.4, * 3057.7,3606.1,4071.4,4554.3,5255.9,5703.6,26002.663, * 28182.535,12*0., * 28*0., * 127.11,222.848,328.6,482.4,605.1,734.04,1002.73,1157.08, * 3407.3,3860.9,4347.,4986.6,5533.8,6095.5,6894.2,7404.4, * 33237.173,35699.936,10*0., * 28*0., * 49.306,95.752,410.642,542.6,681.6,877.4,1026.,1187.6, * 1520.64,1704.047,4774.,5301.,5861.,6595.,7215.,7860., * 8770.,9338.,41366.,44177.4,8*0., * 28*0., * 28*0., * 28*0., * 28*0., * 28*0., * 63.737,130.563,247.22,442.,605.,799.,1008.,1218.38, * 1884.,2114.,2341.,2668.,2912.,3163.,3686.,3946.82, * 10180.,10985.,11850.,12708.,13620.,14510.,15797., * 16500.,71203.,74829.,2*0., * 28*0., * 61.6,146.542,283.8,443.,613.5,870.,1070.,1310.,1560., * 1812.,2589.,2840.,3100.,3470.,3740.,4020.,4606., * 4896.2,12430.,13290.,14160.,15280.,16220.,17190., * 18510.,19351.,82984.,86909.4/ c data hfrac/0.75/ data hfrac/1.0/ data ergsev/1.602192e-12/ data cc1/1.e-06/ c c Tim Kallman works with temperatures in units of 10^4 K c t=temp/1.e4 c dirt=0. ini=inid(iont,iatom) if(ini.le.0) return c ekt = t*(0.861707) xst = sqrt(t) hconst = hfrac*ekt*ergsev t3s2=1./(t*xst) tmr = 1.e-6*t3s2 alogt = log10(t) kk = 0 ist=1 j=ini dirt = 0. c dr for iron from Arnaud and Raymond if ( j.lt.115 .or. j.gt.139 ) go to 2901 kk = kk + 1 do 20 n = 1,4 dirt = dirt + dcfe(kk,n)*expo(-defe(kk,n)/ekt) 20 continue dirt = dirt*tmr go to 101 2901 continue c aldrovandi and Pequignot rates c The reference is Aldrovandi, S. M. V. and P\'equignot, D. (1973) c A&A, 25, 137 c c ap is the density dependent correction to dr from Raymond c enn = xpx**(0.2) ap = 1./(1.+cdd(j)*enn) dirt = adi(j)*ap*cc1*expo(-t0(j)/t) & *(1.+bdi(j)*expo(-t1(j)/t)) $ /(t*sqrt(t)) dirtemp=0. c storey dr rates if ((j.ne.(istorey(ist)-1)).or.(t.gt.6.).or.(ist.gt.12)) $ go to 101 dirtemp= $ (1.e-12)*(rstorey(1,ist)/t+rstorey(2,ist) $ +t*(rstorey(3,ist)+t*rstorey(4,ist)))*t3s2 $ *expo(-rstorey(5,ist)/t) dirt=dirt+dirtemp ist=ist+1 101 continue c c pseudo cross-section c if(iatom.le.20) then gp=gli(iont+1) if(gp.le.0) gp=1. gg=gp/gli(iont) else if(iatom.le.26) then gp=gfe(iont+1) if(gp.le.0) gp=1. gg=gp/gfe(iont) else if(iatom.le.28) then gp=gni(iont+1) if(gp.le.0) gp=1. gg=gp/gni(iont) end if frq0=cons*uu(iont,iatom) frq1=1.1*frq0 delfr=frq1-frq0 fra=0.5*(frq0+frq1) x=1.-expo(-4.79928e-11*delfr/temp) sig0=dirt*8.47272e24*gg*sqrt(temp)/fra**2/x return end c c C C C ************************************************************************ C c function expo(x) c ================ c INCLUDE 'IMPLIC.FOR' crit=80. if(x.lt.-crit) x=-crit if(x.gt.crit) x=crit expo=exp(x) return end c C C C ************************************************************************ C c SUBROUTINE IRC(N,T,IC,RNO,SE) c ============================= c C IRC CALCULATES THE EXCITATION RATE, SE [cm**3/s], FOR IONIZATION C OF HYDROGEN ATOMS FROM STATE N DUE TO ELECTRON COLLISIONS, ASSUMING C THE CONTINUUM STARTS AT LEVEL RNO. C REF. JOHNSON (1972) C c a modification of Tim Kallman's XSTAR routine c INCLUDE 'IMPLIC.FOR' IF(IC.NE.1) THEN ! MAB CALL SZIRC(N,T,IC,rno,SE) RETURN END IF c XO=1.-N*N/RNO/RNO YN=XO*157803./(T*N*N) IF(N.LE.1) THEN AN=1.9603*N*(1.133/3./XO**3-0.4059/4./XO**4+0.07014/5./XO**5) BN=2./3.*N*N/XO*(3.+2./XO-0.603/XO/XO) RN=0.45 ELSE IF(N.EQ.2) THEN AN=1.9603*N*(1.0785/3./XO**3-0.2319/4./XO**4+0.02947/5./XO**5) BN=(4.-18.63/N+36.24/(N*N)-28.09/(N*N*N))/N BN=2./3.*N*N/XO*(3.+2./XO+BN/XO/XO) RN=0.653 ELSE G0=(0.9935+0.2328/N-0.1296/(N*N))/3./XO**3 G1=-(0.6282-0.5598/N+0.5299/(N*N))/(N*4.)/XO**4 G2=(0.3887-1.181/N+1.470/(N*N))/(N*N*5.)/XO**5 AN=1.9603*N*(G0+G1+G2) BN=(4.-18.63/N+36.24/(N*N)-28.09/(N*N*N))/N BN=(3.+2./XO+BN/XO/XO)*2.*N*N/3./XO RN=1.94*N**(-1.57) END IF C RN=RN*XO ZN=RN+YN CALL EXPINX(YN,EY) CALL EXPINX(ZN,EZ) SE=AN*(EY/YN/YN-EXP(-RN)*EZ/ZN/ZN) EY=1.+1./YN-EY*(2./YN+1.) EZ=EXP(-RN)*(1.+1./ZN-EZ*(2./ZN+1.)) SE=SE+(BN-AN*LOG(2.*N*N/XO))*(EY-EZ) SE=SE*SQRT(T)*YN*YN*N*N*1.095E-10/XO RETURN END c C C C ************************************************************************ C c subroutine szirc(nn,T,ic,rno,cii) c ================================= c c calculates electron impact ionizition rates from semiempirical c formula (eq.35) from Sampson & Zhang (1988, ApJ 335, 516) c c a modification of Tim Kallman's XSTAR routine c INCLUDE 'IMPLIC.FOR' real abethe(11), hbethe(11), rbethe(11) DATA(abethe(i),i=1,11)/ 1.134, 0.603, 0.412, 0.313, 0.252, 1 0.211, 0.181, 0.159, 0.142, 0.128, 1.307 / DATA(hbethe(i),i=1,11)/ 1.48, 3.64, 5.93, 8.32, 10.75, 12.90, 1 15.05, 17.20, 19.35, 21.50, 2.15 / DATA(rbethe(i),i=1,11)/ 2.20, 1.90, 1.73, 1.65, 1.60, 1.56, 1 1.54, 1.52, 1.52, 1.52, 1.52 / rz=ic Boltz=1.38066e-16 Eion=2.179874e-11 const=4.6513e-3 C rc=float(int(rno)) if (nn.lt.11) then an=abethe(nn) hn=hbethe(nn) rrn=rbethe(nn) else an=abethe(11)/float(nn) hn=hbethe(11)*float(nn) rrn=rbethe(11) endif tt= T*Boltz rn=float(nn) yy=rz*rz*Eion/tt*(1./rn/rn-1./rc/rc-.25*(1./(rc-1.)**2- c 1./rc/rc)) call eint(yy,e1,e2,e3) cii=const*sqrt(tt)*(rn**5)/(rz**4)*an*yy* ( 1 e1/rn-(exp(-yy)-yy*e3)/(3.*rn)+(yy*e2-2.*yy*e1+exp(-yy))* 2 3.*hn/rn/(3.-rrn)+(e1-e2)*3.36*yy) return end C C C ************************************************************************ C c subroutine expinx(x,em1) c ======================== c c expinx is a subroutine to calculate the value of e1, the exponential c integral or em1=x*expo(x)*e1 at the point x. the polynomial c expressions that are used come from abromowitz and stegen c c a modification of Tim Kallman's XSTAR routine c c INCLUDE 'IMPLIC.FOR' if(x.gt.1.) then b1=9.5733223454 b2=25.6329561486 b3=21.0996530827 b4=3.9584969228 c1=8.5733287401 c2=18.0590169730 c3=8.6347608925 c4=0.2677737343 em1=x**4+c1*x**3+c2*x*x+c3*x+c4 em1=em1/(x**4+b1*x*x*x+b2*x*x+b3*x+b4) else a0=-0.57721566 a1=0.99999193 a2=-0.24991055 a3=0.05519968 a4=-0.00976004 a5=0.00107857 if(x.gt.0) then e1= a0+a1*x+a2*x*x+a3*x**3+a4*x**4+a5*x**5-log(x) else e1=-a0+a1*x+a2*x*x+a3*x**3+a4*x**4+a5*x**5-log(-x) end if em1=e1*x*expo(x) end if return end C C C ************************************************************************ C subroutine eint(t,e1,e2,e3) c ============================ c c returns the values of the exponential integral function of order c 1, 2, and 3 c c a modification of Tim Kallman's XSTAR routine c INCLUDE 'IMPLIC.FOR' e1=0. e2=0. e3=0. call expinx(t,ss) e1=ss/t/expo(t) e2=exp(-t)-t*e1 e3=0.5*(expo(-t)-t*e2) return end c c C C C ************************************************************************ C C SUBROUTINE COMSET C ================= C C sets up necessary parameters for treating the Compton scattering c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' dimension freqi(mfreq) parameter (xcon=8.0935d-21,YCON=1.68638E-10) parameter (t15=1.d-15) common/auxcbc/cden1m(mdepth),cden10(mdepth), * cden2m(mdepth),cden20(mdepth) common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc) DIMENSION PL(MDEPTH),PLM(MDEPTH) C if(icompt.le.0) go to 100 nmuc=3 nsti=0 nedd=3 C C frequency-dependent universal parameters C do ij=1,nfreq cder10(ij)=0. cder1p(ij)=0. cder1m(ij)=0. cder20(ij)=0. cder2p(ij)=0. cder2m(ij)=0. iji=nfreq-kij(ij)+1 ijorig(iji)=ij freqi(iji)=freq(ij) fr=freqi(iji) bnus(iji)=two*xcon*fr/(bn*(fr*1.d-15)**3) end do C ij=1 dlnfr(ij)=log(freqi(ij+1)/freqi(ij)) do ij=2,nfreq-1 dlnfr(ij)=log(freqi(ij+1)/freqi(ij)) delp=dlnfr(ij) delm=dlnfr(ij-1) del0=delp+delm cd0=two/del0 cder2m(ij)=cd0/delm cder2p(ij)=cd0/delp cder20(ij)=-cder2m(ij)-cder2p(ij) end do c do ij=1,nfreq-1 frj0=freqi(ij) frjp=freqi(ij+1) frz=sqrt(frj0*frjp) do id=1,nd C to avoid over/underflow problems: IF(HK*FRJ0/TEMP(ID).LT.200.) THEN fjb0=un/(exp(hk*frj0/temp(id))-un) ELSE fjb0=0. ENDIF IF(HK*FRJP/TEMP(ID).LT.200.) THEN fjbp=un/(exp(hk*frjp/temp(id))-un) ELSE fjbp=0. ENDIF fjz0=fjb0*(bn*(frj0*t15)**3) fjzp=fjbp*(bn*(frjp*t15)**3) if(ichcoo.eq.0) then zj0=hk*frz/temp(id) dfjz=fjz0-fjzp dfjb=fjb0-fjbp fzz=un+fjbp-3./zj0 aa=dfjz*dfjb bb=dfjz*fzz+fjzp*dfjb cc=fjzp*fzz-dfjz/dlnfr(ij)/zj0 else e2=ycon*temp(id) zxxp=xcon*frjp*(un+fjbp)-3.*e2 zxx0=xcon*frj0*(un+fjb0)-3.*e2 dzxx=zxx0-zxxp dfjb=fjb0-fjbp dfjz=fjz0-fjzp aa=dfjz*dzxx bb=dfjz*zxxp+fjzp*dzxx cc=fjzp*zxxp-e2*dfjz/dlnfr(ij) end if CXXX to avoid division by zero: if(abs(aa).eq.0.and.abs(bb).eq.0.) then xx1=0. elseif(abs(aa).lt.1.e-7*abs(bb)) then xx1=-cc/bb else dd=bb*bb-4.*aa*cc if(dd.lt.0.) dd=0. dd=sqrt(dd) xx1=(dd-bb)*half/aa if(ichcoo.gt.0) then xx2=-(dd+bb)*half/aa dxx1=abs(xx1-half) dxx2=abs(xx2-half) if(dxx2.lt.dxx1) xx1=xx2 if((xx1.gt.1.).or.(xx1.lt.0.)) xx1=half end if end if delj(ij,id)=xx1 end do end do c C angle-dependent universal parameters C call angset c C frequency-dependent universal parameters C 100 continue do ij=1,nfreq c c first-order expression c if(knish.eq.0) then SIGEC(IJ)=SIGE*(un-two*freq(ij)*xcon) c C Use full Klein-Nishina cross section (Rybicki & Lightman 1975): c else xf=xcon*freq(ij) if(xf.lt.1.d-1) then SIGEC(IJ)=SIGE*(1.-xf*(2.-xf*(26./5.-xf*(13.3 * -xf*(1144./35.-xf*(544./7.-xf*(3784./21. * -xf*(6148./15.-xf*(151552./165. * -xf*111872./55.))))))))) else if(xf.gt.1.d3) then SIGEC(IJ)=SIGE*3./8./xf*(log(2.*xf)+0.5) else SIGEC(IJ)=SIGE*0.75*((1.+xf)/xf**3*(2.*xf*(1.+xf)/ * (1.+2.*xf)-log(1.+2.*xf))+0.5*log(1.+2.*xf)/xf * -(1.+3.*xf)/(1.+2.*xf)**2) endif endif end do c if(icompt.le.0) return IJ=1 IJO=ijorig(ij) DO ID=1,ND PLM(ID)=BNUE(IJO)/(EXP(HK/Temp(ID)*FREQ(IJO))-UN) END DO C DO IJ=2,NFREQ IJO=ijorig(ij) DO ID=1,ND C to avoid over/underflow problems: IF(HK/TEMP(ID)*FREQ(IJO).LT.200.) THEN PL(ID)=BNUE(IJO)/(EXP(HK/temp(ID)*FREQ(IJO))-UN) ELSE PL(ID)=PLM(ID) ENDIF PLM(ID)=PL(ID) END DO END DO C return end C C C ****************************************************************** C c c subroutine angset c ================= c c sets up angles points and angle-dependent quantities for treating c the Compton scattering c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter(three=3.d0, five=5.d0, zero=0.d0, tr16=3.d0/16.d0) dimension amu0(mmuc),wtmu0(mmuc) c c amu=cos(angle between line of sight and normal to slab) grid and c gauss-legendre integration weights for the interval mu=[0,1] c call gauleg(zero,un,amu0,wtmu0,nmuc,mmuc) c do i=1,nmuc amuc(i)=-amu0(nmuc-i+1) amuc(i+nmuc)=amu0(i) wtmuc(i)=wtmu0(nmuc-i+1) wtmuc(i+nmuc)=wtmu0(i) end do nmuc=2*nmuc c do i=1,nmuc amuc1(i)=amuc(i)*wtmuc(i) amuc2(i)=amuc(i)*amuc(i)*wtmuc(i) amuc3(i)=amuc(i)*amuc(i)*amuc(i)*wtmuc(i) a1=amuc(i) a2=a1*a1 a3=a1*a2 do i1=1,nmuc b1=amuc(i1) b2=b1*b1 b3=b1*b2 trw=tr16*wtmuc(i1) calph(i,i1)=(three*a2*b2-a2-b2+three)*trw cbeta(i,i1)=(five*(a1*b1+a3*b3)-three*(a3*b1+a1*b3))*trw cgamm(i,i1)=a1*b1*trw end do end do c return end C C C ********************************************************************* C C SUBROUTINE GAULEG(X1,X2,X,W,N,M) C ================================ C C set up angle points C INCLUDE 'IMPLIC.FOR' DIMENSION X(M),W(M) PARAMETER (EPS=3.D-14,half=0.5d0,pi=3.141592654d0,quart=0.25, * un=1.d0, two=2.d0) c N2=(N+1)/2 XM=HALF*(X2+X1) XL=HALF*(X2-X1) DO I=1,N2 Z=COS(PI*(I-quart)/(N+half)) 1 CONTINUE P1=1.D0 P2=0.D0 DO J=1,N P3=P2 P2=P1 P1=((TWO*J-UN)*Z*P2-(J-UN)*P3)/J END DO PP=N*(Z*P1-P2)/(Z*Z-un) Z1=Z Z=Z1-P1/PP IF(ABS(Z-Z1).GT.EPS) GO TO 1 X(I)=XM-XL*Z X(N+1-I)=XM+XL*Z W(I)=TWO*XL/((UN-Z*Z)*PP*PP) W(N+1-I)=W(I) END DO RETURN END C C C C **************************************************************** C C subroutine rte_sc(dtau,st0,rup,rdown,amu0,ri,ali) C ================================================ C C formal solver of the radiative transfer equation C for one frequency, angle, and for completely known source function; c using short characteristics C c c input: dtau - optical depth increments Delta tau c st0 - total source function c rup - intensity at the upper boundary (id=1) c rdown- intensity at the lower boundary (id=nd) c amu0 - cosine of angle of propagation (wrt. the normal) c output: ri - radiation intensity c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' dimension dtau(mdepth),st0(mdepth),ri(mdepth),ali(mdepth), * dtx1(mdepth),dtx2(mdepth),dtx0(mdepth) C do id=1,nd-1 dtx1(id)=exp(-dtau(id)) dtx2(id)=(un-dtx1(id))/dtau(id) dtx0(id)=un-dtx2(id) end do c c incoming intensity c if(amu0.lt.0) then c ID=1 ri(id)=rup do id=1,nd-1 ri(id+1)=ri(id)*dtx1(id)+st0(id)*(dtx2(id)-dtx1(id))+ * st0(id+1)*dtx0(id) ali(id+1)=dtx0(id) end do ali(1)=0. C c outgoing intensity c else c ri(nd)=rdown do id=nd-1,1,-1 ri(id)=ri(id+1)*dtx1(id)+st0(id)*dtx0(id)+ * st0(id+1)*(dtx2(id)-dtx1(id)) ali(id)=dtx0(id) end do ali(nd)=0. end if return end C C C C **************************************************************** C C subroutine rtesol(dtau,st0,rup,rdown,amu0,ri,ali) C ================================================ C C formal solver of the radiative transfer equation C for one frequency, angle, and for completely known source function; c by the Discontinuous Finite Element method c Castor, Dykema, Klein, 1992, ApJ 387, 561. c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (one=1.d0) dimension dtau(mdepth),st0(mdepth),ri(mdepth),ali(mdepth), * rim(mdepth),rip(mdepth),aim(mdepth),aip(mdepth) c c incoming intensity c if(amu0.lt.0) then c id=1 rip(id)=rup dt0=dtau(id) dtaup1=dt0+one dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=dtau2+bb rim(id)=(aa*rip(id)-cc*st0(id)+dt0*st0(id+1))/bb do id=1,nd-1 dt0=dtau(id) dtaup1=dt0+one dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=dtau2+bb rim(id+1)=(two*rim(id)+dt0*st0(id)+cc*st0(id+1))/aa rip(id)=(bb*rim(id)+cc*st0(id)-dt0*st0(id+1))/aa aim(id+1)=cc/aa aip(id)=(cc+bb*aim(id))/aa enddo do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) ri(id)=(rim(id)*dtau(id)+rip(id)*dtau(id-1))*dtt ali(id)=(aim(id)*dtau(id)+aip(id)*dtau(id-1))*dtt enddo ri(1)=rip(1) ri(nd)=rim(nd) ali(1)=aim(1) ali(nd)=aim(nd) C c outgoing intensity c else c rip(nd)=rdown id=nd-1 dt0=dtau(id) dtaup1=dt0+one dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=dtau2+bb rim(id+1)=(aa*rip(id+1)-cc*st0(id+1)+dt0*st0(id))/bb do id=nd-1,1,-1 dt0=dtau(id) dtaup1=dt0+one dtau2=dt0*dt0 bb=two*dtaup1 cc=dt0*dtaup1 aa=dtau2+bb rim(id)=(two*rim(id+1)+dt0*st0(id+1)+cc*st0(id))/aa rip(id+1)=(bb*rim(id+1)+cc*st0(id+1)-dt0*st0(id))/aa aim(id)=cc/aa aip(id+1)=(cc+bb*aim(id+1))/aa enddo do id=2,nd-1 dtt=un/(dtau(id-1)+dtau(id)) ri(id)=(rim(id)*dtau(id-1)+rip(id)*dtau(id))*dtt ali(id)=(aim(id)*dtau(id-1)+aip(id)*dtau(id))*dtt enddo ri(1)=rim(1) ri(nd)=rip(nd) ali(1)=aim(1) ali(nd)=aim(nd) end if c return end C C C **************************************************************** C C subroutine rtefe2(dtau,s,rup,rdown,ri) C ====================================== C C formal solver of the radiative transfer equation C for one frequency, angle, and for completely known source function; c original Feautrier (second-order) scheme c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (one=1.d0) dimension dtau(mdepth),s(mdepth),ri(mdepth) dimension a(mdepth),b(mdepth),c(mdepth),d(mdepth), * f(mdepth),v(mdepth),z(mdepth) c c set up the global tridiagonal matrix c c upper boundary condition c id=1 cc=two/dtau(id) c(id)=cc/dtau(id) b(id)=one+cc+c(id) a(id)=0. v(id)=s(id)+cc*rup c c normal depth points c do id=2,nd-1 dtinv=two/(dtau(id-1)+dtau(id)) a(id)=dtinv/dtau(id-1) c(id)=dtinv/dtau(id) b(id)=one+a(id)+c(id) v(id)=s(id) enddo c c lower boundary condition c id=nd aa=two/dtau(id-1) a(id)=aa/dtau(id-1) b(id)=one+aa+a(id) if(rdown.eq.0.) b(id)=one+a(id) c(id)=0. v(id)=s(id)+aa*rdown c c --------------------------------------------------- c solution by elimination c 1. forward sweep c f(1)=(b(1)-c(1))/c(1) d(1)=one/(one+f(1)) z(1)=v(1)/b(1) c c ii) normal depth points c do id=2,nd-1 f(id)=(b(id)-a(id)-c(id)+a(id)*f(id-1)*d(id-1))/c(id) d(id)=one/(one+f(id)) z(id)=(v(id)+a(id)*z(id-1))*d(id)/c(id) enddo c c iii) upper boundary c id=nd z(id)=(v(id)+a(id)*z(id-1))/(b(id)-a(id)*d(id-1)) c c 2. backward elimination c ri(nd)=z(nd) do id=nd-1,1,-1 ri(id)=ri(id+1)*d(id)+z(id) enddo c return end C C C C **************************************************************** C C SUBROUTINE RTECF0(IJ) C ===================== C C Setup of the individual matrix elements of matrices A,B,C, E,U,V, C and alpha, beta, gamma, for solving the coupled transfer equation C with Compton scattering C Evaluation for a given frequency point IJ. C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' COMMON/OPTDPT/DT(MDEPTH) PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) COMMON/AUXRTE/ * COMA(MDEPTH),COMB(MDEPTH),COMC(MDEPTH),VL(MDEPTH), * COME(MDEPTH),U(MDEPTH),V(MDEPTH),BS(MDEPTH), * AL(MDEPTH),BE(MDEPTH),GA(MDEPTH) common/auxcbc/cden1m(mdepth),cden10(mdepth), * cden2m(mdepth),cden20(mdepth) c IJI=NFREQ-KIJ(IJ)+1 FR=FREQ(IJ) frp=freq(ijorig(iji+1)) frm=freq(ijorig(iji-1)) xcomp=fr*xcon C C optical depth scale C do id=1,nd-1 dt(id)=deldmz(id)*(absot(id+1)+absot(id)) end do C C depth discretization matrices C c 1. upper boundary c id=1 dtp1=dt(id) bb0=un/dtp1 bb1=two*bb0*bb0 be(id)=bb0*two*fh(ij)+bb1*fak(ij,id) ga(id)=bb1*fak(ij,id+1) sext=two*bb0*hextrd(ij) c c 2. normal depth point c do id=2,nd-1 dtm1=dtp1 dtp1=dt(id) dt0=two/(dtm1+dtp1) al(id)=fak(ij,id-1)/dtm1*dt0 ga(id)=fak(ij,id+1)/dtp1*dt0 be(id)=fak(ij,id)*dt0*(un/dtm1+un/dtp1) end do c c 3. lower boundary c id=nd c c stellar atmospheric c IF(IDISK.EQ.0.OR.IFZ0.LT.0) then IF(IBC.EQ.0) THEN be(ID)=fak(ij,id)/DTP1+HALF al(ID)=fak(ij,id-1)/DTP1 ELSE IF(IBC.LT.4) THEN B=UN/DTP1 A=TWO*B*B be(id)=B*TWO*fhd(ij)+a*fak(ij,id) al(id)=a*fak(ij,id-1) ELSE B=UN/DTP1 A=TWO*B*B be(id)=b+a*fak(ij,id) al(id)=a*fak(ij,id-1) END IF c c accretion disk - symmetric boundary c ELSE bb0=un/dtp1 bb1=two*bb0*bb0 B=TWO/DTP1 be(id)=bb1*fak(ij,id) al(id)=bb1*fak(ij,id-1) END IF C C scattering matrices C do id=1,nd scat0=elec(id)*sige sa0=emis1(id)/abso1(id) ss0=scat0/abso1(id) epsnu=(abso1(id)-scat1(id))/abso1(id) x0=ss0 e2=ycon*temp(id)+0.7*xcomp*xcomp e1=xcomp-3.*e2-0.7*xcomp*xcomp e0=1.-xcomp-4.2*xcomp*xcomp coma(id)=0. comc(id)=0. u(id)=0. v(id)=0. vl(id)=sa0 if(id.eq.1.and.iwinbl.lt.0) vl(id)=sa0+sext bs(id)=0. if(iji.eq.1) then comc(id)=0. comb(id)=x0*(un-2.*xcomp) else if(iji.lt.nfreq) then del0=two/(dlnfr(iji)+dlnfr(iji-1)) cder1p(iji)=(un-delj(iji,id))*del0 cder1m(iji)=-delj(iji-1,id)*del0 if(ichcoo.eq.0) then cder10(iji)=-cder1m(iji)-cder1p(iji) coma(id)=x0*(e1*cder1m(iji)+e2*cder2m(iji)) comb(id)=x0*(e0+e1*cder10(iji)+e2*cder20(iji)) comc(id)=x0*(e1*cder1p(iji)+e2*cder2p(iji)) x0=ss0*bnus(iji) IF(ICOMST.EQ.0) X0=0. come(id)=x0*(cder10(iji)-un) u(id)=x0*cder1m(iji) v(id)=x0*cder1p(iji) bs(id)=come(id)*rad(iji,id)+ * u(id)*rad(iji-1,id)+v(id)*rad(iji+1,id) else cder10(iji)=-del0*(un-delj(iji-1,id)-delj(iji,id)) zxxp=xcon*frp+0.5*bnus(iji+1)*rad(iji+1,id)-3.*e2 zxx0=xcomp+0.5*bnus(iji)*rad(iji,id)-3.*e2 zxxm=xcon*frm+0.5*bnus(iji-1)*rad(iji-1,id)-3.*e2 zxxp12=((un-delj(iji,id))*zxxp+delj(iji,id)*zxx0)*del0 zxxm12=((un-delj(iji-1,id))*zxx0+delj(iji-1,id)*zxxm)* * del0 coma(id)=x0*(-delj(iji-1,id)*zxxm12+e2*cder2m(iji)) comc(id)=x0*((un-delj(iji,id))*zxxp12+e2*cder2p(iji)) comb(id)=x0*(delj(iji,id)*zxxp12-(un-delj(iji-1,id))* * zxxm12+e2*cder20(iji))-epsnu+1 end if else dlt=delj(iji-1,id) zj1=exp(-hk*freq(ij)/temp(id)) zj2=exp(-hk*freq(ij+1)/temp(id)) if(ichcoo.eq.0) then zj0=un/(hk*sqrt(freq(ij)*freq(ij+1))/temp(id)) zxx=un-3.*zj0+(un-dlt)*zj1+dlt*zj2 comb(id)=zj0/dlnfr(iji-1)+(un-dlt)*zxx coma(id)=-zj0/dlnfr(iji-1)+dlt*zxx else zxx0=xcomp*(un+zj1)-3.*e2 zxxm=xcon*frm*(un+zj2)-3.*e2 zxx=(un-dlt)*zxx0+dlt*zxxm comb(id)=e2/dlnfr(iji-1)+(un-dlt)*zxx coma(id)=-e2/dlnfr(iji-1)+dlt*zxx end if vl(id)=0. if(icomde.ne.0) then al(id)=0. be(id)=-un ga(id)=0. end if end if if(icomde.eq.0) then coma(id)=0. comc(id)=0. comb(id)=x0*(un-2.*xcomp) end if end do C return end C C C **************************************************************** C C SUBROUTINE INICOM C ================= C C Auxiliary procedure for INILAM C initialization of g-factors for the Compton scattering C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc) DIMENSION PL(MDEPTH),PLM(MDEPTH) C IJ=1 IJO=ijorig(ij) DO ID=1,ND PLM(ID)=BNUE(IJO)/(EXP(HKT1(ID)*FREQ(IJO))-UN) END DO C DO IJ=2,NFREQ IJO=ijorig(ij) DO ID=1,ND PL(ID)=BNUE(IJO)/(EXP(HKT1(ID)*FREQ(IJO))-UN) PLM(ID)=PL(ID) END DO END DO C RETURN END C C C **************************************************************** C C SUBROUTINE RTECOM C ================= C C Solution of the radiative transfer equation with Compton scattering C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' COMMON/OPTDPT/DT(MDEPTH) COMMON/AUXRTE/ * COMA(MDEPTH),COMB(MDEPTH),COMC(MDEPTH),VL(MDEPTH), * COME(MDEPTH),U(MDEPTH),V(MDEPTH),BS(MDEPTH), * AL(MDEPTH),BE(MDEPTH),GA(MDEPTH) common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc) dimension aa(mdepth),bb(mdepth),cc(mdepth), * d(mdepth),f(mdepth),z(mdepth),rd(mdepth) c PRD0=0. DO ID=1,ND PRADT(ID)=0. END DO c c --------------------------------------------- c "1st formal solution" to update Eddington factors c --------------------------------------------- c if(ncfor1.gt.0) then do iform=1,ncfor1 ij0=1 if(icombc.gt.0) ij0=2 DO IJ=ij0,NFREQ CALL OPACF1(IJ) CALL RTECF1(IJ) END DO if(icombc.gt.0) then ij=1 iji=nfreq call rtecf0(ij) do id=1,nd rad(iji,id)=-rad(iji-1,id)*coma(id)/(comb(id)+bs(id)) end do end if end do end if c c ----------------------------------------------- c coupled solution for the frequency derivatives terms c ----------------------------------------------- c c fully coupled treatment - traditional formulation c if(ncfull.gt.0) then do icfull=1,ncfull call rtecmc c c iterative treatment of the derivative terms c if(ncitot.gt.0) then do ictot=1,ncitot c if(nccoup.gt.0) then do iccoup=1,nccoup do ij=1,nfreq ijo=ijorig(ij) fr=freq(ijo) call opacf1(ijo) call rtecf0(ijo) do id=1,nd comb(id)=comb(id)+bs(id) bb(id)=be(id)+un-comb(id) aa(id)=al(id) cc(id)=ga(id) vl(id)=vl(id)+ * (coma(id)*gfm(ij,id)+ * comc(id)*gfp(ij,id))*rad(ij,id) end do c c ---------------- c forward sweep c ---------------- c c i) upper boundary c f(1)=(bb(1)-cc(1))/cc(1) d(1)=un/(un+f(1)) z(1)=vl(1)/bb(1) c c ii) normal depth points c do id=2,nd-1 f(id)=(bb(id)-aa(id)-cc(id)+ * aa(id)*f(id-1)*d(id-1))/cc(id) d(id)=un/(un+f(id)) z(id)=(vl(id)+aa(id)*z(id-1))*d(id)/cc(id) end do c c iii) lower boundary c id=nd z(id)=(vl(id)+aa(id)*z(id-1))/(bb(id)-aa(id)*d(id-1)) c c -------------------- c backward elimination c -------------------- c rd(nd)=z(nd) do id=nd-1,1,-1 rd(id)=rd(id+1)*d(id)+z(id) end do c do id=1,nd rad(ij,id)=rd(id) end do end do end do end if c c --------------------------------------------- c "2nd formal solution" to update Eddington factors c --------------------------------------------- c if(ncfor2.gt.0) then do iform=1,ncfor2 ij0=nfreq if(icombc.gt.0) ij0=nfreq-1 PRD0=0. DO ID=1,ND PRADT(ID)=0. END DO DO IJ=1,ij0 ijo=ijorig(ij) CALL OPACF1(IJo) CALL RTECF1(IJo) END DO PRD0=PRD0*PCK DO ID=1,ND PRADT(ID)=PRADT(ID)*PCK END DO if(icombc.gt.0) then ij=1 iji=nfreq call rtecf0(ij) do id=1,nd radcm(iji,id)=-radcm(iji-1,id)*coma(id)/ * (comb(id)+bs(id)) end do flux(1)=radcm(iji,1)*fh(2) end if c do id=1,nd DO IJ=1,NFREQ rad(ij,id)=radcm(ij,id) END DO end do c end do end if c end do end if c c --------------------------------------------- c end of formal solutions c --------------------------------------------- c end do end if return end c C C C **************************************************************** C C C SUBROUTINE RTECF1(IJ) C ===================== C C Solution of the radiative transfer equation with Compton scattering C for one frequency (assuming the radiation intensity in i C other frequencies is given C solution is done for individual angles, and new Eddington factors C are determined C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0) COMMON/OPTDPT/DT(MDEPTH) COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ) COMMON/EXTINT/WANGLE,EXTIN(MFREQ) COMMON/AUXRTE/ * COMA(MDEPTH),COMB(MDEPTH),COMC(MDEPTH),VL(MDEPTH), * COME(MDEPTH),U(MDEPTH),V(MDEPTH),BS(MDEPTH), * AL(MDEPTH),BE(MDEPTH),GA(MDEPTH) common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc) DIMENSION RI(MDEPTH),RDH(MDEPTH),RDK(MDEPTH),RDN(MDEPTH), * DTAU(MDEPTH),ST0(MDEPTH),RDWN(MMUC), * ali(mdepth) DIMENSION AANU(MDEPTH),DDD(MDEPTH),FKK(MDEPTH),ali0(mdepth), * SS0(MDEPTH), * AAA(MDEPTH),BBB(MDEPTH),CCC(MDEPTH),EEE(MDEPTH), * ZZZ(MDEPTH),ALRH(MDEPTH),ALRM(MDEPTH),ALRP(MDEPTH), * ss0c(mdepth) C IF(IJ.EQ.1) THEN if(icompt.gt.0.and.icombc.gt.0) then IJE=IJEX(IJ) DO ID=1,ND rad1(id)=rad(nfreq,id) fak1(id)=0.333333 ali1(id)=0. if(ije.gt.0) then RADEX(IJE,ID)=rad1(id) FAKEX(IJE,ID)=fak1(id) END IF END DO return end if END IF C WW=W(IJ) IJI=NFREQ-KIJ(IJ)+1 FR=FREQ(IJ) CALL RTECF0(IJ) c do id=1,nd rad1(id)=0. ali1(id)=0. rdh(id)=0. rdk(id)=0. rdn(id)=0. st0(id)=vl(id)+(comb(id)+bs(id))*rad(iji,id) ss0(id)=0. end do rdh1=0. rdhd=0. c if(iji.gt.1) then do id=1,nd st0(id)=st0(id)+coma(id)*rad(iji-1,id) end do end if if(iji.lt.nfreq) then do id=1,nd st0(id)=st0(id)+comc(id)*rad(iji+1,id) end do end if c if(idisk.eq.0.or.ifz0.lt.0) then FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 PLAND=BNU/(EXP(HK*FR/TEMP(ND))-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMP(ND-1))-UN)*RRDIL IF(TEMPBD.GT.0.) THEN PLAND=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL DPLAN=BNU/(EXP(HK*FR/TEMPBD)-UN)*RRDIL ENDIF DPLAN=(PLAND-DPLAN)/DT(ND-1) end if c if(icomrt.eq.0) then c c ======================================================== c Formal angle-dependent solution done by Feautrier scheme c ======================================================== c c loop over angles points c do i=1,nmu do id=1,nd-1 dtau(id)=dt(id)/amu(i) end do c c boundary conditions c rup=0. rdown=0. rup=extint(ij,i) if(idisk.eq.0.or.ifz0.lt.0) rdown=pland+amu(i)*dplan c c solution of the transfer equation c call rtefe2(dtau,st0,rup,rdown,ri) ttau=0. do id=1,nd riid=wtmu(i)*ri(id) rad1(id)=rad1(id)+riid rdk(id)=rdk(id)+amu(i)*amu(i)*riid end do rdh1=rdh1+amu(i)*wtmu(i)*ri(1) rdhd=rdhd+amu(i)*wtmu(i)*ri(nd) end do rdh1=rdh1-half*hextrd(ij) c c ---------------------- c end of the loop over angle points c c =========================================== c Formal angle-dependent solution done by DFE c =========================================== c else c c loop over angle points c ---------------------- c do i=1,nmuc do id=1,nd-1 dtau(id)=dt(id)/abs(amuc(i)) end do c c boundary conditions c rup=0. rdown=0. if(amuc(i).lt.0.) rup=extint(ij,i) C C diffusion approximation for semi-infinite atmospheres C if(idisk.eq.0.or.ifz0.lt.0) rdown=pland+amuc(i)*dplan c c the case of finite slab - irradiation of the back side c if(amuc(i).gt.0.) rdown=rdwn(nmuc-i+1) c c solution of the transfer equation c call rtesol(dtau,st0,rup,rdown,amuc(i),ri,ali) ttau=0. do id=1,nd riid=ri(id)*half rad1(id)=rad1(id)+wtmuc(i)*riid ali1(id)=ali1(id)+wtmuc(i)*ali(id) rdh(id)=rdh(id)+amuc1(i)*riid rdk(id)=rdk(id)+amuc2(i)*riid rdn(id)=rdn(id)+amuc3(i)*riid end do rdwn(i)=ri(nd) if(amuc(i).gt.0.) rdh1=rdh1+amuc1(i)*ri(1)*half rdhd=rdhd+abs(amuc1(i))*ri(nd)*half end do c c ---------------------- c end of the loop over angle points c end if c do id=1,nd fak1(id)=fak(ij,id) radk(ij,id)=rdk(id) if(icomve .gt. 0) then fkk(id)=rdk(id)/rad1(id) else fkk(id)=fak(ij,id) endif ss0(id)=0. end do if(icomve.gt.0) then do id=1,nd fak(ij,id)=rdk(id)/rad1(id) fak1(id)=fak(ij,id) fkk(id)=fak(ij,id) end do end if if(rad1(1).gt.0.) then flux(ij)=rdh1 fhd(ij)=rdhd/rad1(nd) end if c ah=rdh1 if(iwinbl.lt.0) ah=ah+half*hextrd(ij) aj=rad1(1) fh(ij)=ah/aj C C ******************** C C Again solution of the transfer equation, now with Eddington C FKK and FH determined above, to insure strict consistency of the C radiation field and Eddington factors C C Upper boundary condition C U0=0. QQ0=0. US0=0. TAUMIN=ABSO1(1)*DEDM1 NMU=3 DO I=1,NMU IF(IWINBL.EQ.0.AND.WANGLE.EQ.0.) THEN C C allowance for non-zero optical depth at the first depth point C TAMM=TAUMIN/AMU(I) EX=EXP(-TAMM) P0=UN-EX QQ0=QQ0+P0*AMU(I)*WTMU(I) U0=U0+EX*WTMU(I) if(tamm.gt.0.) US0=US0+P0/TAMM*WTMU(I) END IF END DO ID=1 DTP1=DT(ID) IF(MOD(ISPLIN,3).EQ.0) THEN B=DTP1*HALF C=0. ELSE B=DTP1*THIRD C=B*HALF END IF BQ=UN/(B+QQ0) CQ=C*BQ BBB(ID)=(FKK(ID)/DTP1+FH(IJ)+B)*BQ+SS0(ID) CCC(ID)=(FKK(ID+1)/DTP1)*BQ-CQ*(UN+SS0(ID+1)) ZZZ(ID)=UN/BBB(ID) VLL=ST0(ID)+CQ*ST0(ID+1) c IF(IWINBL.LT.0) VLL=VLL+TWO*HEXTRD(IJ)/DTP1 AANU(ID)=VLL*ZZZ(ID) DDD(ID)=CCC(ID)*ZZZ(ID) IF(ISPLIN.GT.2) FFF=BBB(ID)/CCC(ID)-UN C C Normal depth point C DO ID=2,ND-1 DTM1=DTP1 DTP1=DT(ID) DT0=TWO/(DTP1+DTM1) ALP=UN/DTM1*DT0 GAM=UN/DTP1*DT0 IF(MOD(ISPLIN,3).EQ.0) THEN A=0. C=0. ELSE IF(ISPLIN.EQ.1) THEN A=DTM1*DT0*SIXTH C=DTP1*DT0*SIXTH ELSE A=(UN-HALF*DTP1*DTP1*ALP)*SIXTH C=(UN-HALF*DTM1*DTM1*GAM)*SIXTH END IF AAA(ID)=ALP*FKK(ID-1)-A*(UN+SS0(ID-1)) CCC(ID)=GAM*FKK(ID+1)-C*(UN+SS0(ID+1)) BBB(ID)=(ALP+GAM)*FKK(ID)+(UN-A-C)*(UN+SS0(ID)) VLL=A*ST0(ID-1)+C*ST0(ID+1)+(UN-A-C)*ST0(ID) AANU(ID)=VLL+AAA(ID)*AANU(ID-1) IF(ISPLIN.LE.2) THEN ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) DDD(ID)=CCC(ID)*ZZZ(ID) AANU(ID)=AANU(ID)*ZZZ(ID) ELSE SUM=-AAA(ID)+BBB(ID)-CCC(ID) FFF=(SUM+AAA(ID)*FFF*DDD(ID-1))/CCC(ID) DDD(ID)=UN/(UN+FFF) AANU(ID)=AANU(ID)*DDD(ID)/CCC(ID) ENDIF END DO C C Lower boundary condition C ID=ND c c stellar atmospheric c IF(IDISK.EQ.0.OR.IFZ0.LT.0) then IF(IBC.EQ.0) THEN BBB(ID)=FKK(ID)/DTP1+HALF AAA(ID)=FKK(ID-1)/DTP1 VLL=HALF*PLAND+THIRD*DPLAN ELSE IF(IBC.LT.4) THEN B=UN/DTP1 A=TWO*B*B BBB(ID)=UN+SS0(ID)+B*TWO*FHD(IJ)+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=ST0(ID)+B*(PLAND+TWOTHR*DPLAN) ELSE B=UN/DTP1 A=TWO*B*B BBB(ID)=B+A*FKK(ID) AAA(ID)=A*FKK(ID-1) VLL=B*(PLAND+TWOTHR*DPLAN) END IF c c accretion disk - symmetric boundary c ELSE B=TWO/DTP1 BBB(ID)=FKK(ID)/DTP1*B+UN+SS0(ND) AAA(ID)=FKK(ID-1)/DTP1*B VLL=ST0(ID) END IF C EEE(ND)=AAA(ID)/BBB(ID) ZZZ(ID)=UN/(BBB(ID)-AAA(ID)*DDD(ID-1)) RAD1(ID)=(VLL+AAA(ID)*AANU(ID-1))*ZZZ(ID) FAK1(ID)=FKK(ND) ALRH(ID)=ZZZ(ID) frd=bbb(nd)*rad1(nd)-aaa(nd)*rad1(nd-1) frd1=(bbb(nd)-un)*rad1(nd)-aaa(nd)*rad1(nd-1) C C Backsolution C DO ID=ND-1,1,-1 EEE(ID)=AAA(ID)/(BBB(ID)-CCC(ID)*EEE(ID+1)) RAD1(ID)=AANU(ID)+DDD(ID)*RAD1(ID+1) FAK1(ID)=FKK(ID) C write(42,642),ij,id,rad1(id),st0(id),fak1(id) ALRH(ID)=ZZZ(ID)/(UN-DDD(ID)*EEE(ID+1)) ALRM(ID)=0 ALRP(ID)=0 END DO c C evaluate approximate Lambda operator C C a) Rybicki-Hummer Lambda^star operator (diagonal) C (for JALI = 1) C DO ID=1,ND ALIM1(ID)=0. ALIP1(ID)=0. END DO IF(JALI.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALRH(ID) END DO c IF(IBC.EQ.0) THEN ali1(nd-1)=rad1(nd-1)/st0(nd-1) ali1(nd)=rad1(nd)/st0(nd) END IF C C for IFALI>5: C tridiagonal Rybicki-Hummer operator (off-diagonal terms) C IF(IFALI.GE.6) THEN ALIP1(1)=ALRH(2)*DDD(1) DO ID=2,ND-1 ALIM1(ID)=ALRH(ID-1)*EEE(ID) ALIP1(ID)=ALRH(ID+1)*DDD(ID) END DO ALIM1(ND)=ALRH(ND-1)*EEE(ND) IF(IBC.EQ.0) THEN ALIM1(nd)=0. ALIM1(nd-1)=0. ALIP1(nd)=0. ALIP1(nd-1)=0. END IF END IF c C b) diagonal Olson-Kunasz Lambda^star operator, C (for JALI = 2) C ELSE IF(JALI.EQ.2) THEN DO ID=1,ND-1 ALI0(ID)=0. DO I=1,NMU DIV=DT(ID)/AMU(I) ALI0(ID)=ALI0(ID)+(UN-EXP(-DIV))/DIV*WTMU(I) END DO END DO DO ID=2,ND-1 ALI1(ID)=UN-HALF*(ALI0(ID)+ALI0(ID-1)) END DO ALI1(1)=UN-HALF*(ALI0(1)+US0) ALI1(ND)=UN-ALI0(ND-1) ali1(nd-1)=rad1(nd-1)/st0(nd-1) ali1(nd)=rad1(nd)/st0(nd) END IF C C correction of Lambda^star for scattering C IF(ILMCOR.EQ.1) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)*(UN+SS0(ID)) ALIM1(ID)=ALIM1(ID)*(UN+SS0(ID)) ALIP1(ID)=ALIP1(ID)*(UN+SS0(ID)) END DO ELSE IF(ILMCOR.EQ.3) THEN DO ID=1,ND ALI1(ID)=ALI1(ID)/(UN+SS0C(ID)*ALI1(ID)) ALIM1(ID)=ALIM1(ID)/(UN+SS0C(ID)*ALIM1(ID)) ALIP1(ID)=ALIP1(ID)/(UN+SS0C(ID)*ALIP1(ID)) END DO END IF C DO ID=1,ND radcm(iji,id)=rad1(id) END DO C C radiation pressure C if(.not.lskip(1,IJ)) * PRD0=PRD0+ABSO1(1)*WW*(RAD1(1)*FH(IJ)-HEXTRD(IJ)) DO ID=1,ND if(.not.lskip(ID,IJ)) * PRADT(ID)=PRADT(ID)+RAD1(ID)*FAK1(ID)*WW PRADA(ID)=PRADA(ID)+RAD1(ID)*FAK1(ID)*WW END DO c if(chmax.ge.1.91e-3.and.chmax.le.2.03e-3) then tauij=taumin do id=1,nd if(id.gt.1) tauij=tauij+dt(id-1) write(97,697) ij,id,tauij,rad1(id),st0(id)/(un+ss0(id)), * st0(id),un+ss0(id),ali1(id) end do 697 format(2i4,1p6e12.4) end if c do id=1,nd fak(ij,id)=fak1(id) end do C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0) RETURN IJE=IJEX(IJ) DO ID=1,ND RADEX(IJE,ID)=RAD1(ID) FAKEX(IJE,ID)=FAK1(ID) END DO c RETURN END C C C **************************************************************** C C SUBROUTINE RTECMC C ================= C C Solution of the radiative transfer equation with Compton scattering C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' COMMON/AUXRTE/ * COMA(MDEPTH),COMB(MDEPTH),COMC(MDEPTH),VL(MDEPTH), * COME(MDEPTH),U(MDEPTH),V(MDEPTH),BS(MDEPTH), * AL(MDEPTH),BE(MDEPTH),GA(MDEPTH) common/comgfs/gfm(mfreq,mdeptc),gfp(mfreq,mdeptc) DIMENSION BB(MDEPTC,MDEPTC+1),AA(MDEPTC),CC(MDEPTC), * Z(MFREQ,MDEPTC),D(MFREQ,MDEPTC,MDEPTC), * FF(MDEPTC,MDEPTC),ZZ(MDEPTC), * drad(mfreq,mdeptc) c nsti=1 if(icomst.gt.1) nsti=icomst do isti=1,nsti DO IJ=1,NFREQ IJO=ijorig(ij) FR=FREQ(IJO) CALL OPACF1(IJO) CALL RTECF0(IJO) do id=1,nd do id1=1,nd bb(id,id1)=0. end do end do id=1 bb(id,id)=be(id) bb(id,id+1)=-ga(id) do id=2,nd-1 bb(id,id)=be(id) bb(id,id-1)=-al(id) bb(id,id+1)=-ga(id) end do id=nd bb(id,id)=be(id) bb(id,id-1)=-al(id) do id=1,nd if(ichcoo.eq.0) then bb(id,id)=bb(id,id)+un-comb(id)-bs(id) else bb(id,id)=bb(id,id)+un-comb(id) end if aa(id)=coma(id) cc(id)=comc(id) end do c c linearization matrices for stimulated emission c if(isti.gt.1) then do id=1,nd vl(id)=vl(id)-bb(id,id)*rad(ij,id) bb(id,id)=bb(id,id)-come(id)*rad(ij,id) aa(id)=aa(id)+u(id)*rad(ij,id) cc(id)=cc(id)+v(id)*rad(ij,id) end do id=1 vl(id)=vl(id)-bb(id,id+1)*rad(ij,id+1) do id=2,nd-1 vl(id)=vl(id)-bb(id,id-1)*rad(ij,id-1)- * bb(id,id+1)*rad(ij,id+1) end do id=nd vl(id)=vl(id)-bb(id,id-1)*rad(ij,id-1) if(ij.gt.1) then do id=1,nd vl(id)=vl(id)+aa(id)*rad(ij-1,id) end do end if if(ij.lt.nfreq) then do id=1,nd vl(id)=vl(id)+cc(id)*rad(ij+1,id) end do end if end if c c forward sweep of the grand matrix c if(ij.eq.1) then call matinv(bb,nd,mdepth) do id=1,nd sum=0. do id1=1,nd d(ij,id,id1)=bb(id,id1)*cc(id1) sum=sum+bb(id,id1)*vl(id1) end do z(ij,id)=sum end do c else do id=1,nd do id1=1,nd ff(id,id1)=bb(id,id1)-aa(id)*d(ij-1,id,id1) end do end do call matinv(ff,nd,mdepth) do id=1,nd do id1=1,nd d(ij,id,id1)=ff(id,id1)*cc(id1) end do end do do id=1,nd zz(id)=vl(id)+aa(id)*z(ij-1,id) end do do id=1,nd sum=0. do id1=1,nd sum=sum+ff(id,id1)*zz(id1) end do z(ij,id)=sum end do end if END DO c c ---------------------------------- c backward sweep of the grand matrix c ---------------------------------- c if(isti.eq.1) then ij=nfreq do id=1,nd rad(ij,id)=z(ij,id) end do c DO IJ=NFREQ-1,1,-1 do id=1,nd sum=0. do id1=1,nd sum=sum+d(ij,id,id1)*rad(ij+1,id1) end do rad(ij,id)=z(ij,id)+sum end do END DO end if c if(isti.gt.1) then ij=nfreq do id=1,nd drad(ij,id)=z(ij,id) end do c DO IJ=NFREQ-1,1,-1 do id=1,nd sum=0. do id1=1,nd sum=sum+d(ij,id,id1)*drad(ij+1,id1) end do drad(ij,id)=z(ij,id)+sum end do END DO c chmax=0. DO IJ=1,NFREQ dri=0. do id=1,nd if(rad(ij,id).gt.0.) dr=drad(ij,id)/rad(ij,id) if(abs(dr).gt.chmax) chmax=abs(dr) if(abs(dr).gt.dri) dri=abs(dr) if(dr.gt.9.) dr=9. if(dr.lt.-0.999) dr=-0.999 rad(ij,id)=rad(ij,id)*(un+dr) end do END DO end if c if(isti.gt.1.and.chmax.lt.1.e-3) go to 100 end do c 100 continue return end C C C ************************************************************************ C C SUBROUTINE COMPT0(IJ,ID,ab,compa,compb,compc,compe,comps,compd) C =============================================================== C c auxiliary quantities for the Compton scattering source function c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) common/auxcbc/cden1m(mdepth),cden10(mdepth), * cden2m(mdepth),cden20(mdepth) c IJI=NFREQ-KIJ(IJ)+1 if(iji.eq.1) then compa=0. compb=0. compc=0. compd=0. compe=0. comps=0. return end if c FR=FREQ(IJ) frp=freq(ijorig(iji+1)) frm=freq(ijorig(iji-1)) xcomp=fr*xcon e2=ycon*temp(id) e1=xcomp-3.*e2 c del0=two/(dlnfr(iji)+dlnfr(iji-1)) cder1p(iji)=(un-delj(iji,id))*del0 cder1m(iji)=-delj(iji-1,id)*del0 cder10(iji)=-del0*(un-delj(iji-1,id)-delj(iji,id)) ss0=elec(id)*sige/ab if(ichcoo.eq.0) then cder10(iji)=-cder1m(iji)-cder1p(iji) compa=ss0*(e1*cder1m(iji)+e2*cder2m(iji)) compb=ss0*(un-xcomp-sigec(ij)/sige+e1*cder10(iji)+ * e2*cder20(iji)) compc=ss0*(e1*cder1p(iji)+e2*cder2p(iji)) else epsnu=(ab-elec(id)*sigec(ij))/ab zxxp=xcon*frp+0.5*bnus(iji+1)*rad(iji+1,id)-3.*e2 zxx0=xcomp+0.5*bnus(iji)*rad(iji,id)-3.*e2 zxxm=xcon*frm+0.5*bnus(iji-1)*rad(iji-1,id)-3.*e2 zxxp12=((un-delj(iji,id))*zxxp+delj(iji,id)*zxx0)*del0 zxxm12=((un-delj(iji-1,id))*zxx0+delj(iji-1,id)*zxxm)*del0 compa=ss0*(-delj(iji-1,id)*zxxm12+e2*cder2m(iji)) compc=ss0*((un-delj(iji,id))*zxxp12+e2*cder2p(iji)) compb=ss0*(delj(iji,id)*zxxp12-(un-delj(iji-1,id))*zxxm12+ * e2*cder20(iji)-sigec(ij)/sige)-epsnu+1. compe=0. end if compd=(-3.*cder10(iji)+cder20(iji))*rad(iji,id) c IF(ICOMDE.EQ.0) THEN COMPA=0. COMPC=0. COMPB=0. END IF c x0=ss0*bnus(iji) if(icomst.eq.0) x0=0. if(ichcoo.eq.0) then compe=x0*(cder10(iji)-un) compu=x0*cder1m(iji) compv=x0*cder1p(iji) cbs=compe*rad(iji,id) compe=cbs end if comps=compb*rad(iji,id) if(iji.gt.1) then if(ichcoo.eq.0) cbs=cbs+compu*rad(iji-1,id) comps=comps+compa*rad(iji-1,id) compd=compd+(-3.*cder1m(iji)+cder2m(iji))*rad(iji-1,id) end if if(iji.lt.nfreq) then if(ichcoo.eq.0) cbs=cbs+compv*rad(iji+1,id) comps=comps+compc*rad(iji+1,id) compd=compd+(-3.*cder1p(iji)+cder2p(iji))*rad(iji+1,id) end if if(ichcoo.eq.0) then compb=compb+cbs compa=compa+compu*rad(iji,id) compc=compc+compv*rad(iji,id) comps=comps+cbs*rad(iji,id) end if compd=compd*ss0*ycon IF(ICOMDE.EQ.0) COMPD=0. c c a variant with ICOMPT=2 - no off-diagonal terms in intensity c if(icompt.eq.2) then if(iji.gt.1) compb=compb+compa*rad(iji-1,id) if(iji.lt.nfreq) compb=compb+compc*rad(iji+1,id) compa=0. compc=0. else if(icompt.eq.3) then compa=0. compb=0. compc=0. end if return end C C C **************************************************************** C C SUBROUTINE TAUFR1(IJ) C ===================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' COMMON/OPTDPT/DT(MDEPTH) dimension ST0(MDEPTH),SS0(MDEPTH),ab0(mdepth), * tau(mdepth),taus(mdepth) c PARAMETER (TAUREF = 0.6666666666667) PARAMETER (TAUREF = 1.) PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) C FR=FREQ(IJ) DO ID=1,ND AB0(ID)=ABSO1(ID) C put in a floor to avoid division by zero: IF(AB0(ID)-SCAT1(ID).GT.1.D-100) THEN ST0(ID)=EMIS1(ID)/(AB0(ID)-scat1(id)) ELSE ST0(ID)=0. ENDIF if(st0(id).eq.0) st0(id)=1.d-20*scat1(id) SS0(ID)=-SCAT1(ID)/AB0(ID) END DO C id=1 TAUMIN=ABSO1(1)*DEDM1 tau(1)=taumin C to avoid a negative square root: taus(1)=sqrt(3.*ab0(id)*max(ab0(id)-scat1(id),0.d0))*DEDM1 C IREF=1 IREFs=1 DO ID=1,ND-1 DT(ID)=DELDMZ(ID)*(ABSOT(ID+1)+ABSOT(ID)) tau(id+1)=tau(id)+dt(id) C to avoid negative square root: eps0=sqrt(ab0(id)*max(ab0(id)-scat1(id),0.d0)) eps1=sqrt(ab0(id+1)*max(ab0(id+1)-scat1(id+1),0.d0)) dts=deldm(id)*(eps0*dens1(id)+eps1*dens1(id+1))*sqrt(3.) taus(id+1)=taus(id)+dts IF(TAU(Id).LE.TAUREF.AND.TAU(Id+1).GT.TAUREF) IREF=Id IF(TAUs(Id).LE.TAUREF.AND.TAUs(Id+1).GT.TAUREF) IREFs=Id END DO if(iref.eq.1.and.tau(nd).le.tauref) iref=nd if(irefs.eq.1.and.taus(nd).le.tauref) irefs=nd C t0=1. iref0=iref iref=irefs if(irefs.lt.nd) then T0=LOG(TAUs(IREF+1)/TAUs(IREF)) X0=LOG(TAUs(IREF+1)/TAUREF)/T0 X1=LOG(TAUREF/TAUs(IREF))/T0 DMREF=EXP(LOG(DM(IREF))*X0+LOG(DM(IREF+1))*X1) TREF=EXP(LOG(TEMP(IREF))*X0+LOG(TEMP(IREF+1))*X1) abREF=EXP(LOG(ab0(IREF))*X0+LOG(ab0(IREF+1))*X1) scREF=EXP(LOG(scat1(IREF))*X0+LOG(scat1(IREF+1))*X1) STREF=EXP(LOG(ST0(IREF))*X0+LOG(ST0(IREF+1))*X1) tauef=EXP(LOG(TAU(IREF))*X0+LOG(TAU(IREF+1))*X1) else x0=1. x1=0. dmref=dm(nd) tref=temp(nd) abref=ab0(nd) scref=scat1(nd) stref=st0(nd) tauef=tau(nd) end if epref=(abref-scref)/abref CX add if statement to avoid overflow: IF(hk*fr/tref.lt.200.) then bref=1.4743e-2*(fr*1.e-15)**3/(exp(hk*fr/tref)-1.) ELSE bref=0. END IF taur=tauef*tauef if(tauef.gt.taur) taur=tauef yref=4.*ycon*tref*taur ALM=2.997925E18/FREQ(IJ) r1=rad(nfreq-kij(ij)+1,1) if(epref.ge.0) rb1=sqrt(epref)*bref if(epref.ge.0) rs1=sqrt(epref)*stref C return end C C C **************************************************************** C C SUBROUTINE RTECMU C ================= C C Solution of the radiative transfer equation with Compton scattering C for one frequency at a time (assuming the radiation intensity in other C frequencies given), for a number of specific intensities (Gaussian) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' PARAMETER (XCON=8.0935D-21,YCON=1.68638E-10) COMMON/OPTDPT/DT(MDEPTH) COMMON/AUXRTE/ * COMA(MDEPTH),COMB(MDEPTH),COMC(MDEPTH),VL(MDEPTH), * COME(MDEPTH),U(MDEPTH),V(MDEPTH),BS(MDEPTH), * AL(MDEPTH),BE(MDEPTH),GA(MDEPTH) DIMENSION RI(MDEPTH),DTAU(MDEPTH),ST0(MDEPTH),ali(mdepth) c PARAMETER (MW=10, nw=10, zero=0.) PARAMETER (MW=3, nw=3, zero=0.) DIMENSION rmu(MW),b(MW),rintmu(mw),rintpo(mw),rdwn(2*mw), * rmmu(2*MW),wmmu(2*mw) DIMENSION RJTOT(MDEPTH),RJNUT(MDEPTH),RDJ1(MDEPTH), * ABSCAD(MDEPTH),ABRAD(MDEPTH),PLTOT(MDEPTH), * retot(mdepth),re1(mdepth),re2(mdepth), * recm(mdepth),recm0(mdepth),scom(mdepth) c c set-up Gaussian angle points c call gauleg(zero,un,rmu,b,nw,mw) do i=1,nw rmmu(i)=-rmu(nw-i+1) rmmu(i+nw)=rmu(i) wmmu(i)=b(nw-i+1) wmmu(i+nw)=b(i) end do C SUMW=0. DO ID=1,ND RJTOT(ID)=0. RJNUT(ID)=0. ABSCAD(ID)=0. ABPLAD(ID)=0. ABRAD(ID)=0. pltot(id)=0. retot(id)=0. re1(id)=0. re2(id)=0. recm(id)=0. recm0(id)=0. END DO C c --------------------- loop over frequencies c do ij=1,nfreq IJI=NFREQ-KIJ(IJ)+1 FR=FREQ(IJ) xcomp=xcon*fr CALL OPACF1(IJ) if(icompt.gt.0) then CALL RTECF0(IJ) else do id=1,nd if(id.lt.nd) dt(id)=deldmz(id)*(absot(id+1)+absot(id)) comb(id)=elec(id)*sige/abso1(id) vl(id)=emis1(id)/abso1(id) coma(id)=0. comc(id)=0. bs(id)=0. end do end if c SUMW=SUMW+W(IJ) do id=1,nd x0=elec(id)*sige/abso1(id) vl(id)=emis1(id)/abso1(id) st0(id)=vl(id)+(comb(id)+bs(id))*rad(iji,id) RDJ1(ID)=0. ABSCAD(ID)=ABSCAD(ID)+SCAT1(ID)*W(IJ) scom(id)=(comb(id)-x0*(un-two*xcomp)+bs(id))*rad(iji,id) end do rdh1=0. rdhd=0. c if(iji.gt.1) then do id=1,nd st0(id)=st0(id)+coma(id)*rad(iji-1,id) scom(id)=scom(id)+coma(id)*rad(iji-1,id) end do end if if(iji.lt.nfreq) then do id=1,nd st0(id)=st0(id)+comc(id)*rad(iji+1,id) scom(id)=scom(id)+comc(id)*rad(iji+1,id) end do end if c if(ifz0.lt.0) then fr15=fr*1.d-15 bnu=bn*fr15*fr15*fr15 pland=0. x=hk*fr/temp(nd) ex=exp(-x) pland=bnu*ex/(un-ex) dplan=0. x=hk*fr/temp(nd-1) ex=exp(-x) dplan=bnu*ex/(un-ex) dplan=(pland-dplan)/dt(nd-1) end if C c --------------------- loop over angles c do i=1,2*nw do id=1,nd-1 dtau(id)=dt(id)/abs(rmmu(i)) end do c c boundary conditions c rup=extint(ij,i) C C diffusion approximation for semi-infinite atmospheres C if(ifz0.lt.0) rdown=pland+rmmu(i)*dplan c c the case of finite slab - irradiation of the back side c if(rmmu(i).gt.0.) rdown=rdwn(nw-i+1) c c solution of the transfer equation c call rtesol(dtau,st0,rup,rdown,rmmu(i),ri,ali) c if(rmmu(i).gt.0.) then if(ri(1).lt.1.e-35) ri(1)=1.e-35 rintmu(i-nw)=ri(1) rintpo(i-nw)=0. rdh1=rdh1+rmmu(i)*wmmu(i)*ri(1)*half end if rdwn(i)=ri(nd) rdhd=rdhd+abs(rmmu(i)*wmmu(i))*ri(nd)*half DO ID=1,ND RDJ1(ID)=RDJ1(ID)+WMMU(I)*RI(ID)*HALF END DO end do C c --------------------- end of loop over angles c BBN=1.4743E-2*(FR*1.E-15)**3 DO ID=1,ND pla=0. x=hk*fr/temp(nd) ex=exp(-x) pla=bbn*ex/(un-ex)*w(ij) RJTOT(ID)=RJTOT(ID)+RDJ1(ID)*W(IJ) RJNUT(ID)=RJNUT(ID)+RDJ1(ID)*FREQ(IJ)*W(IJ) ABRAD(ID)=ABRAD(ID)+RDJ1(ID)*W(IJ)*(ABSO1(ID)-SCAT1(ID)) ABPLAD(ID)=ABPLAD(ID)+PLA*(ABSO1(ID)-SCAT1(ID)) PLTOT(ID)=PLTOT(ID)+PLA retot(id)=retot(id)+abso1(id)*(st0(id)-rdj1(id))*w(ij) re1(id)=re1(id)+(abso1(id)-scat1(id))*rdj1(id)*w(ij) re2(id)=re2(id)+emis1(id)*w(ij) recm(id)=recm(id)+(st0(id)-vl(id)- * scat1(id)/abso1(id)*rdj1(id))*w(ij) recm0(id)=recm0(id)+scom(id)*w(ij) END DO c c wll=2.997925e18/fr c WRITE(14,641) wll,rdh1,(RINTMU(I),RINTPO(I),I=1,NW) END DO C c --------------------- end of loop over frequencies c c 641 FORMAT(1H ,f15.3,1pe15.5/(1P5E15.5)) c tautot=dm(nd)*elec(nd)*sige/dens(nd) DO ID=1,ND ABSCAD(ID)=elec(ID)*sige/DENS(ID) ABRAD(ID)=ABRAD(ID)/DENS(ID)/RJTOT(ID) ABPLAD(ID)=ABPLAD(ID)/DENS(ID)/PLTOT(ID) XNU=RJNUT(ID)/RJTOT(ID) re1(id)=re1(id)/dens(id) re2(id)=re2(id)/dens(id) retot(id)=retot(id)/dens(id) taurr=dm(id)*abscad(id) xl=abplad(id)*(temp(id)/teff)**4 xr1=0.75*(1./sqrt(3.)+taurr*(1.-0.5*taurr/tautot)) xr3a=4.*temp(id)*ycon xr3b=xnu*xcon xr3=xr3a-xr3b xr4=abscad(id)*xr3 xx1=xr1*(abrad(id)-xr4) xx2=0.25/dm(nd) xr=xx1+xx2 xtj=sig4p*4.*teff**4*xr1 XH1=ABPLAD(ID)*PLTOT(ID) XH2=ABRAD(ID)*RJTOT(ID) XH12=XH1-XH2 XH3=XR4*RJTOT(ID) XH123=XH12+XH3 XHR=SIG4P*TEFF**4/DM(ND) END DO RETURN END C C C **************************************************************** C C SUBROUTINE RTEANG C ================= C C initialization of the angle quadrature points for the radiative C transfer equation C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (NMU3=3, NMU5=5, ZERO=0.D0) COMMON/EXTINT/WANGLE,EXTIN(MFREQ) COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ) DIMENSION AMU0(MMU),WTMU0(MMU) C C If irradiation is neglected, the angular quadrature is a standard C NMU-point Gaussian quadrature C X=WANGLE*HALF XJ=0. XH=0. IF(X.LE.0.) THEN call gauleg(zero,un,amu0,wtmu0,nmu,mmu) do i=1,nmu amu(i)=amu0(i) wtmu(i)=wtmu0(i) fmu(i)=0. end do ELSE C C Here, allowance is made for irradiation by central star. C First, establish angular integration that takes into account C angles with mu < 0; instead of the standard 3-point integration C over angles, we have now a more general NMU5-point integration C X0=HALF-X X1=HALF+X call gauleg(-un,un,amu0,wtmu0,nmu3,mmu) DO I=1,NMU3 AMU(I)=X0*AMU0(I)+X1 WTMU(I)=X0*WTMU0(I) FMU(I)=0. END DO NMU=NMU5 i4=nmu3+1 i5=nmu3+2 AMU(i4)=X*(UN+0.577350269189626D0) AMU(i5)=X*(UN-0.577350269189626D0) DO I=NMU3+1,NMU5 WTMU(I)=X FMU(I)=ASIN(SQRT((WANGLE**2-AMU(I)**2)/(UN-AMU(I)**2)))/ * 3.141592653589793D0 XJ=XJ+WTMU(I)*FMU(I) XH=XH+WTMU(I)*AMU(I)*FMU(I) END DO END IF C DO IJ=1,NFREQ EXTJ(IJ)=XJ*EXTIN(IJ)*HALF EXTH(IJ)=XH*EXTIN(IJ)*HALF END DO C RETURN END C C C C **************************************************************** C C SUBROUTINE PRD(IJ) c ================== c c modification of the line emission coefficient c and the scattering coefficient in the case of PRD c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' parameter(a21=4.699e8,pi2=6.28318531,gr=2.*4.8e-8) c if(ij.gt.0) then c if(ilam.le.1) return FR=FREQ(IJ) IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) ITRPRD=IPRD(ITR) IF(ITRPRD.GT.0) THEN DFR=ABS(FREQ(IJ)-FR0(ITR)) if(ilow(itr).eq.nfirst(ielh)) then omeg=dfr*pi2 gra=a21+gr*popul(nfirst(ielh),id) do id=1,nd coher(itrprd,id)=a21/ * (gra+gami(2,'elec',omeg,temp(id),elec(id))) end do end if DO ID=1,ND SG=PRFLIN(ID,IJ) IF(DFR/DOPTR(ITRPRD,ID).LE.XPDIV) SG=0. SCALIN=SG*ABTRA(ITR,ID)*COHER(ITRPRD,ID) SCAT1(ID)=SCAT1(ID)+SCALIN scem=sg*emtra(itr,id)*coher(itrprd,id)*xkfb(id) c EMIS1(ID)=EMIS1(ID)-SCALIN*RJBAR(ITRPRD,ID) EMIS1(ID)=EMIS1(ID)-SCEM END DO END IF END IF IF(NLINES(IJ).GT.0) THEN C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) ITRPRD=IPRD(ITR) IF(ITRPRD.EQ.0) GO TO 100 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 DFR=ABS(FREQ(IJ)-FR0(ITR)) if(ilow(itr).eq.nfirst(ielh)) then omeg=dfr*pi2 gra=a21+gr*popul(nfirst(ielh),id) do id=1,nd coher(itrprd,id)=a21/ * (gra+gami(2,'elec',omeg,temp(id),elec(id))) end do end if DO ID=1,ND SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) IF(DFR/DOPTR(ITRPRD,ID).LE.XPDIV) SG=0. SCALIN=SG*ABTRA(ITR,ID)*COHER(ITRPRD,ID) scem=sg*emtra(itr,id)*coher(itrprd,id)*xkfb(id) SCAT1(ID)=SCAT1(ID)+SCALIN c EMIS1(ID)=EMIS1(ID)-SCALIN*RJBAR(ITRPRD,ID) EMIS1(ID)=EMIS1(ID)-SCEM END DO 100 CONTINUE END IF C C Opacity sampling option C ELSE IF(NLINES(IJ).GT.0) THEN DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) ITRPRD=IPRD(ITR) IF(ITRPRD.EQ.0) GO TO 300 KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DFR=ABS(FREQ(IJ)-FR0(ITR)) if(ilow(itr).eq.nfirst(ielh)) then omeg=dfr*pi2 gra=a21+gr*popul(nfirst(ielh),id) do id=1,nd coher(itrprd,id)=a21/ * (gra+gami(2,'elec',omeg,temp(id),elec(id))) end do end if DO ID=1,ND SG=PRFLIN(ID,KJ) IF(DFR/DOPTR(ITRPRD,ID).LE.XPDIV) SG=0. SCALIN=SG*ABTRA(ITR,ID)*COHER(ITRPRD,ID) SCAT1(ID)=SCAT1(ID)+SCALIN EMIS1(ID)=EMIS1(ID)-SCEM END DO END IF 300 CONTINUE END IF END IF RETURN c end if c do itrp=1,ntrprd itr=itrtot(itrp) aji=osc0(itr)*g(ilow(itr))/g(iup(itr))*7.42163e-22* * fr0(itr)**2 omeg=0. do id=1,nd t=temp(id) ane=elec(id) call dopgam(itr,id,t,dop,agam) doptr(itrp,id)=dop coher(itrp,id)=0.99 if(agam.gt.0.) coher(itrp,id)=aji/(12.5664*dop*agam) if(coher(itrp,id).gt.0.999) coher(itrp,id)=0.999 c c special expression for Lyman-alpha c coher(itrp,id)=aji/(aji+9.8e-8*popul(nfirst(ielh),id)+ * 0.667*(gami(2,'iont',omeg,t,ane)+ * gami(2,'elec',omeg,t,ane))) rjbar(itrp,id)=pjbar(itrp,id) end do end do return END C C C C **************************************************************** C C SUBROUTINE PRDINI c ================= c c initialization of PRD c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' c ntrprd=0 do itr=1,ntrans iprd(itr)=0 if(ifprd.gt.0.and.line(itr).and.indexp(itr).ne.0) then ii=ilow(itr) jj=iup(itr) iat=iatm(ii) c c select Lyman alpha for PRD c if(iat.eq.iath.and.ii.eq.nfirst(ielh).and. * fr0(itr).lt.2.5e15) then ntrprd=ntrprd+1 iprd(itr)=ntrprd itrtot(ntrprd)=itr end if c c select Mg I resonance line for PRD c if(numat(iat).eq.12.and.iz(iel(ii)).eq.1.and. * ii.eq.nfirst(iel(ii)).and.fr0(itr).lt.1.06e15) then ntrprd=ntrprd+1 iprd(itr)=ntrprd itrtot(ntrprd)=itr end if c c select Mg II resonance lines for PRD c if(numat(iat).eq.12.and.iz(iel(ii)).eq.2.and. * ii.eq.nfirst(iel(ii)).and.fr0(itr).lt.1.08e15) then ntrprd=ntrprd+1 iprd(itr)=ntrprd itrtot(ntrprd)=itr end if end if end do c do itrp=1,ntrprd do id=1,nd pjbar(itrp,id)=0. end do end do return end C C C **************************************************************** C C function gami(j,aper,omeg,t,ane) c ================================ c c function i(j) defined by eqs. (4.5)-(4.9) of c cooper, ballagh, and hubeny (1989), ap.j. 344, 949. c j = principal quantum number c aper = either 'iont', or 'elec', whether one calculates the c ion or electron contribution c omeg = delta omega (circular frequency) c t = temperature c ane = electron density (assumed equal to proton density) c INCLUDE 'IMPLIC.FOR' character*4 aper dimension xx(3) data xx/0., 50.6205, 68.6112/ c if(omeg.gt.0.) then gami=xx(j)*ane/sqrt(omeg) return end if c x=j*j omegp=5.64e4*sqrt(ane) amu=1. if(aper.eq.'iont') then amu=30.2 omegp=omegp/42.85 end if omegc=1.7455e11*t/amu/amu/j corr=0.27-log(8.356e-13*x*amu*amu*ane/t/t) gami=3.885e-5*amu*x*ane/sqrt(t)*corr if(omeg.lt.omegp) return gamp=gami gam0=22.58*x**0.75*ane gamc=gam0/sqrt(omegc) if(omeg.lt.omegc) then gami=log(omeg/omegp)/log(omegc/omegp)*log(gamc/gamp)+ * log(gamp) gami=exp(gami) else gami=gam0/sqrt(omeg) end if return end c C C C ******************************************************************** C C SUBROUTINE INPDIS C ================= C C driver for input specific for disks C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (VELC=2.997925E10, * pi4=12.5663706d0) PARAMETER (GRCON = 6.668D-8) common/relcor/arh,brh,crh,drh C C ---------------------- C Basic input parameters C ---------------------- C C The user may choose one of the two C following possibilities to input the basic physical parameters: C C XMSTAR - M(star), either in M(Sun), or in grams; C XMDOT - M(dot), either in M(Sun)/year; or in g/s C RSTAR - R(star), either in R(Sun), or in cm C RELDST - R/R(star) C C or to directly give parameters with which the program works, ie C C TEFF - effective temperature C QGRAV - coefficient in the hydrostatic equilibrium equation C QGRAV=G*M(star)/R**3 C DMTOT - total column mass at the midplane C WRITE(6,660) IF(FRACTV.LT.0.) THEN AMUV0=DMVISC**(ZETA0+UN) FRACTV=UN/(UN+(ZETA0+UN)/(ZETA1+UN)*AMUV0/(UN-AMUV0)) END IF IF(DMVISC.LT.0.) DMVISC=(UN/(UN+(ZETA0+UN)/(ZETA1+UN)* * FRACTV/(UN-FRACTV)))**(UN/(ZETA0+UN)) alpha0=alphav WRITE(6,600) XMSTAR,XMDOT,RSTAR,RELDST,ALPHAV C c if XMSTAR<0, turn on general relativistic corrections c RSTAR now has the input meaning of dimensionless angular c momentum of the Kerr black hole, but we will call this c value AA and RSTAR will take on the meaning of 1 radius- c equivalent of mass of the black hole c RELDST now is expressed in multiples of 1*G*XMSTAR/c^2 c (note that for Schwarzschild black hole, the c horizon is at RELDST=2 and the smallest radius of c stable circular orbit is at RELDST=6) C IF(XMSTAR.NE.0.) THEN IF(XMSTAR.LT.0) THEN AA=RSTAR RSTAR=-XMSTAR*1.989D33*GRCON/VELC/VELC ELSE AA=0. END IF IF(abs(XMSTAR).GT.1.D16) XMSTAR=XMSTAR/1.989D33 IF(XMDOT.GT.1.D3) XMDOT=XMDOT/6.3029D25 IF(RSTAR.GT.1.D3) RSTAR=RSTAR/6.9598D10 R=RSTAR*ABS(RELDST) QGRAV=5.9D0*GRCON*abs(XMSTAR)/R**3 OMEG32=SQRT(QGRAV)*1.5 c c apply general relativistic corrections to c QGRAV and TEFF; keep MSTAR<0 for future use c RR0=RELDST CALL GRCOR(AA,RR0,XMSTAR,QCOR,TCOR,ARH,BRH,CRH,DRH) TEFF0=(1.79049311D-1*QGRAV*3.34379D24*XMDOT/SIG4P)**0.25 TEFF=TEFF0*TCOR QGRAV=QGRAV*QCOR OMEG32=OMEG32*ARH/BRH rr0=abs(rr0) xmas9=abs(Xmstar)*1.d-9 xmdt=Xmdot/xmas9/2.22 XMD=XMDOT*6.3029D25 alpav=abs(alphav) c c following is the old procedure c if(alphav.le.0.) then C ------------------------- chih=0.39 if(reynum.le.0.) then reynum=(rr0/xmdt)**2/alpav*arh*crh/drh/drh c REYNUM=(R/XMDOT*1.10422E-15*12.5663*VELC/CHIH)**2* c * 2./ALPAV*ARH*CRH/DRH/DRH else alpav=(rr0/xmdt)**2/reynum*arh*crh/drh/drh c ALPAV=(R/XMDOT*1.10422E-15*12.5663*VELC/CHIH)**2* c * 2./REYNUM*ARH*CRH/DRH/DRH endif VISC=1.176565D22*SQRT(GRCON*abs(XMSTAR)*R)/REYNUM DMTOT=3.34379D24*XMDOT/VISC*BRH*DRH/ARH/ARH C if(alphav.lt.0.) then c C **************************************************************** C Compute the Keplerian rotation frequency (omega=c/r_g/x^1.5): C RE=ABS(RR0) OMEGA=VELC/RSTAR/6.9698D10/RE**1.5D0 C C Compute Relativistic factors, using Krolik (1998) notation: C RELT=DRH/ARH RELR=DRH/BRH RL2=RE*(1.D0-2.D0*AA/RE**1.5D0+AA*AA/RE/RE)**2/BRH EINF=(1.D0-2.D0/RE+AA/RE**1.5D0)/SQRT(BRH) RELZ=(RL2-AA*AA*(EINF-1.D0))/RE C C Compute the surface mass density (assuming pure electron scattering, C pure hydrogen composition, and that T_rphi = \alpha P_tot): C DMTOT=0.5D0*SIGMAR(ALPAV,XMD,TEFF,OMEGA,RELR,RELT,RELZ) end if c ---------------------------- c c new procedure c else call column end if c EDISC=SIG4P*TEFF**4/DMTOT WBARM=XMDOT*6.3029D25/6./3.1415926*BRH*DRH/(ARH*ARH) reynum=dmtot/wbarm*sqrt(xmstar*r)*3.03818e18 WRITE(6,601) TEFF,QGRAV,DMTOT, * ZETA0,ZETA1,FRACTV,DMVISC,TSTAR write(6,321) tcor,qcor,arh,brh,crh,drh, * reynum,alpav, * dmtot,edisc,wbarm 321 FORMAT( * ' tcor =',1PD10.3/ * ' qcor =',D10.3/ * ' A(RH) =',D10.3/ * ' B(RB) =',D10.3/ * ' C(RH) =',D10.3/ * ' D(RH) =',D10.3/ * ' Re =',D10.3/ * ' alpha =',D10.3// * ' DMTOT =',D10.3/ * ' EDISC =',D10.3/ * ' WBARM =',D10.3//) C ELSE TEFF=XMDOT QGRAV=RSTAR DMTOT=RELDST EDISC=SIG4P*TEFF**4/DMTOT OMEG32=SQRT(QGRAV)*1.5 WRITE(6,601) TEFF,QGRAV,DMTOT, * ZETA0,ZETA1,FRACTV,DMVISC,TSTAR END IF C C set up the maximum frequency C c if(idgrey.le.2) then c IF(FRCMAX.EQ.0.) FRCMAX=2.83e11*(dmtot*0.39)**0.25*teff c end if IF(FRLMAX.EQ.0.) FRLMAX=1.D11*CNU1*TEFF C 660 FORMAT(1H1,'***************************************'// * ' M O D E L O F A D I S K R I N G'// * ' ***************************************'//) 600 FORMAT( * ' M(STAR) =',1PD10.3/ * ' M(DOT) =',D10.3/ * ' R(STAR) =',D10.3/ * ' R/R(STAR) =',D10.3/ * ' ALPHA =',D10.3//) 601 FORMAT( * ' TEFF =',F10.0/ * ' QGRAV =',1PD10.3/ * ' DMTOT =',D10.3/ * ' ZETA0 =',D10.3/ * ' ZETA1 =',D10.3/ * ' FRACTV =',D10.3/ * ' DMVISC =',D10.3/ * ' TSTAR =',0PF10.0//) RETURN END C C C **************************************************************** C C subroutine column c ================= c c approximate determination of the total disk column c mass, DMTOT c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' common/relcor/arh,brh,crh,drh c parameter (xmdsun = 6.3029e25, * xmsun = 1.989e33, * rsun = 6.9598e10, * grcon = 6.668e-8, * velc = 2.997925e10, * rgas = 1.3e8, * xkram0 = 7.e25, * xkap0 = 6.4e24, * chiel = 0.39, * pi = 3.14159265e0, * pi4 = 4.*pi) c alpha= abs(alphav) r = rstar*abs(reldst) ga=xmdot*xmdsun/pi4*sqrt(5.9*grcon*abs(xmstar)/r**3)*drh/arh c be=0.77*rgas*xkap0**0.125*(two*qgrav/pi/rgas)**0.0625*sqrt(teff) be=be*fractv**0.125 al=(sig4p*pi4*teff**4*chiel/velc)**2/(3.*qgrav) c dm00=(ga/alpha/be)**0.8 write(6,640) ga,al,be,dm00 640 format(/' new procedure to determine M_tot'/ * ' gam, al, be, dm0 ',1p4e11.3/ * ' iter M delta(M)/M p, jac'/) itdm=0 10 itdm=itdm+1 p0=alpha*dm00*(al+be*dm00**0.25)-ga ppr=alpha*(al+1.25*be*dm00**0.25) ddm0=-p0/ppr write(6,641) itdm,dm00,ddm0/dm00,p0,ppr 641 format(i4,1p4e11.3) dm00=dm00+ddm0 if(abs(ddm0/dm00).gt.1.e-2.and.itdm.lt.20) go to 10 dmtot=dm00 visc=3.34379D24*XMDOT/dmtot*BRH*DRH/ARH/ARH c return end C C C **************************************************************** C SUBROUTINE GRCOR(AA,RR,XMSTAR,QCOR,TCOR,ARH,BRH,CRH,DRH) C ======================================================= C C Procedure for computing general-relativistic correction C factors to gravitational factor (QGRAV) and effective C temperature (TEFF) C Also calculates all frour quantities in the Riffer-Herlod (RH) C notation - ARH, BRH, CRH, DRH C C Input: C AA - angular momentum (0.98 maximum) C RR - R/R_g = r/(GM/c^2) C Outout: C QCOR - g-correction = C/B in RH notation C TCOR - T-correction = (D/B)^(1/4) in RH notation C ARH - A in RH notation C BRH - B in RH notation C CRH - C in RH notation C DRH - D in RH notation C INCLUDE 'IMPLIC.FOR' PARAMETER (THIRD=1.D0/3.D0, PI3=1.0471976) C C ---------------- C Imput parameters C ---------------- C C AA - specific angular momentum/mass C of the Kerr black hole C RR - distance/mass of the Kerr black hole C C ----------------------------------- C Classical case - no GR corrections C ------------------------------------ C if(Xmstar.gt.0.) then arh=1. brh=1. crh=1. drh=1.-sqrt(1./rr) qcor=1. tcor=drh**0.25 return end if c C --------------------------------- C Set correcion factors A through G (see Novikov & Thorne,'73, eq.5.4.1a-g) C --------------------------------- C rror=rr rr=abs(rr) AA2=AA*AA RR1=1/RR RR12=SQRT(RR1) RR2=RR1*RR1 A2R2=AA2*RR2 A4R4=A2R2*A2R2 A2R3=AA2*RR2*RR1 AR32=SQRT(A2R3) C A = 1 + A2R2 + 2*A2R3 B = 1 + AR32 C = 1 - 3*RR1 + 2*AR32 D = 1 - 2*RR1 + A2R2 E = 1 + 4*A2R2 - 4*A2R3 + 3*A4R4 C C ------------------------------- C Set correction factor for QGRAV (see Novikov & Thorne,'73, eq.5.7.2) C ------------------------------- C if(rror.lt.0) QCOR = B*B*D*E/(A*A*C) c c correction - after Riffert and Harold c if(rror.gt.0) QCOR = (1. - 4.*AR32 + 3.*A2R2)/C C C ----------------------- C Set correction factor Q (see Page & Thorne,'73, eq.35) C ----------------------- C C Minimum radius for last stable circular orbit per unit mass, X0 C Z1 = 1 + (1-AA2)**THIRD * ((1+AA)**THIRD + (1-AA)**THIRD) Z2 = SQRT(3*AA2 + Z1*Z1) X0 = SQRT(3 + Z2 - SQRT((3-Z1)*(3+Z1+2*Z2))) C C Roots of x^3 - 3x + 2a = 0 C CA3 = THIRD * ACOS(AA) X1 = 2*COS(CA3-PI3) X2 = 2*COS(CA3+PI3) X3 = -2*COS(CA3) C C FB = '[]' term in eq. (35) of Page&Thorne '73 C X = SQRT(RR) C1 = 3*(X1-AA)*(X1-AA)/(X1*(X1-X2)*(X1-X3)) C2 = 3*(X2-AA)*(X2-AA)/(X2*(X2-X1)*(X2-X3)) C3 = 3*(X3-AA)*(X3-AA)/(X3*(X3-X1)*(X3-X2)) AL0 = 1.5*AA*log(X/X0) AL1 = log((X-X1)/(X0-X1)) AL2 = log((X-X2)/(X0-X2)) AL3 = log((X-X3)/(X0-X3)) FB = (X-X0 - AL0 - C1*AL1 - C2*AL2 - C3*AL3) Q = FB*(1+AR32)*RR12/SQRT(1-3*RR1+2*AR32) C ------------------------------ C Set correction factor for TEFF (see Novikov & Thorne,'73, eq.5.5.14b) C ------------------------------ C TCOR = (Q/B/SQRT(C))**0.25 C C ------------------------------ C RH quantities C ------------------------------ C ARH = D BRH = C CRH = 1. - 4.*AR32 + 3.*A2R2 DRH = Q/B*SQRT(C) C RETURN END C C C **************************************************************** C C SUBROUTINE DMDER C ================ C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' COMMON/DEPTDR/DDM(MDEPTH),DDP(MDEPTH),DD0(MDEPTH), * DDMIN(MDEPTH),DDPLU(MDEPTH),DDA(MDEPTH), * DDC(MDEPTH),DDB(MDEPTH) C DO ID=2,ND-1 DDM(ID)=DM(ID)-DM(ID-1) DDP(ID)=DM(ID+1)-DM(ID) DD0(ID)=DM(ID+1)-DM(ID-1) DDMIN(ID)=DDP(ID)/DD0(ID) DDPLU(ID)=DDM(ID)/DD0(ID) DDA(ID)=DDMIN(ID)/DDM(ID) DDC(ID)=DDPLU(ID)/DDP(ID) END DO C DDM(1)=0. DDM(ND)=DM(ND)-DM(ND-1) DDP(1)=DM(2)-DM(1) DDP(ND)=0. DDMIN(1)=0. DDMIN(ND)=1. DDPLU(1)=1. DDPLU(ND)=0. DDA(1)=0. DDA(ND)=UN/DDM(ND) DDC(1)=UN/DDP(1) DDC(ND)=0. DO ID=1,ND DDB(ID)=DDA(ID)-DDC(ID) END DO C RETURN END C C C **************************************************************** C C FUNCTION SIGMAR(ALPHA,XMDT,TEF,OMEGA,RELR,RELT,RELZ) C ===================================================== c C-------------------------------------------------------------------- C The following function takes as inpute various disk parameters computed C at a certain radius in cgs units, and outputs the surface mass density, C assuming that the opacity is electron-scattering dominated (or that kappa C is independent of the density). The equations were derived assuming a 1-zone C model (i.e. rho, T_g, mu are constant with height), assuming t_r,phi = C -alpha P, and that the dissipation is constant per unit optical depth. C See chapter 7 of Krolik for information on the notation used here C (especially relativistic factors). C C-------------------------------------------------------------------- C Uses Numerical Recipes subroutine LAGUER C-------------------------------------------------------------------- C ALPHA - viscosity parameter C XMDT - accretion rate (in g/s) C TEF - temperature in Kelvins C OMEGA - Keplerian frequency (in Hz) C RELR,RELT, RELZ - relativistic factors C KAPPA - opacity (cm^2/g) C MU - mean atomic mass (g) = rho/N C-------------------------------------------------------------------- C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' REAL*8 KAPPA,MU COMPLEX*16 COEFF(11),XGUESS C C We should check that the physical constants used here agree with those in C disk195g: C parameter (ZERO=0.D0,ONE=1.D0,TRES=3.D0, * FOUR=4.D0,THIRD=ONE/TRES,FOURTH=0.25D0,EPS=1.D-5) parameter (C=2.9979D10,SIGMAB=5.6703D-5) parameter (BK=1.3807D-16) PI=ACOS(-ONE) C C We'll assume fully ionized, pure hydrogen: C KAPPA=0.39D0 MU=0.5D0*1.6726D-24 FAC1=RELZ*(HALF*TRES*C*OMEGA/ALPHA/KAPPA/SIGMAB/TEF**4)**2 FAC2=(HALF*KAPPA)**FOURTH*BK*TEF/MU FAC3=XMDT*OMEGA*RELT/PI C C Coefficients of the equation for x^4=Sigma: C COEFF(1)=DCMPLX(FAC1*(HALF*FAC3)**2,ZERO) COEFF(2)=ZERO COEFF(3)=ZERO COEFF(4)=ZERO COEFF(5)=DCMPLX(-(TRES*FAC3)/(8.D0*ALPHA),ZERO) COEFF(6)=DCMPLX(-FAC1*FAC3*ALPHA*FAC2,ZERO) COEFF(7)=ZERO COEFF(8)=ZERO COEFF(9)=ZERO COEFF(10)=DCMPLX(FOURTH*FAC2,ZERO) COEFF(11)=DCMPLX(FAC1*(ALPHA*FAC2)**2,ZERO) C C At small radii, we'll approximate P_rad >> P_gas C First, compute sigma assuming radiation pressure dominates: C SIGRAD=FOUR*OMEGA*C*C*RELT*RELZ/ALPHA/KAPPA**2/SIGMAB/TEF**4/RELR C C Next, compute sigma assuming gas pressure dominates: C SIGGAS=((MU*XMDT*OMEGA*RELT/PI/ALPHA/BK/TEF)**4/8./KAPPA)**0.2D0 C C Use a starting guess which has the correct value for P_gas >> P_rad C or P_rad >> P_gas. C XGUESS=DCMPLX(ONE/(ONE/SIGRAD+ONE/SIGGAS)**FOURTH,ZERO) C C Look for root of the 10th order equation for x: C CALL LAGUER(COEFF,10,XGUESS,ITS) C C Make sure that we haven't landed a wrong root: C IF(ABS(DIMAG(XGUESS)).LT.EPS.AND.DBLE(XGUESS).GT.ZERO) THEN SIGMAR=DBLE(XGUESS)**4 ELSE SIGMAR=ONE/(ONE/SIGRAD+ONE/SIGGAS) WRITE(6,*) 'Surface density approximated' ENDIF WRITE(6,2000) TEF,SIGRAD,SIGGAS,SIGMAR RETURN 2000 FORMAT(20(2x,1pe12.5)) END C C C **************************************************************** C C SUBROUTINE laguer(a,m,x,its) C ============================ C C Routine from Numerical Recipees C INCLUDE 'IMPLIC.FOR' COMPLEX*16 a(m+1),x PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR) REAL frac(MR) COMPLEX*16 dx,x1,b,d,f,g,h,sq,gp,gm,g2 SAVE frac DATA frac /.5,.25,.75,.13,.38,.62,.88,1./ C do iter=1,MAXIT its=iter b=a(m+1) err=abs(b) d=dcmplx(0.d0,0.d0) f=dcmplx(0.d0,0.d0) abx=abs(x) do j=m,1,-1 f=x*f+d d=x*d+b b=x*b+a(j) err=abs(b)+abx*err end do err=EPSS*err if(abs(b).le.err) then return else g=d/b g2=g*g h=g2-2.d0*f/b sq=sqrt(dble(m-1)*(dble(m)*h-g2)) gp=g+sq gm=g-sq abp=abs(gp) abm=abs(gm) if(abp.lt.abm) gp=gm if (max(abp,abm).gt.0.D0) then dx=dble(m)/gp else dx=exp(dcmplx(log(1.d0+abx),dble(iter))) endif endif x1=x-dx if(x.eq.x1)return if (mod(iter,MT).ne.0) then x=x1 else x=x-dx*frac(iter/MT) endif end do c write(6,601) x,x1 601 format(' too many iterations in laguer, x,x1 ',1p2e9.1) return END C C C **************************************************************** C C SUBROUTINE LTEGRD C ================= C C Driving procedure for computing the initial LTE-grey disk model C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C PARAMETER (ERRT=1.D-3, THIRD=UN/3.D0, FOUR=4.D0) DIMENSION TAU0(MDEPTH),TEMP0(MDEPTH),ELEC0(MDEPTH), * DENS0(MDEPTH),ZD0(MDEPTH),DM0(MDEPTH) COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0 COMMON/TOTJHK/TOTJ(MDEPTH),TOTH(MDEPTH),TOTK(MDEPTH), * RDOPAC(MDEPTH),FLOPAC(MDEPTH) COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 COMMON/CUBCON/A,B,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD C C ---------------- C Input parameters C ---------------- C C NDEPTH - number of depth point for evaluating LTE-grey model C < 0 - the program computes an isothermal structure; C the temperature is specified by an extra record C (see below) C DM1 - mass at the first depth point C ABROS0 - initial estimate of the Rosseland opacity (per gram) C at the first depth point C ABPLA0 - initial estimate of the Planck mean opacity (per C gram) at the first depth point C DION0 - initial estimate of the degree of ionization at the C first depth point (=1 for completely ionized; =1/2 for C completely neutral) C ITGMAX - maximum number of global iterations of the procedure C for determining the Eddington and opacity factors C - number of iterations in recalculating new depth scale C in order to get a better coverage of optical depths C > 0 - subroutine NEWDM (blind addition of points) C < 0 - subroutine NEWDMT - new depths determined as the C equal-segment endpoints of the curve y=tauros(m) C C -------------------------------------------------------------------- C C IDEPTH - mode of determining the mass-depth scale to be used C in linearization C = 0 - depth scale DM is set up by the program C = 1 - interpolation to the depth scale DM (in g*cm**-2), C which has been read in START C = 2 - DM is evaluated as mass corresponding to Rosseland C optical depths which are equidistantly spaced in C logarithms between the first point TAU1 and the C last-but-one point TAU2=0.99*TAUMAX; the last point C is TAUMAX, where TAUMAX is the Ross. optical depth C corresponding to the last depth point (midplane), C set up by the program C NCONIT - number of internal iterations for calculating the C LTE-gray model with convection C = 0 - if HMIX0>0, program sets NCONIT=10. C IPRING - switch for determining an amount of output from C the calculation of LTE-gray model C = 0 - only final LTE-gray model is printed C = 1 - more tables are printed C = 2 - complete output C IHM > 0 - negative hydrogen ion considered in particle and C charge conservation in ELDENS C IH2 > 0 - hydrogen molecule considered in particle C conservation in ELDENS C IH2P > 0 - ionized hydrogen molecule considered in particle C and charge conservation in ELDENS C C -------------------------------------------------------------------- C IF(NDGREY.EQ.0) THEN NDEPTH=ND ELSE NDEPTH=NDGREY END IF IF(NDEPTH.GT.MDEPTH) call quit(' NDEPTH too large in LTEGR', * ndept,mdepth) IDEPTH=IDGREY ITGMAX=ITGMX0 IF(HMIX0.GT.0..AND.NCONIT.EQ.0) NCONIT=10 if(dion0.lt.0) then abpmin=-dion0 dion0=1. end if T4=TEFF**4 TOTF=SIG4P*T4 ABFL0=SIGE/WMM(1) if(idmfix.eq.1) then t0=teff DMTOT=TOTF/EDISC else call greyd t0=temp(1) EDISC=TOTF/DMTOT end if c ZND=0. VSND20=2.76D-16*T0/WMM(1)*DION0+VTB*VTB HSCALG=SQRT(TWO*VSND20/QGRAV) HSCALR=4.19168946D-10*TOTF*ABFL0/QGRAV R=HSCALR/HSCALG WRITE(6,615) HSCALG,HSCALR,R 615 FORMAT(/' GAS PRESSURE SCALE HEIGHT = ',1PD10.3/ * ' RAD.PRESSURE SCALE HEIGHT = ',1PD10.3/ * ' RATIO = ',1PD10.3/) GAMH=UN FAK0=THIRD ANEREL=(DION0-HALF)/DION0 IF(ANEREL.LT.ERRT) ANEREL=ERRT IF(NDEPTH.EQ.0) NDEPTH=ND LCHC0=LCHC LCHC=.TRUE. ND0=ND ND=NDEPTH DO ID=1,ND0 DM0(ID)=DM(ID) END DO C C mass-depth scale C Initial estimate of the density, geometrical distance z, and C pressure C CALL ZMRHO(R,HSCALG) C if(ipring.eq.2) then xdm=dm(1) DO ID=1,ND if(id.gt.1) xdm=xdm-half*(dens(id)+dens(id-1))* * (zd(id)-zd(id-1)) WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) * ,dens(id),xdm end do end if c ITGREY=-1 AMUV0=DMVISC**(ZETA0+UN) AMUV1=UN-AMUV0 DO ID=1,ND PGS(ID)=DENS(ID)*VSND20 IF(DM(ID).LE.DMVISC*DM(ND)) THEN VISCD(ID)=(UN-FRACTV)*(ZETA1+UN)/ * DMVISC**(ZETA1+UN)*(DM(ID)/DM(ND))**ZETA1 THETA(ID)=(UN-FRACTV)*(DM(ID)/DMVISC/DM(ND))**(ZETA1+UN) ELSE VISCD(ID)=FRACTV*(ZETA0+UN)/AMUV1* * (DM(ID)/DM(ND))**ZETA0 THETA(ID)=(UN-FRACTV)+FRACTV*((DM(ID)/DM(ND))**(ZETA0+UN)- * AMUV0)/AMUV1 END IF GAMJ(ID)=UN C C First estimates of the values of the Rosseland opacity C and function tauthe C IF(ID.EQ.1) THEN TAUR=DM(ID)*ABROS0 TAUTHE(ID)=TAUR*THETA(ID)/(ZETA1+TWO) ABROSD(ID)=ABROS0 ABPLAD(ID)=ABPLA0 ELSE DDM=DM(ID)-DM(ID-1) TAUR=TAUROS(ID-1)+DDM*ABROSD(ID-1) TAUTHE(ID)=TAUTHE(ID-1)+DDM*ABROSD(ID-1)*THETA(ID) ABROSD(ID)=ABROSD(ID-1) ABPLAD(ID)=ABPLAD(ID-1) END IF C do ii=1,nlevel wop(ii,id)=un end do C C Determination of temperature and mean opacities C CALL TEMPER(ID,TAUR,ITGREY) END DO C IF(IPRING.GE.2) THEN WRITE(6,601) xdm=dm(1) DO ID=1,ND if(id.gt.1) xdm=xdm-half*(dens(id)+dens(id-1))* * (zd(id)-zd(id-1)) WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) * ,dens(id),xdm END DO END IF C C C Simultaneous solution of the hydrostatic equilibrium and the C z-m relation, assuming sound speed fixed C if(nconit.ge.0) CALL HESOLV C if(nconit.lt.-2) then do id=2,nd dm(id)=dm(id-1)-half*(dens(id)+dens(id-1))* * (zd(id)-zd(id-1)) end do end if IF(IPRING.GE.2) THEN xdm=dm(1) WRITE(6,601) DO ID=1,ND if(id.gt.1) xdm=xdm-half*(dens(id)+dens(id-1))* * (zd(id)-zd(id-1)) WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) * ,dens(id),xdm END DO END IF C C ------------------------------------------------------------------- C C Outer iteration loop for the pseudo-grey model; C basically generalized Unsold-Lucy procedure C C 1.iteration - assumes that C Rosseland opacity = flux mean opacity C Planck mean opac = absorption mean opacity C Eddington factors = 1/3 and 1/sgrt(3) C C next iterations C improvement of mean opacities and Eddington factors; C corrections of the temperature (generalized Unsold-Lucy) C C C 1.part C 100 ITGREY=ITGREY+1 C ANEREL=ELEC(1)/(DENS(1)/WMM(1)+ELEC(1)) DO ID=1,ND TAUR=TAUROS(ID) IF(ITGREY.GT.1) TAUR=TAUFLX(ID) CALL TEMPER(ID,TAUR,ITGREY) END DO C C Again simultaneous solution of the hydrostatic equilibrium C and the z-m relation, assuming sound speed fixed C if(nconit.ge.0) CALL HESOLV C IF(IPRING.GE.1) THEN WRITE(6,601) xdm=dm(1) DO ID=1,ND WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) * ,dens(id),xdm END DO END IF C 601 FORMAT(1H1,' ID DM TAUROSS TEMP NE P', * 8X,'ZD ROSS.MEAN PLANCK',' dens '/) 602 FORMAT(1H ,I3,1P2D9.2,0PF11.0,1P3D9.2,2X,2D9.2,2x,2d11.4,d9.2) C C If required, modification of the depth scale (logarithmically C equidistant not in m, but in Tau(ross) C C ***************************************************** C IF(NNEWD.GT.0.AND.ITGREY.EQ.0.AND.TAUROS(ND).GT.10.) THEN DO III=1,NNEWD CALL NEWDM END DO END IF C C another modification of the depth scale C IF(NNEWD.LT.0) THEN DO III=1,-NNEWD CALL NEWDMT END DO END IF C IF(HMIX0.GT.0.) THEN CALL CONTMD GO TO 200 END IF C C ***************************************************** C C If ITGMAX = 0 - no iterative improvement of the pseudo-grey C model is required C IF(ITGMAX.EQ.0) GO TO 200 IF(ITGREY.EQ.0) ITGREY=1 C C Opacities and mean intensities in all frequency points ; C evaluation of appropriate integrals over frequency C CALL RADTOT C C Interpolation of TOTH and FLOPAC, which are determined by RTE C at the intermediate depth ponts DM(ID+1/2) to the grid DM C DO ID=2,ND-1 A1=DM(ID+1)-DM(ID-1) A0=(DM(ID)-DM(ID-1))/A1 A1=(DM(ID+1)-DM(ID))/A1 TOTH(ID)=A0*TOTH(ID+1)+A1*TOTH(ID) FLOPAC(ID)=A0*FLOPAC(ID+1)+A1*FLOPAC(ID) END DO TOTH(ND)=0. FLOPAC(ND)=FLOPAC(ND-1) C C Determination of new temperature C IF(IPRING.GE.1) WRITE(6,613) ITGREY DO ID=1,ND HMECH=TOTF*(UN-THETA(ID)) DFLUX=TOTH(ID)-HMECH FAKK=TOTK(ID)/TOTJ(ID) ABRAD=RDOPAC(ID)/DENS(ID)/TOTJ(ID) GAMJ(ID)=ABRAD/ABPLAD(ID)/FAKK*THIRD IF(ID.NE.ND) THEN ABFLX=FLOPAC(ID)/TOTH(ID) ELSE ABFLX=ABFLXM END IF abflx=abrosd(id) IF(ID.EQ.1) THEN FHH=TOTH(ID)/TOTJ(ID) GAMH=FAKK/FHH/5.7753D-1 TAUFLX(ID)=ABFLX*DM(ID) TAUTHE(ID)=TAUFLX(ID)*THETA(ID)/(ZETA1+TWO) DFINT=TAUFLX(ID)*DFLUX DB0=FAKK/FHH*DFLUX ELSE IF(DM(ID).LE.DMVISC*DM(ND)) THEN ZETAD=ZETA1 ELSE ZETAD=ZETA0 END IF DDM=DM(ID)-DM(ID-1) A0=(ABFLXM*DM(ID)-ABFLX*DM(ID-1))/DDM/(ZETAD+TWO) A1=(ABFLX-ABFLXM)/DDM/(ZETAD+3.D0) TAUFLX(ID)=TAUFLX(ID-1)+DDM*HALF*(ABFLXM+ABFLX) TAUTHE(ID)=TAUTHE(ID-1)+ * A0*(THETA(ID)*DM(ID)-THETA(ID-1)*DM(ID-1))+ * A1*(THETA(ID)*DM(ID)**2-THETA(ID-1)*DM(ID-1)**2) DFINT=DFINT+DDM*HALF*(ABFLXM*DFLUXM+ABFLX*DFLUX) END IF ABFLXM=ABFLX DFLUXM=DFLUX IF(ITGMAX.GE.0) THEN C C generalized Unsold-Lucy procedure C B0=FOUR*SIG4P*TEMP(ID)**4 DIS=TOTF*VISCD(ID)/ABPLAD(ID)/DM(ND) DB1=ABRAD/ABPLAD(ID)*TOTJ(ID)-B0+DIS DB=DB1-3.D0*GAMJ(ID)*(DB0+DFINT) BNEW=FOUR*SIG4P*TEMP(ID)**4+DB TEMP(ID)=SQRT(SQRT(BNEW/4.D0/SIG4P)) BREL=DB/B0 END IF C C diagnostic output of iterative improvement C R2=ABFLX/ABROSD(ID) R3=ABRAD/ABPLAD(ID) IF(IPRING.GE.1) WRITE(6,614) ID,FAKK,TAUROS(ID), * ABROSD(ID),ABFLX,R2, * ABRAD,ABPLAD(ID),R3,TOTH(ID),HMECH,BREL END DO C 613 FORMAT(1H1,'ITERATIVE IMPROVEMENT, ITGREY =',I2// * ' ID FK TAUROS ABROS',4X, * 'ABFLUX RATIO ABRAD ABPLA RATIO',10X,'FLUX', * 7X,'MECH',4X,'DELTA(B)/B'/) 614 FORMAT(1H ,I3,1P2D9.2,1X,3D9.2,1X,3D9.2,3X,2D13.5,3X,D10.2) C IF(ITGREY.LE.IABS(ITGMAX)) GO TO 100 C C End of iteration loop for the pseudo-grey model C ------------------------------------------------------------------- C C C 2. The final part C Interpolation of the computed model to the depth scale which is C going to be used in the subsequent - complete-linearization - C step of the model construction C C C First option - no interpolation C C Second option - interpolation to the prescribed mass scale DM C 200 CONTINUE IF(IDEPTH.EQ.1) THEN CALL INTERP(DM,TEMP,DM0,TEMP0,ND,ND0,2,1,0) CALL INTERP(DM,ELEC,DM0,ELEC0,ND,ND0,2,1,1) CALL INTERP(DM,DENS,DM0,DENS0,ND,ND0,2,1,1) CALL INTERP(DM,ZD,DM0,ZD0,ND,ND0,2,1,0) END IF C C Third option - logarithmically equidistant Rosseland opt.depths C IF(IDEPTH.EQ.2) THEN READ(IBUFF,*) TAU1 TAU0(ND0)=TAUROS(ND) TAU2=TAU0(ND0)*0.99 DML0=LOG(TAU1) DLGM=(LOG(TAU2)-DML0)/(ND0-2) DO I=1,ND0-1 TAU0(I)=EXP(DML0+(I-1)*DLGM) END DO CALL INTERP(TAUROS,DM,TAU0,DM0,ND,ND0,2,1,0) CALL INTERP(TAUROS,TEMP,TAU0,TEMP0,ND,ND0,2,1,0) CALL INTERP(TAUROS,ELEC,TAU0,ELEC0,ND,ND0,2,1,1) CALL INTERP(TAUROS,DENS,TAU0,DENS0,ND,ND0,2,1,1) CALL INTERP(TAUROS,ZD,TAU0,ZD0,ND,ND0,2,1,0) END IF C C Fourth option - truncation of the disk and computing only C a disk atmosphere C IF(IDEPTH.GE.3) THEN TAU1=TAUROS(1) IF(IDEPTH.EQ.3) THEN READ(IBUFF,*) TDIV ELSE IF(IDEPTH.EQ.4) THEN READ(IBUFF,*) TAU0(ND) ELSE IF(IDEPTH.EQ.5) THEN READ(IBUFF,*) TDIV ELSE IF(IDEPTH.EQ.6) THEN READ(IBUFF,*) TAU0(1),TAU0(ND) END IF IF(IDEPTH.EQ.3.OR.IDEPTH.EQ.5) THEN DO ID=1,ND IF(TAUROS(ID).LE.TDIV.AND.TAUROS(ID+1).GT.TDIV) * ID1=ID END DO END IF if(tauros(nd).le.tdiv) ID1=ND IF(IDEPTH.EQ.3) THEN ND0=ID1 DO ID=1,ND0 DM0(ID)=DM(ID) TEMP0(ID)=TEMP(ID) ELEC0(ID)=ELEC(ID) DENS0(ID)=DENS(ID) ZD0(ID)=ZD(ID) END DO nd=nd0 ELSE IF(IDEPTH.EQ.5) THEN TAU0(ND0)=TAUROS(ID1) END IF IF(IDEPTH.GE.4) THEN TAU2=TAU0(ND0)*0.99 DML0=LOG(TAU1) DLGM=(LOG(TAU2)-DML0)/(ND0-2) DO I=1,ND0-1 TAU0(I)=EXP(DML0+(I-1)*DLGM) END DO CALL INTERP(TAUROS,DM,TAU0,DM0,ND,ND0,2,1,0) CALL INTERP(TAUROS,TEMP,TAU0,TEMP0,ND,ND0,2,1,0) CALL INTERP(TAUROS,ELEC,TAU0,ELEC0,ND,ND0,2,1,1) CALL INTERP(TAUROS,DENS,TAU0,DENS0,ND,ND0,2,1,1) CALL INTERP(TAUROS,ZD,TAU0,ZD0,ND,ND0,2,1,0) END IF c IFZ0=-1 ZND=ZD0(ND0) IF(INZD.GT.0) THEN INZD=0 IF(INSE.GT.0) INSE=INSE-1 END IF END IF C C in the two last options - interpolation from the previous C Rosseland opacity scale to the new scale and from the previous C mass depth scale to the new one C IF(IDEPTH.GT.0) THEN ND=ND0 DO I=1,ND DM(I)=DM0(I) TEMP(I)=TEMP0(I) ELEC(I)=ELEC0(I) DENS(I)=DENS0(I) ZD(I)=ZD0(I) END DO END IF C C Recalculation of the populations C DO ID=1,ND AN=DENS(ID)/WMM(ID)+ELEC(ID) ANEREL=ELEC(ID)/AN CALL ELDENS(ID,TEMP(ID),AN,ANE,ENRG,ENTT,WM,1) ELEC(ID)=ANE DENS(ID)=WMM(ID)*(AN-ANE) PGS(ID)=AN*BOLK*TEMP(ID) PHMOL(ID)=AHMOL CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) END DO if(nconit.lt.0) CALL PSOLVE IF(HMIX0.GE.0.AND.IPRING.GT.0) CALL CONOUT(2,IPRING) LCHC=LCHC0 RETURN END C C C **************************************************************** C C SUBROUTINE TEMPER(ID,TAUF,ITGR) C =============================== C C Auxiliary procedure for LTEGR C Evaluation of temperature, electron density, Rosseland opacity C and Planck mean opacity for at a given depth point C C Input parameters: C ID - depth index C TAUF - Rosseland optical depth (if ITGR = -1, 0 or 1 C - flux mean opacity (if ITGR > 1) C ITGR = -1, 0, 1 - means that TEMPER is called in the first C iteration of the pseudo-grey model; C temperature is evaluated; C > 1 - next iterations; temperature is given, C only evaluation of electron density and C populations C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0 PARAMETER (ERRT=1.D-3) C IT=0 IF(ITGR.GT.1.AND.ITGMAX.GT.0) THEN T=TEMP(ID) GO TO 10 END IF C IF(ID.EQ.1) THEN DDM=HALF*DM(ID) ELSE DDM=DM(ID)-DM(ID-1) END IF C C C Initial estimate of temperature for current values of Rosseland C and Planck mean opacities C call tlocal(id,tauf,t) C C ********** Iteration loop for determining temperature at depth ID C for a given total pressure C 10 IT=IT+1 TEMP(ID)=T C C Estimate of the gas pressure C PRAD=1.8912D-15*T4*(GAMH*5.7735D-1+TAUF-TAUTHE(ID)) PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PGAS=PGS(ID) PTOT=PGAS+PRAD+PTURB PTOTAL(ID)=PTOT PRADT(ID)=PRAD IF(PGAS.LE.0.) WRITE(6,603) ID,IT,PGAS,PTOT,PTURB,PRAD 603 format(' negative gas pressure!! id,it,pgas,p,pturb,prad =', * 2i3,1p4d9.2) C C Determination of electron density from the known temperature C and total pressure C if(ioptab.ge.-1) then AN=PGAS/T/BOLK CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) ELEC(ID)=ANE DENS(ID)=WMM(ID)*(AN-ANE) PHMOL(ID)=AHMOL VSND2(ID)=PTOTAL(ID)/DENS(ID) if(ioptab.ge.0) then CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) end if end if c IF(IT.GT.1.AND.REL.LT.ERRT) GO TO 30 C C For itgr.gt.1 - only new electron density and populations C IF(ITGR.GT.1) RETURN C C Evaluation of the Rosseland and Planck mean opacities C for the new values of temperature, electron density, and C populations (OPROS - Rosseland opacity per 1 cm**3; OPPLA - Planck C mean opacity per 1 cm**3) C if(ioptab.ge.0) then CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROS=OPROS/DENS(ID) ABPLA=OPPLA/DENS(ID) if(abpla.lt.abpmin) abpla=abpmin ABFLX=ABROS ABPLAD(ID)=ABPLA ABROSD(ID)=ABROS else if(ioptab.eq.-1) then rho=dens(id) call meanopt(t,id,rho,opros,oppla) abrosd(id)=opros abplad(id)=oppla abros=opros abpla=oppla else temp(id)=t rho=rhoeos(t,p) dens(id)=rho call meanopt(t,id,rho,opros,oppla) abrosd(id)=opros abplad(id)=oppla abros=opros abpla=oppla end if c IF(IT.GT.1.AND.REL.LT.ERRT) GO TO 30 C C New values of the Rosseland opacity and function tauthe C IF(ID.EQ.1) THEN TAUR=DM(ID)*ABROS TAUTHE(ID)=DM(ID)*ABFLX*THETA(ID)/(ZETA1+TWO) ELSE TAUR=TAUROS(ID-1)+DDM*HALF*(ABROSD(ID-1)+ABROS) ABFLXM=ABROSD(ID-1) ZETAD=ZETA0 IF(DM(ID).LE.DMVISC*DM(ND)) ZETAD=ZETA1 A0=(ABFLXM*DM(ID)-ABFLX*DM(ID-1))/DDM/(ZETAD+TWO) A1=(ABFLX-ABFLXM)/DDM/(ZETAD+3.D0) TAUTHE(ID)=TAUTHE(ID-1)+ * A0*(THETA(ID)*DM(ID)-THETA(ID-1)*DM(ID-1))+ * A1*(THETA(ID)*DM(ID)**2-THETA(ID-1)*DM(ID-1)**2) END IF TAUF=TAUR C C New value of temperature C call tlocal(id,tauf,t) C C Convergence criterion for temperature C (if REL < 1e-3, temperature is not recalculated again, but for C consistency the electron density and pressures are still C calculated consistently with the last temperature) C REL=ABS(T-TEMP(ID))/TEMP(ID) IF(IT.LE.5) GO TO 10 C C Store the final quantitites C 30 TEMP(ID)=T PGS(ID)=PGAS VSND2(ID)=PTOTAL(ID)/DENS(ID) ABROSD(ID)=ABROS ABPLAD(ID)=ABPLA TAUROS(ID)=TAUR TAUFLX(ID)=TAUF IF(ID.NE.1) RETURN DPRAD=1.8912D-15*T4*(TAUF-TAUTHE(ID)) HG1=SQRT(2.D0*PGS(1)/DENS(1)/QGRAV) HR1=DPRAD/DM(1)/QGRAV RR1=HR1/HG1 RETURN END C C C **************************************************************** C C subroutine tlocal(id,tauf,t) c ============================ c c local temperature as a a function of optical depth c for a grey model c c input; ID - depth index c TAUF - current estimate of the flux-mean opacity c output: T - local temperature c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' parameter (c1=0.8112,c2=3.966e14,c3=6.745e-10,c4=0.96, * c23=c2*c3,c34=c3*c4) c COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0 C if(tdisk.gt.0.) then t=tdisk return end if c vis=viscd(id)/(3.*dm(nd)) extra=4.*fak0*wdil*(tstar/teff)**4 gj=gamj(id) gh=gamh*5.7735e-1 gg=(tauf-tauthe(id))*fractv+gh+extra c if(icompt.eq.0.or.icomgr.eq.0) then t=(0.75*t4*(gj*gg+vis/abplad(id)))**0.25 return end if c epsbar=abplad(id)/abrosd(id) tfor=c1*teff*epsbar**(-0.125) tf0=tfor if(tauf.gt.un.and.tfor.lt.temp(id).or.tauf.ge.100.) then tfor=0. b=gg*(c3-c34) b=0. else b=gg*c3 end if a=epsbar/(0.75*t4) c=gg*(epsbar*gj+c34*tfor)+vis/abrosd(id) call quartc(a,b,c,t1) t=t1 c return end C C C *************************************************************** C C subroutine quartc(a,b,c,x) C ========================== c c solver for the algebraic equation of the fourth order c a*x**4 + b*x =c c c solution done by the Newton-Raphson method c c Initial estimate c INCLUDE 'IMPLIC.FOR' c if(a.gt.b) then x=(c/a)**0.25 else x=c/b end if c it=0 10 continue it=it+1 ax=a*x**3 v=c-b*x-x*ax d=4.*ax+b if(d.ne.0.) dx=v/d x=x+dx if(abs(dx/x).gt.1.e-3) then if(it.lt.20) go to 10 else if(it.ge.20) write(6,601) a,b,c,dx,x end if 601 format(' slow convergence of quartic solver'/ * ' a,b,c,dx,x = ',1p5e13.4) return end C C C ****************************************************************** C C SUBROUTINE NEWDM C ================ C C New m-scale, calculated as that corresponding to a new C tau(Ross)-scale, which is logarithmically equidistant, with C a generally different step in six different regions: C C 1. region between the original tau(1) and T0 (taken as 0.01); C 2. region between T0 and TC0 (taken as 0.01 and 0.1) - denser C mesh (with number of points N0) C 3. region between TC0 and TC1 (taken as 0.1 and 10.) - the C central region with densest mesh (N1 points) C 4. region between TC1 and T1 (taken as 10. and 100.) - as dens C as the second region (N0 points) C 5. the remaining region between T1 and the original last tau C (more precisely, the last-but-one point TAUROS(ND-1). C C If T1 is greater than the original last tau, the new tau-scale C is equidistant between T0 and the last tau. C C The procedure also calulates all the necessary state parameters C for the new depth scale (density, z, pressure, opacities, and C temperature) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (TEN=1.D1) DIMENSION TAU(MDEPTH),TAUL(MDEPTH),DM0(MDEPTH),DENS0(MDEPTH), * ABRS0(MDEPTH),ABPL0(MDEPTH) COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0 COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 C DATA N0,NC0 /8,24/ DATA T0,TC0,TC1,T1 /-2.D0,-1.D0,1.D0,2.D0/ C DO ID=1,ND DM0(ID)=DM(ID) DENS0(ID)=DENS(ID) ABRS0(ID)=ABROSD(ID) ABPL0(ID)=ABPLAD(ID) TAUL(ID)=LOG10(TAUROS(ID)) IF(TAUL(ID).LT.T0) IMIN=ID IF(TAUL(ID).LT.T1) IMAX=ID END DO ND1=ND-1 NC=2*N0+NC0 NB=ND1-NC IF(IMAX.GE.ND1) THEN IC=0 ELSE X=(TAUL(IMIN)-TAUL(1))/(TAUL(ND1)-TAUL(IMAX)) X1=FLOAT(NB)/(X+UN) IC=int(X1) END IF NB0=NB-IC C C New tau-scale C C First, logarithmically equidistant tau-points between tau(1) C (which is the previous TAUROS(1)), and log tau = T0. C Their number is NB0. c DT=(T0-TAUL(1))/FLOAT(NB0-1) TAU(1)=TAUL(1) DO ID=2,NB0 TAU(ID)=TAU(ID-1)+DT END DO C IF(IC.GT.0) THEN C C 2.region - between log tau = T0 and TC0 C DT=(TC0-T0)/FLOAT(N0) DO I=1,N0 TAU(NB0+I)=TAU(NB0+I-1)+DT END DO C C 3. The most dense region between TC0 and TC1 (central part) C NB1=NB0+N0 DT=(TC1-TC0)/FLOAT(NC0) DO I=1,NC0 TAU(NB1+I)=TAU(NB1+I-1)+DT END DO C C 4. The part similar to that between T0 and TC0, this time C betwen TC1 and T1 C NB2=NB1+NC0 DT=(T1-TC1)/FLOAT(N0) DO I=1,N0 TAU(NB2+I)=TAU(NB2+I-1)+DT END DO C C 5. The remainig part between T1 and the last-but-one tau C NB3=NB2+N0 DT=(TAUL(ND1)-T1)/FLOAT(IC) DO I=1,IC TAU(NB3+I)=TAU(NB3+I-1)+DT END DO TAU(ND)=TAUL(ND) C C The case where the last tau is smaller than T1; in this case C the points are logarithmically equidistant between T0 and the C last-but-one tau C ELSE DT=(TAUL(ND1)-T0)/FLOAT(NC) DO I=1,NC TAU(NB0+I)=TAU(NB0+I-1)+DT END DO TAU(ND)=TAUL(ND) C END IF C C --------------------------------------- C C Final new Rosseland optical depth scale C DO ID=1,ND TAU(ID)=TEN**TAU(ID) END DO C C Interpolation from the old to the new tau(Ross) scale to C get the new m-scale, density and Planck mean opacity C CALL INTERP(TAUROS,DM0,TAU,DM,ND,ND,2,1,1) CALL INTERP(DM0,DENS0,DM,DENS,ND,ND,2,1,1) CALL INTERP(DM0,ABRS0,DM,ABROSD,ND,ND,2,1,1) CALL INTERP(DM0,ABPL0,DM,ABPLAD,ND,ND,2,1,1) C C New Rosseland opacity and functions theta and tauthe C AMUV0=DMVISC**(ZETA0+UN) AMUV1=UN-AMUV0 DO ID=1,ND IF(DM(ID).LE.DMVISC*DM(ND)) THEN VISCD(ID)=(UN-FRACTV)*(ZETA1+UN)/ * DMVISC**(ZETA1+UN)*(DM(ID)/DM(ND))**ZETA1 THETA(ID)=(UN-FRACTV)*(DM(ID)/DMVISC/DM(ND))**(ZETA1+UN) ELSE VISCD(ID)=FRACTV*(ZETA0+UN)/AMUV1* * (DM(ID)/DM(ND))**ZETA0 THETA(ID)=(UN-FRACTV)+FRACTV*((DM(ID)/DM(ND))**(ZETA0+UN)- * AMUV0)/AMUV1 END IF GAMJ(ID)=UN IF(ID.EQ.1) THEN TAUROS(ID)=DM(ID)*ABROSD(ID) TAUTHE(ID)=TAUROS(ID)*THETA(ID)/(ZETA1+TWO) ANEREL=ELEC(ID)/(DENS(ID)/WMM(ID)+ELEC(ID)) ELSE DDM=DM(ID)-DM(ID-1) TAUROS(ID)=TAUROS(ID-1)+DDM*HALF*(ABROSD(ID-1)+ABROSD(ID)) ZETAD=ZETA0 IF(DM(ID).LE.DMVISC*DM(ND)) ZETAD=ZETA1 A0=(ABROSD(ID-1)*DM(ID)-ABROSD(ID)*DM(ID-1))/DDM/ * (ZETAD+TWO) A1=(ABROSD(ID)-ABROSD(ID-1))/DDM/(ZETAD+3.D0) TAUTHE(ID)=TAUTHE(ID-1)+ * A0*(THETA(ID)*DM(ID)-THETA(ID-1)*DM(ID-1))+ * A1*(THETA(ID)*DM(ID)**2-THETA(ID-1)*DM(ID-1)**2) END IF TAUR=TAUROS(ID) CALL TEMPER(ID,TAUR,1) END DO C C Next step - simultaneous solution of the hydrostatic C equilibrium and the z-m relation C if(nconit.ge.0) CALL HESOLV C C New temperature and mean opacities for the current density C and pressure C DO ID=1,ND TAUR=TAUROS(ID) CALL TEMPER(ID,TAUR,1) END DO C C Once again - simultaneous solution of the hydrostatic C equilibrium and the z-m relation C if(nconit.ge.0) CALL HESOLV C IF(IPRING.GE.1) THEN WRITE(6,601) DO ID=1,ND WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) END DO END IF C 601 FORMAT(1H1,' NEW DEPTH GRID ESTABLISHED, NEW MODEL:'/ * ' --------------------------------------'/ * ' ID DM TAUROSS TEMP NE P', * 8X,'ZD ROSS.MEAN PLANCK'/) 602 FORMAT(1H ,I3,1P2D9.2,0PF8.0,1P3D9.2,2X,2D9.2) C RETURN END C C C **************************************************************** C C SUBROUTINE NEWDMT C ================= C C New m-scale, calculated as that corresponding to the new C grid better representing temperature variations C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' DIMENSION DM0(MDEPTH),DM11(MDEPTH),DENS0(MDEPTH),ZD0(MDEPTH), * T0(MDEPTH),T1(MDEPTH),ELEC0(MDEPTH),PT0(MDEPTH), * ABRS0(MDEPTH),ABPL0(MDEPTH) COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0 COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0 C DO ID=1,ND DM0(ID)=LOG10(DM(ID)) T0(ID)=LOG10(TAUROS(ID)) ELEC0(ID)=ELEC(ID) DENS0(ID)=DENS(ID) PT0(ID)=PTOTAL(ID) ZD0(ID)=ZD(ID) ABRS0(ID)=ABROSD(ID) ABPL0(ID)=ABPLAD(ID) END DO ND1=ND-1 CALL GRIDP(DM0,T0,DM11,T1,ND1) DM11(ND)=DM0(ND) T1(ND)=T0(ND) DO ID=1,ND DM(ID)=EXP(2.3025851*DM11(ID)) TAUROS(ID)=EXP(2.3025851*T1(ID)) END DO CALL INTERP(DM0,ELEC0,DM11,ELEC,ND,ND,2,0,1) CALL INTERP(DM0,DENS0,DM11,DENS,ND,ND,2,0,1) CALL INTERP(DM0,PT0,DM11,PTOTAL,ND,ND,2,0,1) CALL INTERP(DM0,ZD0,DM11,ZD,ND,ND,2,0,0) CALL INTERP(DM0,ABRS0,DM11,ABROSD,ND,ND,2,0,1) CALL INTERP(DM0,ABPL0,DM11,ABPLAD,ND,ND,2,0,1) DO ID=1,ND VSND2(ID)=PTOTAL(ID)/DENS(ID) END DO C C New Rosseland opacity and functions theta and tauthe C AMUV0=DMVISC**(ZETA0+UN) AMUV1=UN-AMUV0 DO ID=1,ND IF(DM(ID).LE.DMVISC*DM(ND)) THEN VISCD(ID)=(UN-FRACTV)*(ZETA1+UN)/ * DMVISC**(ZETA1+UN)*(DM(ID)/DM(ND))**ZETA1 THETA(ID)=(UN-FRACTV)*(DM(ID)/DMVISC/DM(ND))**(ZETA1+UN) ELSE VISCD(ID)=FRACTV*(ZETA0+UN)/AMUV1* * (DM(ID)/DM(ND))**ZETA0 THETA(ID)=(UN-FRACTV)+FRACTV*((DM(ID)/DM(ND))**(ZETA0+UN)- * AMUV0)/AMUV1 END IF GAMJ(ID)=UN IF(ID.EQ.1) THEN TAUROS(ID)=DM(ID)*ABROSD(ID) TAUTHE(ID)=TAUROS(ID)*THETA(ID)/(ZETA1+TWO) ANEREL=ELEC(ID)/(DENS(ID)/WMM(ID)+ELEC(ID)) ELSE DDM=DM(ID)-DM(ID-1) TAUROS(ID)=TAUROS(ID-1)+DDM*HALF*(ABROSD(ID-1)+ABROSD(ID)) ZETAD=ZETA0 IF(DM(ID).LE.DMVISC*DM(ND)) ZETAD=ZETA1 A0=(ABROSD(ID-1)*DM(ID)-ABROSD(ID)*DM(ID-1))/DDM/ * (ZETAD+TWO) A1=(ABROSD(ID)-ABROSD(ID-1))/DDM/(ZETAD+3.D0) TAUTHE(ID)=TAUTHE(ID-1)+ * A0*(THETA(ID)*DM(ID)-THETA(ID-1)*DM(ID-1))+ * A1*(THETA(ID)*DM(ID)**2-THETA(ID-1)*DM(ID-1)**2) END IF TAUR=TAUROS(ID) CALL TEMPER(ID,TAUR,1) END DO C C Next step - simultaneous solution of the hydrostatic C equilibrium and the z-m relation C if(nconit.ge.0) CALL HESOLV C C New temperature and mean opacities for the current density C and pressure C DO ID=1,ND TAUR=TAUROS(ID) CALL TEMPER(ID,TAUR,1) END DO C C Once again - simultaneous solution of the hydrostatic C equilibrium and the z-m relation C if(nconit.ge.0) CALL HESOLV C IF(IPRING.GE.1) THEN WRITE(6,601) DO ID=1,ND WRITE(6,602) ID,DM(ID),TAUROS(ID), * TEMP(ID),ELEC(ID),PTOTAL(ID), * ZD(ID),ABROSD(ID),ABPLAD(ID) END DO END IF C 601 FORMAT(1H1,' NEW DEPTH GRID ESTABLISHED, NEW MODEL:'/ * ' --------------------------------------'/ * ' ID DM TAUROSS TEMP NE P', * 8X,'ZD ROSS.MEAN PLANCK'/) 602 FORMAT(1H ,I3,1P2D9.2,0PF8.0,1P3D9.2,2X,2D9.2) C RETURN END C C C **************************************************************** C C SUBROUTINE GRIDP(X,Y,XNEW,YNEW,N) c ================================= c c evaluation of new grid points for a function; grid points c determined by dividing the curve Y=f(x) into n-1 equal segments; c the x-coordinates of the endpoints of the individual segments c define new grid points C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' DIMENSION X(N),Y(N),XNEW(N),YNEW(N),Z(MDEPTH) C C original segments - lengths (Z), and directional cosines (CD); C ZTOT - total length of the curve; C Z0 - length of a new segment C ZTOT=0. DO I=2,N Z(I-1)=SQRT((X(I)-X(I-1))**2+(Y(I)-Y(I-1))**2) ZTOT=ZTOT+Z(I-1) END DO Z0=ZTOT/(N-1) C ISEG=1 XLAST=X(ISEG) YLAST=Y(ISEG) ZREST=Z(ISEG) ZREM=Z0 IP=1 XNEW(IP)=X(1) YNEW(IP)=Y(1) C 20 CONTINUE IF(ZREM.LT.ZREST) THEN ZREST=ZREST-ZREM XLAST=XLAST+ZREM*(X(ISEG+1)-X(ISEG))/Z(ISEG) YLAST=YLAST+ZREM*(Y(ISEG+1)-Y(ISEG))/Z(ISEG) IP=IP+1 XNEW(IP)=XLAST YNEW(IP)=YLAST ZREM=Z0 IF(IP.GE.N-1) GO TO 50 ELSE ZREM=ZREM-ZREST ISEG=ISEG+1 XLAST=X(ISEG) YLAST=Y(ISEG) ZREST=Z(ISEG) END IF GO TO 20 50 XNEW(N)=X(N) YNEW(N)=Y(N) RETURN END C C C **************************************************************** C C SUBROUTINE HESOLV C ================= C C Solution of the coupled system of hydrostatic equilibrium equation C and the z-m relation; with a given (generally depth-dependent) sound C speed, defined as total pressure/density. C Numerical solution by a Newton-Raphson method C C Input: P - initial total pressure C VSND2 - sound speed squared C HG1 - gas pressure scale height at the surface C RR1 - ratio of radiation and gas pressure scale heights C at the surface C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 DIMENSION P(MDEPTH),B(2,2),C(2,2),VL(2), * D(2,2,MDEPTH),ANU(2,MDEPTH) C DATA ERROR /1.D-4/ C C Density for a given total pressure and sound speed C DO ID=1,ND P(ID)=PTOTAL(ID) vsnd2(id)=p(id)/dens(id) END DO C C Consistent z-values C c ZD(ND)=ZND c DO IID=1,ND-1 c ID=ND-IID c ZD(ID)=ZD(ID+1)+HALF*(DM(ID+1)-DM(ID))*(UN/DENS(ID)+ c * UN/DENS(ID+1)) c END DO C C Basic Newton-Raphson iteration loop C ITERH=0 30 CONTINUE ITERH=ITERH+1 C C ------------------- C Forward elimination C ------------------- C C Upper boundary condition C ID=1 X=ZD(1)/HG1-RR1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=1.772453851D0*EXP(X*X)*ERFCX(X) ELSE F1=(UN-HALF/X/X)/X END IF BET0=HALF/DENS(ID)/P(ID) BETP=HALF/DENS(ID+1)/P(ID+1) GAMA=UN/(DM(ID+1)-DM(ID)) B(1,1)=F1 B(1,2)=TWO*(X*F1-UN)*P(1)/HG1 B(2,1)=BET0 B(2,2)=GAMA C(1,1)=0. C(1,2)=0. C(2,1)=-BETP C(2,2)=GAMA VL(1)=DM(ID)*2.D0*VSND2(ID)/HG1-P(ID)*F1 VL(2)=BET0*P(ID)+BETP*P(ID+1)-GAMA*(ZD(ID)-ZD(ID+1)) ANU(1,ID)=0. ANU(2,ID)=0. CALL MATINV(B,2,2) DO I=1,2 DO J=1,2 S=0. DO K=1,2 S=S+B(I,K)*C(K,J) END DO D(I,J,ID)=S ANU(I,ID)=ANU(I,ID)+B(I,J)*VL(J) END DO END DO C C Normal depth points 1 < ID < ND C DO ID=2,ND-1 BET0=BETP BETP=HALF/DENS(ID+1)/P(ID+1) GAMA=UN/(DM(ID+1)-DM(ID)) DMD=HALF*(DM(ID+1)-DM(ID-1)) AA=UN/(DM(ID)-DM(ID-1))/DMD CC=GAMA/DMD BB=AA+CC BQ=QGRAV/P(ID)/DENS(ID) B(1,1)=BB+BQ-AA*D(1,1,ID-1) B(1,2)=-AA*D(1,2,ID-1) B(2,1)=BET0 B(2,2)=GAMA C(1,1)=CC C(1,2)=0. C(2,1)=-BETP C(2,2)=GAMA VL(1)=AA*P(ID-1)+CC*P(ID+1)-(BB-BQ)*P(ID)+AA*ANU(1,ID-1) VL(2)=BET0*P(ID)+BETP*P(ID+1)-GAMA*(ZD(ID)-ZD(ID+1)) CALL MATINV(B,2,2) ANU(1,ID)=0. ANU(2,ID)=0. DO I=1,2 DO J=1,2 S=0. DO K=1,2 S=S+B(I,K)*C(K,J) END DO D(I,J,ID)=S ANU(I,ID)=ANU(I,ID)+B(I,J)*VL(J) END DO END DO END DO C C Lower boundary condition C ID=ND AA=TWO/(DM(ID)-DM(ID-1))**2 BQ=QGRAV/P(ID)/DENS(ID) B(1,1)=AA+BQ-AA*D(1,1,ID-1) B(1,2)=-AA*D(1,2,ID-1) B(2,1)=0. B(2,2)=UN VL(1)=QGRAV/DENS(ID)+AA*(P(ID-1)-P(ID)+ANU(1,ID-1)) VL(2)=0. CALL MATINV(B,2,2) ANU(1,ID)=0. ANU(2,ID)=0. DO I=1,2 DO J=1,2 S=0. DO K=1,2 S=S+B(I,K)*C(K,J) END DO D(I,J,ID)=S ANU(I,ID)=ANU(I,ID)+B(I,J)*VL(J) END DO END DO C C ------------ C Backsolution C ------------ C P(ID)=P(ID)+ANU(1,ID) ZD(ID)=ZND CHMAXX=ABS(ANU(1,ID)/P(ID)) DO IID=1,ND-1 ID=ND-IID DO I=1,2 DO J=1,2 ANU(I,ID)=ANU(I,ID)+D(I,J,ID)*ANU(J,ID+1) END DO END DO CH1=ANU(1,ID)/P(ID) CH2=ANU(2,ID)/ZD(ID) IF(ABS(CH1).GT.CHMAXX) CHMAXX=ABS(CH1) IF(ABS(CH2).GT.CHMAXX) CHMAXX=ABS(CH2) IF(CH1.LT.-0.9D0) CH1=-0.9D0 IF(CH1.GT.9.D0) CH1=9.D0 P(ID)=P(ID)*(UN+CH1) END DO C C Recalculate density for the new total pressure C DO ID=1,ND DENS(ID)=P(ID)/VSND2(ID) END DO C C New z-values C ZD(ND)=ZND DO IID=1,ND-1 ID=ND-IID ZD(ID)=ZD(ID+1)+HALF*(DM(ID+1)-DM(ID))*(UN/DENS(ID)+ * UN/DENS(ID+1)) END DO C C Convergence criterion for the Newton-Raphson method C IF(IPRING.GE.1) WRITE(6,601) ITERH,CHMAXX 601 FORMAT(/' solution of hydrostatic eq. + z-m relation:', * 'iter = ',I3,' max.rel.chan. =',1PD10.2) IF(CHMAXX.GT.ERROR.AND.ITERH.LT.10) GO TO 30 C DO ID=1,ND X=PGS(ID)/PTOTAL(ID) PTOTAL(ID)=P(ID) PGS(ID)=X*P(ID) END DO C C Recalculation of the populations C if(ih2p.ge.0) then ID=1 ANEREL=ELEC(ID)/(DENS(ID)/WMM(ID)+ELEC(ID)) DO ID=1,ND CALL RHONEN(ID,TEMP(ID),DENS(ID),AN,ANE) ELEC(ID)=ANE CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) END DO end if RETURN END C C C **************************************************************** C C SUBROUTINE HESOL6 C ================= C C Solution of the coupled system of C 1) hydrostatic equilibrium equation; C 2) definitions of Ptotal, Pgas and rho; C 3) state equation C 4) z-m relation C with a given temperature and radiation pressure C Numerical solution by a Newton-Raphson method C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (MP=6,NP=6,IP=1,IG=2,IR=3,IN=4,IE=5,IZ=6) PARAMETER (NITERH=15) COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1 DIMENSION P(MDEPTH),ANTT(MDEPTH),CHNG(MDEPTH), * VEC(MP,MDEPTH),VEC1(MP,MDEPTH), * VEC2(MP,MDEPTH),VEC3(MP,MDEPTH), * SOL(MP),ERR(MP),CHN(MP), * A(MP,MP),B(MP,MP),C(MP,MP),VL(MP), * D(MP,MP,MDEPTH),ANU(MP,MDEPTH), * anerl(mdepth) C DATA ERROR /1.D-4/ C C radiation pressure scale feight at the surface C ID=1 IF(ITER.EQ.0) THEN HR1=SIG4P*TEFF**4*PCK*ABROSD(ID)/QGRAV ELSE IF(NFREQE.GT.0) THEN DO IJ=1,NFREQE IJT=IJFR(IJ) IF(.NOT.LSKIP(ID,IJT)) THEN FLUXW=W(IJT)*(FH(IJT)*RADEX(IJ,ID)-HEXTRD(IJT)) GRD=GRD+FLUXW*ABSOE1(IJ) END IF END DO END IF HR1=PCK/QGRAV*(GRD+FPRD(ID))/DENS(ID) END IF do id=1,nd ANTT(ID)=DENS(ID)/WMM(ID)+ELEC(ID) PGS(ID)=ANTT(ID)*BOLK*TEMP(ID) PTOTAL(ID)=PRADT(ID)+PGS(ID) end do C C Basic Newton-Raphson iteration loop C ITERH=0 LAC2H=.FALSE. IACH=6 IACDH=4 IACH0=IACH-3 10 CONTINUE ITERH=ITERH+1 C C ------------------- C Forward elimination C ------------------- C DO ID=1,ND ANTT(ID)=DENS(ID)/WMM(ID)+ELEC(ID) PGS(ID)=ANTT(ID)*BOLK*TEMP(ID) PTOTAL(ID)=PRADT(ID)+PGS(ID) P(ID)=PTOTAL(ID) VEC(IP,ID)=PTOTAL(ID) VEC(IG,ID)=PGS(ID) VEC(IR,ID)=DENS(ID) VEC(IN,ID)=ANTT(ID) VEC(IE,ID)=ELEC(ID) VEC(IZ,ID)=ZD(ID) C DO I=1,NP VL(I)=0. DO J=1,NP B(I,J)=0. A(I,J)=0. C(I,J)=0. END DO END DO C IF(ID.EQ.1) THEN HG1=SQRT(TWO*PGS(ID)/DENS(ID)/QGRAV) X=(ZD(ID)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF X1=X*1.01 F1D=0. IF(X1.LT.3.) THEN F1D=8.86226925D-1*EXP(X1*X1)*ERFCX(X1) ELSE F1D=HALF*(UN-HALF/X1/X1)/X1 END IF IF(X.GT.0.) F1D=(F1D-F1)*100./X B(IG,IG)=DENS(ID)*HG1*HALF/PGS(ID)*(F1-F1D*X) B(IG,IR)=HG1*HALF*(F1+F1D*X) B(IG,IZ)=DENS(ID)*F1D VL(IG)=DM(ID)-DENS(ID)*HG1*F1 B(IP,IP)=UN B(IP,IG)=-UN VL(IP)=PRADT(ID)+PGS(ID)-P(ID) ELSE DMM=UN/(DM(ID)-DM(ID-1)) QG=HALF*QGRAV B(IP,IP)=DMM B(IP,IZ)=-QG A(IP,IP)=DMM A(IP,IZ)=QG VL(IP)=QG*(ZD(ID)+ZD(ID-1))-(P(ID)-P(ID-1))*DMM B(IG,IP)=UN B(IG,IG)=-UN VL(IG)=PRADT(ID)+PGS(ID)-P(ID) END IF C B(IR,IR)=UN B(IR,IN)=-WMM(ID) B(IR,IE)=WMM(ID) VL(IR)=wmm(id)*(antt(id)-elec(id))-dens(id) C B(IN,IG)=UN B(IN,IN)=-BOLK*TEMP(ID) VL(IN)=antt(id)*bolk*temp(id)-pgs(id) C T=TEMP(ID) AN=ANTT(ID) ANERL(ID)=ELEC(ID)/AN B(IE,IE)=UN b(ie,in)=-anerl(id) vl(ie)=anerl(id)*antt(id)-elec(id) C IF(ID.LT.ND) THEN DMP=(DM(ID+1)-DM(ID))*HALF B(IZ,IR)=DMP/DENS(ID)**2 B(IZ,IZ)=UN C(IZ,IR)=-DMP/DENS(ID+1)**2 C(IZ,IZ)=UN VL(IZ)=ZD(ID+1)-ZD(ID)+DMP/DENS(ID)+DMP/DENS(ID+1) ELSE B(IZ,IZ)=UN VL(IZ)=0. END IF C IF(ID.GT.1) THEN B(IP,IR)=B(IP,IR)- * A(IP,IP)*D(IP,IR,ID-1)- * A(IP,IZ)*D(IZ,IR,ID-1) B(IP,IZ)=B(IP,IZ)- * A(IP,IP)*D(IP,IZ,ID-1)- * A(IP,IZ)*D(IZ,IZ,ID-1) VL(IP)=VL(IP)+A(IP,IP)*ANU(IP,ID-1)+ * A(IP,IZ)*ANU(IZ,ID-1) END IF C CALL MATINV(B,NP,MP) C DO I=1,NP SUM=0. DO J=1,NP SUM=SUM+B(I,J)*VL(J) END DO ANU(I,ID)=SUM END DO IF(ID.LT.ND) THEN DO I=1,NP D(I,IR,ID)=B(I,IZ)*C(IZ,IR) D(I,IZ,ID)=B(I,IZ)*C(IZ,IZ) END DO END IF END DO C C ------------------- C backsubstitution C ------------------- C CHANM=0 DO ID=ND,1,-1 CHNG(ID)=0. IF(ID.EQ.ND) THEN DO I=1,NP SOL(I)=ANU(I,ID) END DO ELSE DO I=1,NP ANU(I,ID)=ANU(I,ID)+D(I,IR,ID)*ANU(IR,ID+1)+ * D(I,IZ,ID)*ANU(IZ,ID+1) SOL(I)=ANU(I,ID) END DO END IF DO I=1,NP CHAN=0. IF(VEC(I,ID).NE.0.) CHAN=SOL(I)/VEC(I,ID) CHN(I)=CHAN IF(ABS(CHAN).GT.CHANM) CHANM=ABS(CHAN) IF(ABS(CHAN).GT.CHNG(ID)) CHNG(ID)=ABS(CHAN) IF(CHAN.LT.-0.99) CHAN=-0.99 IF(CHAN.GT.99.00) CHAN=99.00 VEC(I,ID)=VEC(I,ID)*(UN+CHAN) END DO C PTOTAL(ID)=VEC(IP,ID) P(ID)=PTOTAL(ID) PGS(ID)=VEC(IG,ID) DENS(ID)=VEC(IR,ID) ANTT(ID)=VEC(IN,ID) ELEC(ID)=VEC(IE,ID) ZD(ID)=VEC(IZ,ID) C IF(ID.EQ.1) THEN HG1=SQRT(TWO*PGS(ID)/DENS(ID)/QGRAV) X=(ZD(ID)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF ERR(IP)=(DENS(ID)*HG1*F1-DM(ID))/DM(ID) ELSE IF(ID.LT.ND) THEN ERR(IP)=(P(ID+1)-P(ID))/(DM(ID+1)-DM(ID))* * TWO/QGRAV/(ZD(ID+1)+ZD(ID))-UN ELSE ERR(IP)=0. END IF IF(P(ID).NE.0.) ERR(IG)= * (PRADT(ID)+PGS(ID)-P(ID))/P(ID) IF(DENS(ID).NE.0.) ERR(IR)= * (DENS(ID)-(ANTT(ID)-ELEC(ID))*WMM(ID))/DENS(ID) IF(PGS(ID).NE.0.) ERR(IN)= * (PGS(ID)-ANTT(ID)*BOLK*TEMP(ID))/PGS(ID) IF(ELEC(ID).NE.0.) * ERR(IE)=(ELEC(ID)-ANerl(id)*antt(id))/ELEC(ID) IF(ID.LT.ND) THEN ERR(IZ)=(ZD(ID)-ZD(ID+1))*TWO/(DM(ID+1)-DM(ID))/ * (UN/DENS(ID)+UN/DENS(ID+1))-UN ELSE ERR(IZ)=ZD(ID) END IF END DO C C acceleration C IF(NITERH.LT.IACH .OR. ITERH.LT.IACH0) GO TO 100 ipngH=1 if(iacdH.gt.0) ipngH=mod((iterH-iacH),iacdH) if(.not.lac2H) then IPT=MOD(ITERH,3) IPT0=MOD(IACH,3) IPT1=MOD((IACH+1),3) IPT2=MOD((IACH+2),3) IF(ITERH.EQ.IACH0) THEN DO ID=1,ND DO IX=1,NP VEC3(IX,ID)=VEC(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT1) THEN DO ID=1,ND DO IX=1,NP VEC2(IX,ID)=VEC(IX,ID) END DO END DO ELSE IF(IPT.EQ.IPT2) THEN DO ID=1,ND DO IX=1,NP VEC1(IX,ID)=VEC(IX,ID) END DO END DO ENDIF else if (ipngH.ne.0) then DO ID=1,ND DO IX=1,NP VEC3(IX,ID)=VEC2(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NP VEC2(IX,ID)=VEC1(IX,ID) END DO END DO DO ID=1,ND DO IX=1,NP VEC1(IX,ID)=VEC(IX,ID) END DO END DO GO TO 100 end if IF(ITERH.LT.IACH) GO TO 100 C A1=0. B1=0. B2=0. C1=0. C2=0. DO IX=1,NP DO ID=1,ND WT=0. IF(VEC(IX,ID).NE.0.) WT=1./ABS(VEC(IX,ID)) D0=VEC(IX,ID)-VEC1(IX,ID) D1=D0-VEC1(IX,ID)+VEC2(IX,ID) D2=D0-VEC2(IX,ID)+VEC3(IX,ID) A1=A1+WT*D1*D1 B1=B1+WT*D1*D2 B2=B2+WT*D2*D2 C1=C1+WT*D0*D1 C2=C2+WT*D0*D2 END DO END DO AB=B2*A1-B1*B1 IF(AB.EQ.0.) THEN IACH=IACH+IACDH IACH0=IACH-3 GO TO 100 END IF AA=(B2*C1-B1*C2)/AB BB=(A1*C2-B1*C1)/AB DO ID=1,ND DO IX=1,NP VEC(IX,ID)=(UN-AA-BB)*VEC(IX,ID)+AA*VEC1(IX,ID)+ * BB*VEC2(IX,ID) END DO END DO LAC2H=.TRUE. 100 CONTINUE C DO ID=1,ND PTOTAL(ID)=VEC(IP,ID) P(ID)=PTOTAL(ID) PGS(ID)=VEC(IG,ID) DENS(ID)=VEC(IR,ID) ANTT(ID)=VEC(IN,ID) ELEC(ID)=VEC(IE,ID) ZD(ID)=VEC(IZ,ID) C IF(ID.EQ.1) THEN HG1=SQRT(TWO*PGS(ID)/DENS(ID)/QGRAV) X=(ZD(ID)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF ERR(IP)=(DENS(ID)*HG1*F1-DM(ID))/DM(ID) ELSE IF(ID.LT.ND) THEN ERR(IP)=(P(ID)-P(ID-1))/(DM(ID)-DM(ID-1))* * TWO/QGRAV/(ZD(ID)+ZD(ID-1))-UN END IF IF(P(ID).NE.0.) ERR(IG)= * (PRADT(ID)+PGS(ID)-P(ID))/P(ID) IF(DENS(ID).NE.0.) ERR(IR)= * (DENS(ID)-(ANTT(ID)-ELEC(ID))*WMM(ID))/DENS(ID) IF(PGS(ID).NE.0.) ERR(IN)= * (PGS(ID)-ANTT(ID)*BOLK*TEMP(ID))/PGS(ID) IF(ELEC(ID).NE.0.) * ERR(IE)=(ELEC(ID)-ANerl(id)*antt(id))/ELEC(ID) IF(ID.GT.1) THEN ERR(IZ)=(ZD(ID-1)-ZD(ID))*TWO/(DM(ID)-DM(ID-1))/ * (UN/DENS(ID-1)+UN/DENS(ID))-UN ELSE ERR(IZ)=0. END IF END DO C C Convergence criterion for the Newton-Raphson method C IF(CHANM.GT.ERROR.AND.ITERH.LT.NITERH) GO TO 10 C RETURN END C C C C *************************************************************** C C SUBROUTINE PSOLVE C ================= C C "formal" solution of the second-order equation for the total C pressure - d**2 P/d m**2 = Q/DENS; C with known density C the resulting tridiagonal system is solved by the standard C elimination C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' DIMENSION D(MDEPTH),ANU(MDEPTH) C C forward elimination C ID=1 B=1.D0 VL=PTOTAL(ID) D(ID)=0. ANU(ID)=VL/B DO ID=2,ND-1 DMD=HALF*(DM(ID+1)-DM(ID-1)) A=UN/DMD/(DM(ID)-DM(ID-1)) C=UN/DMD/(DM(ID+1)-DM(ID)) B=A+C-A*D(ID-1) VL=QGRAV/DENS(ID) D(ID)=C/B ANU(ID)=(VL+A*ANU(ID-1))/B END DO ID=ND A=TWO/(DM(ID)-DM(ID-1))**2 B=A-A*D(ID-1) VL=QGRAV/DENS(ID) ANU(ID)=(VL+A*ANU(ID-1))/B PTOTAL(ND)=ANU(ND) C C backsubstitution C DO IID=1,ND-1 ID=ND-IID PTOTAL(ID)=ANU(ID)+D(ID)*PTOTAL(ID+1) END DO RETURN END C C C **************************************************************** C C SUBROUTINE ZMRHO(R,HG) C ====================== C C Initial estimate of DM, DENS, and ZD C by an approximate solution of the hydrostatic equilibrium C equation C Both gas and radiation pressure contribute; C C Input: R - ration of radiation to gas pressure scale heights C HG - gas pressure scale height C DM1 - mass at the first depth point C DMTOT - mass at the last depth point (central plane) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (PISQ=1.77245385090551D0,pisq2=pisq*half) C C Mass-depth grid - logarithmicaly equidistant C if(nd.gt.mdepth) nd=mdepth C if(dm1.gt.0) then DM(ND)=DMTOT DM(ND-1)=0.99D0*DMTOT DML=LOG(DM(ND-1)/DM1)/(ND-2) DML1=LOG(DM1) DO ID=1,ND-1 DM(ID)=EXP(DML1+(ID-1)*DML) END DO else if(dm1.lt.-1.e-20.and.dm1.gt.-1.e-10) then DM(ND)=DMTOT DM1=ABS(DM1*1.e20) DML=LOG(DM(ND)/DM1)/(ND-1) DML1=LOG(DM1) DO ID=1,ND-1 DM(ID)=EXP(DML1+(ID-1)*DML) end do else if(dm1.gt.-1.e-10) then if(mod(nd,2).eq.0) nd=nd-1 dmha=dmtot*half dm1=abs(dm1*1.e10) ndha=nd/2 dml=log(dmha/dm1)/ndha dml1=log(dm1) dm(nd)=dmtot do id=1,ndha dm(id)=exp(dml1+(id-1)*dml) dm(nd-id)=dm(nd)-exp(dml1+id*dml) end do C C Determination of the total pressure scale height - function BETAH C HH - total pressure scale height C end if HH=BETAH(R)*R DMH=PISQ/2.D0*EXP(-R*(HH-R))*ERFCX(HH-R)/HH RHO0=DM(ND)/HH/HG C C Approximate solution of the hydrostatic equilibrium C DO ID=1,ND DMREL=DM(ID)/DM(ND) IF(DMREL.LE.DMH) THEN X=R+ERFCIN(DMREL*2.D0/PISQ*HH*EXP(R*(HH-R))) RHO=EXP(-(X-R)*(X-R)-(HH-R)*R) ELSE IF(DMREL.LT.UN) THEN HSQ=SQRT(HH*(HH-R)) X=ERFCIN(2.D0/PISQ*HSQ*(DMREL-DMH)+ERFCX(HSQ))*HH/HSQ RHO=EXP(-X*X*(UN-R/HH)) ELSE X=0. RHO=UN END IF DENS(ID)=RHO0*RHO ZD(ID)=X*HG END DO c if(dm1.lt.-1.e-10) then DM(ND)=DMTOT DM(ND-1)=0.99D0*DMTOT dm1=abs(dm1) DML=LOG(DM(ND-1)/DM1)/(ND-2) DML1=LOG(DM1) DO ID=1,ND-1 DM(ID)=EXP(DML1+(ID-1)*DML) end do c hr=r*hg hg2=hg*pisq2 hrg=hr+hg2 dmh=hg2/hrg rho0=dmtot/hrg do id=1,nd dmrel=dm(id)/dm(nd) if(dmrel.ge.dmh) then zd(id)=hrg*(un-dmrel) dens(id)=rho0 else zd(id)=hr+hg*erfcin(dmrel*hrg/hg2) x=(zd(id)-hr)/hg dens(id)=rho0*exp(-x*x) end if end do end if RETURN END C C C ******************************************************************** C C FUNCTION BETAH(R) C ================= C C Determination of the total pressure scale height C Solution of the transcendental equation by the Newton-Raphson method C INCLUDE 'IMPLIC.FOR' PARAMETER (UN=1.D0, * PISQ=1.77245385090551D0) IF(R.LT.0.88) THEN BET0=PISQ/2.D0/R ELSE BET0=UN+UN/3.D0/R/R END IF C ITER=0 BETA=BET0 10 ITER=ITER+1 B1=BETA-UN RB1=R*B1 BSQ=SQRT(BETA*B1) ERF1=ERFCX(R*BSQ) ERF2=ERFCX(RB1) RHS=BSQ/B1*(UN-ERF1)+EXP(-R*RB1)*ERF2 DP=R/PISQ*(2.D0-EXP(-R*BETA*RB1))+(UN-ERF1)/2.D0/B1/BSQ+ * R*R*EXP(-R*RB1)*ERF2 DBETA=(RHS-2.D0/PISQ*BETA*R)/DP DEL=DBETA/BETA BETA=BETA+DBETA IF(ABS(DEL).GT.1.D-5.AND.ITER.LE.10) GO TO 10 BETAH=BETA RETURN END C C C *********************************************************** C C FUNCTION ERFCIN(X) C ================== C C Approximate inverse complementary error function inverfc(x) C INCLUDE 'IMPLIC.FOR' parameter (pisq=1.77245385090551D0, pisq2=pisq/2.d0) XL=-LOG(X) REL=0.88623D0+XL*(7.4871471D-3-XL*1.7726701D-4) E=SQRT(-LOG(X*(2.D0-X)))*REL iterr=0 10 continue iterr=iterr+1 dele=(erfcx(e)-x)*pisq2*exp(e*e) err=abs(dele/e) e=e+dele if(err.gt.1.e-6.and.iterr.lt.10) go to 10 erfcin=e RETURN END C C C **************************************************************** C SUBROUTINE RADTOT C ================= C C Evaluation of integrated radiative intensities and moments C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ITERAT.FOR' COMMON/OPTDPT/DT(MDEPTH) COMMON/SURFEX/EXTJ(MFREQ),EXTH(MFREQ) COMMON/TOTJHK/TOTJ(MDEPTH),TOTH(MDEPTH),TOTK(MDEPTH), * RDOPAC(MDEPTH),FLOPAC(MDEPTH) DIMENSION SUMPL(MDEPTH) C C zero the quantities C DO ID=1,ND ABROSD(ID)=0. SUMDPL(ID)=0. ABPLAD(ID)=0. SUMPL(ID)=0. TOTJ(ID)=0. TOTH(ID)=0. TOTK(ID)=0. RDOPAC(ID)=0. FLOPAC(ID)=0. if(id.lt.nd) THEN DELDM(ID)=HALF*(DM(ID+1)-DM(ID)) deldmz(id)=deldm(id) if(izscal.eq.1) deldmz(id)=half*(zd(id)-zd(id+1)) end if END DO DEDM1=DM(1)/DENS(1) C C loop over frequencies C CALL TDPINI CALL OPAINI(1) DO IJ=1,NFREQ FR=FREQ(IJ) CALL OPACF1(IJ) CALL RTEFR1(IJ) WW=W(IJ) DO ID=1,ND PLAN=XKFB(ID)/XKF1(ID)*WW DPLAN=PLAN/XKF1(ID)*FREQ(IJ)*HKT21(ID) if(ioptab.ge.0) then ABROSD(ID)=ABROSD(ID)+DPLAN/ABSO1(ID) ABPLAD(ID)=ABPLAD(ID)+PLAN*(ABSO1(ID)-SCAT1(ID)) RDOPAC(ID)=RDOPAC(ID)+WW*RAD1(ID)*(ABSO1(ID)-SCAT1(ID)) else ar=(ABSO1(ID)-SCAT1(ID))*dens(id) ABROSD(ID)=ABROSD(ID)+DPLAN/(ABSO1(ID)*dens(id)) ABPLAD(ID)=ABPLAD(ID)+PLAN*AR RDOPAC(ID)=RDOPAC(ID)+WW*RAD1(ID)*AR end if SUMDPL(ID)=SUMDPL(ID)+DPLAN SUMPL(ID)=SUMPL(ID)+PLAN TOTJ(ID)=TOTJ(ID)+WW*RAD1(ID) TOTK(ID)=TOTK(ID)+WW*RAD1(ID)*FAK1(ID) IF(ID.LT.ND) THEN FLUX1=RAD1(ID+1)*FAK1(ID+1)-RAD1(ID)*FAK1(ID) TOTH(ID+1)=TOTH(ID+1)+WW*FLUX1/DT(ID) END IF END DO WF=WW*(FH(IJ)*RAD1(1)-HEXTRD(IJ)) TOTH(1)=TOTH(1)+WF if(ioptab.ge.0) then FLOPAC(1)=FLOPAC(1)+WF*ABSO1(1)/DENS(1) else FLOPAC(1)=FLOPAC(1)+WF*ABSO1(1) end if END DO c c Rosseland and Planck mean opacities C DO ID=1,ND ABROSD(ID)=SUMDPL(ID)/ABROSD(ID) ABPLAD(ID)=ABPLAD(ID)/SUMPL(ID) END DO C c Rosseland optical depth scale; flux mean c ID=1 TAUROS(ID)=HALF*DEDM1*ABROSD(ID) DO ID=2,ND DTAUR=DELDM(ID-1)*(ABROSD(ID)*DENS1(ID)+ * ABROSD(ID-1)*DENS1(ID-1)) TAUROS(ID)=TAUROS(ID-1)+DTAUR FLOPAC(ID)=(TOTK(ID)-TOTK(ID-1))/(DM(ID)-DM(ID-1)) END DO c c final Rosseland and Planck mean opacities C DO ID=1,ND ABROSD(ID)=ABROSD(ID)/DENS(ID) ABPLAD(ID)=ABPLAD(ID)/DENS(ID) END DO C RETURN END C C C **************************************************************** C C SUBROUTINE COOLRT C ================= C C Evaluation of cooling and heating rates for each ion C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' parameter (pi4=4.*3.14159265d0) DIMENSION CLHT1(MDEPTH),CLHT2(MDEPTH),CLHT3(MDEPTH) DIMENSION CLRAT(MION,MDEPTH),HTRAT(MION,MDEPTH) COMMON/COOLCO/ABSOTI(MION,MDEPTH),EMISTI(MION,MDEPTH), * ABSOC1(MDEPTH),EMISC1(MDEPTH) C DO ID=1,ND DO ION=1,NION CLRAT(ION,ID)=0. HTRAT(ION,ID)=0. END DO CLHT1(ID)=0. CLHT2(ID)=0. CLHT3(ID)=0. END DO C DO IJ=1,NFREQ IF(IJX(IJ).NE.-1) THEN CALL OPACFA(IJ) CALL RTEFR1(IJ) DO ID=1,ND DO ION=1,NION CLRAT(ION,ID)=CLRAT(ION,ID)+W(IJ)*EMISTI(ION,ID) HTRAT(ION,ID)=HTRAT(ION,ID)+ & W(IJ)*ABSOTI(ION,ID)*RAD1(ID) END DO EM=EMIS1(ID)+SCAT1(ID)*RAD1(ID) CLHT2(ID)=CLHT2(ID)+W(IJ)*(EM-ABSO1(ID)*RAD1(ID)) CLHT3(ID)=CLHT3(ID)+W(IJ)*EMIS1(ID) END DO C if(ipopac.eq.1) then if(ij.le.nfreqc) then write(85,685) ij,freq(ij),(absoc1(id)/dens(id),id=1,nd) end if end if if(ipopac.eq.2) then if(ij.le.nfreqc) then write(87,686) ij,freq(ij) taud=abso1(1)*dedm1 do id=1,nd if(id.gt.1) taud=taud+deldmz(id-1)* * (absot(id-1)+absot(id)) end do end if end if 685 format(i5,1pe15.7/(1p8e10.3)) 686 format(i5,1pe15.7) C END IF END DO C if(icoolp.le.0) return C DO ID=1,ND DO ION=1,NION CLHT1(ID)=CLHT1(ID)+CLRAT(ION,ID)-HTRAT(ION,ID) END DO WRITE(86,1060) ID,CLHT1(ID)*pi4,CLHT2(ID)*pi4, * CLHT3(ID)*pi4 1060 FORMAT(I5,1P3E14.6) END DO c if(icoolp.lt.2) return c DO ID=1,ND WRITE(87,1071) id, * ((CLRAT(ION,ID)-HTRAT(ION,ID))*pi4,ION=1,NION) END DO c if(icoolp.lt.10) return WRITE(87,1070) ND,NION IOFE2=0 DO ION=1,NION NN1=NFIRST(ION) IAT2=IATM(NN1) IF(NUMAT(IAT2).EQ.26 .and. IZ(ION).EQ.2) IOFE2=ION END DO REWIND 8 READ(8,*) NDR READ(8,*) TTR,RSR DO ID=ND,1,-1 READ(8,*) RSR WRITE(88,1071) RSR,CLRAT(IOFE2,ID) END DO 1070 FORMAT(2I5) 1071 FORMAT(i5/(1P6E13.5)) RETURN END C C C **************************************************************** C C C SUBROUTINE OPACFA(IJ) C ===================== C C Absorption, emission, and scattering coefficients C at frequency IJ and for all depths C C Saves additionally contributions per ion (for computing C ionic cooling and heating rates, see routine COOLRT) C C Input: IJ opacity and emissivity is calculated for the C frequency points with index IJ C Output: ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient (all scattering C mechanisms except electron scattering) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' INCLUDE 'ALIPAR.FOR' COMMON/COOLCO/ABSOTI(MION,MDEPTH),EMISTI(MION,MDEPTH), * ABSOC1(MDEPTH),EMISC1(MDEPTH) PARAMETER (C14=2.99793D14, CFF1=1.3727D-25) C C initialize c IF(ICOMPT.GT.0) THEN DO ID=1,ND ELSCAT(ID)=ELEC(ID)*SIGEC(IJ) END DO END IF C DO ID=1,ND ABSO1(ID)=ELSCAT(ID) EMIS1(ID)=0. SCAT1(ID)=ELSCAT(ID) ABSOC1(ID)=ABSO1(ID) EMISC1(ID)=0. DO ION=1,NION ABSOTI(ION,ID)=0. EMISTI(ION,ID)=0. END DO END DO C C basic frequency- and depth-dependent quantities C FR=FREQ(IJ) FRINV=UN/FR FR3INV=FRINV*FRINV*FRINV lfre=fr.gt.frtabm DO ID=1,ND XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) END DO C C ******** 1a. bound-free contribution - without dielectronic rec. C if(ifdiel.eq.0) then DO IBFT=1,NTRANC ITR=ITRBF(IBFT) SG=CROSS(IBFT,IJ) II=ILOW(ITR) JJ=IUP(ITR) iad=iadop(iatm(ii)) if(sg.gt.0..and.(iad.eq.0.or.(iad.gt.0.and.lfre))) then IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF ABSOTI(IEL(II),ID)=ABSOTI(IEL(II),ID)+SGD*ABTRA(ITR,ID) EMISTI(IEL(II),ID)=EMISTI(IEL(II),ID)+EMISBF END DO END IF END DO else C C ******** 1b. bound-free contribution - with dielectronic rec. C DO IBFT=1,NTRANC ITR=ITRBF(IBFT) II=ILOW(ITR) JJ=IUP(ITR) iad=iadop(iatm(ii)) if(sg.gt.0..and.(iad.eq.0.or.(iad.gt.0.and.lfre))) then IZZ=IZ(IEL(II)) IMER=IMRG(II) DO ID=1,ND SG=CROSSD(IBFT,IJ,ID) IF(SG.GT.0.) THEN SGD=SG IF(MCDW(ITR).GT.0) THEN CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1) DWF1(MCDW(ITR),ID)=DW1 SGD=SG*DW1 END IF IF(IFWOP(II).LT.0) THEN CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1) SGMG(IMER,ID)=SGME1 SGD=SGME1 END IF EMISBF=SGD*EMTRA(ITR,ID) ABSO1(ID)=ABSO1(ID)+SGD*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+EMISBF ABSOTI(IEL(II),ID)=ABSOTI(IEL(II),ID)+SGD*ABTRA(ITR,ID) EMISTI(IEL(II),ID)=EMISTI(IEL(II),ID)+EMISBF END IF END DO END IF END DO end if C C ******** 2. free-free contribution C DO ION=1,NION IT=ITRA(NNEXT(ION),NNEXT(ION)) iad=iadop(iatm(nnext(ion))) if(iad.gt.0.and..not.lfre) go to 40 C C hydrogenic with Gaunt factor = 1 C IF(IT.EQ.1) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF ABSOTI(ION,ID)=ABSOTI(ION,ID)+ABSOFF EMISTI(ION,ID)=EMISTI(ION,ID)+ABSOFF END DO C C hydrogenic with exact Gaunt factor C ELSE IF(IT.EQ.2) THEN DO ID=1,ND SF1=SFF3(ION,ID)*FR3INV SF2=SFF2(ION,ID) IF(FR.LT.FF(ION)) SF2=UN/XKF(ID) X=C14*CHARG2(ION)/FR SF2=SF2-UN+GFREE1(ID,X) ABSOFF=SF1*SF2 ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF ABSOTI(ION,ID)=ABSOTI(ION,ID)+ABSOFF EMISTI(ION,ID)=EMISTI(ION,ID)+ABSOFF END DO C C H minus free-free opacity C ELSE IF(IT.EQ.3) THEN DO ID=1,ND ABSOFF=SFFHMI(POPUL(NFIRST(IELH),ID),FR,TEMP(ID))* * ELEC(ID) ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF ABSOTI(ION,ID)=ABSOTI(ION,ID)+ABSOFF EMISTI(ION,ID)=EMISTI(ION,ID)+ABSOFF END DO C C special evaluation of the cross-section C ELSE IF(IT.LT.0) THEN DO ID=1,ND ABSOFF=FFCROS(ION,IT,TEMP(ID),FR)* * POPUL(NNEXT(ION),ID)*ELEC(ID) ABSO1(ID)=ABSO1(ID)+ABSOFF EMIS1(ID)=EMIS1(ID)+ABSOFF ABSOTI(ION,ID)=ABSOTI(ION,ID)+ABSOFF EMISTI(ION,ID)=EMISTI(ION,ID)+ABSOFF END DO END IF 40 CONTINUE END DO C C ******** 3. - additional continuum opacity (OPADD) C IF(IOPADD.NE.0) THEN ICALL=1 DO ID=1,ND CALL OPADD(0,ICALL,IJ,ID) ABSO1(ID)=ABSO1(ID)+ABAD EMIS1(ID)=EMIS1(ID)+EMAD SCAT1(ID)=SCAT1(ID)+SCAD ABSOTI(IELH,ID)=ABSOTI(IELH,ID)+ABAD EMISTI(IELH,ID)=EMISTI(IELH,ID)+EMAD END DO END IF C DO ID=1,ND ABSOC1(ID)=ABSO1(ID) EMISC1(ID)=EMIS1(ID) END DO IF(ICOOLP.EQ.0) GO TO 500 C C ******** 4. - opacity and emissivity in lines C IF(ISPODF.EQ.0) THEN IF(IJLIN(IJ).GT.0) THEN C C the "primary" line at the given frequency C ITR=IJLIN(IJ) iad=iadop(iatm(ilow(itr))) if(iad.eq.0.or.(lfre.and.iad.gt.0)) then ION=IEL(ILOW(ITR)) DO ID=1,ND SG=PRFLIN(ID,IJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) ABSOTI(ION,ID)=ABSOTI(ION,ID)+SG*ABTRA(ITR,ID) EMISTI(ION,ID)=EMISTI(ION,ID)+SG*EMTRA(ITR,ID) END DO end if ENDIF IF(NLINES(IJ).LE.0) GO TO 200 C C the "overlapping" lines at the given frequency C DO 100 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 100 if(linexp(itr)) goto 100 IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 70 END IF END DO 70 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 ION=IEL(ILOW(ITR)) DO ID=1,ND SG=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) ABSOTI(ION,ID)=ABSOTI(ION,ID)+SG*ABTRA(ITR,ID) EMISTI(ION,ID)=EMISTI(ION,ID)+SG*EMTRA(ITR,ID) END DO 100 CONTINUE 200 CONTINUE C C Opacity sampling option C ELSE IF(NLINES(IJ).LE.0) GO TO 400 DO 300 ILINT=1,NLINES(IJ) ITR=ITRLIN(ILINT,IJ) iad=iadop(iatm(ilow(itr))) if(iad.gt.0.and..not.lfre) go to 300 ION=IEL(ILOW(ITR)) KJ=IJ-IFR0(ITR)+KFR0(ITR) INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN DO ID=1,ND SG=PRFLIN(ID,KJ) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) ABSOTI(ION,ID)=ABSOTI(ION,ID)+SG*ABTRA(ITR,ID) EMISTI(ION,ID)=EMISTI(ION,ID)+SG*EMTRA(ITR,ID) END DO ELSE DO ID=1,ND KJD=JIDI(ID) SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+(UN-XJID(ID))* * SIGFE(KJD+1,KJ)) ABSO1(ID)=ABSO1(ID)+SG*ABTRA(ITR,ID) EMIS1(ID)=EMIS1(ID)+SG*EMTRA(ITR,ID) ABSOTI(ION,ID)=ABSOTI(ION,ID)+SG*ABTRA(ITR,ID) EMISTI(ION,ID)=EMISTI(ION,ID)+SG*EMTRA(ITR,ID) END DO END IF 300 CONTINUE 400 CONTINUE ENDIF 500 CONTINUE C C ---------------------------- C total opacity and emissivity C ---------------------------- C DO ID=1,ND ABSO1(ID)=ABSO1(ID)-EMIS1(ID)*XKF(ID) ABSOC1(ID)=ABSOC1(ID)-EMISC1(ID)*XKF(ID) DO ION=1,NION ABSOTI(ION,ID)=ABSOTI(ION,ID)-EMISTI(ION,ID)*XKF(ID) END DO EMIS1(ID)=EMIS1(ID)*XKFB(ID) EMISC1(ID)=EMISC1(ID)*XKFB(ID) DO ION=1,NION EMISTI(ION,ID)=EMISTI(ION,ID)*XKFB(ID) END DO absot(id)=abso1(id) END DO if(izscal.eq.0) then do id=1,nd absot(id)=abso1(id)*dens1(id) end do end if c if(ifprd.gt.0) call prd(ij) c RETURN END C C C **************************************************************** C C SUBROUTINE VISINI C ================= C C Auxiliary procedure for RESOLV C initialization of necessary quantities for treating the viscosity C in disks C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' C AMUV0=DMVISC**(ZETA0+UN) AMUV1=UN-AMUV0 GP=0. GN=UN IF(INMP.GT.0) THEN GP=UN GN=0. END IF C IF(IVISC.LE.1) THEN x=0. DO ID=1,ND DMD=DM(1) IF(ID.GT.1) DMD=(DM(ID)+DM(ID-1))*HALF IF(DM(ID).LE.DMVISC*DM(ND)) THEN VISCD(ID)=(UN-FRACTV)*(ZETA1+UN)/ * DMVISC**(ZETA1+UN)*(DM(ID)/DM(ND))**ZETA1 THETAV(ID)=(UN-FRACTV)*(DMD/DMVISC/DM(ND))**(ZETA1+UN) ELSE VISCD(ID)=FRACTV*(ZETA0+UN)/AMUV1* * (DM(ID)/DM(ND))**ZETA0 THETAV(ID)=(UN-FRACTV)+FRACTV*((DMD/DM(ND))**(ZETA0+UN)- * AMUV0)/AMUV1 END IF TVISC(ID)=EDISC*VISCD(ID)*DENS(ID) DTVIST(ID)=0. DTVISR(ID)=EDISC*VISCD(ID)*WMM(ID) DTVISN(ID)=0. if(id.gt.1) then X=X+HALF*(TVISC(ID)/DENS(ID)+TVISC(ID-1)/DENS(ID-1))* * (DM(ID)-DM(ID-1)) end if END DO vtot=x x=0. if(iter.eq.niter) write(6,600) do id=1,nd AN=DENS(ID)/WMM(ID)+ELEC(ID) PGS(ID)=BOLK*TEMP(ID)*AN if(id.gt.1) then X=X+HALF*(TVISC(ID)/DENS(ID)+TVISC(ID-1)/DENS(ID-1))* * (DM(ID)-DM(ID-1)) end if alp=tvisc(id)/omeg32/pgs(id)*12.5664 if(iter.eq.niter) * write(6,601) id,dm(id),tvisc(id),thetav(id),x/vtot, * viscd(id),alp write(96,601) id,dm(id),tvisc(id),thetav(id),x/vtot, * viscd(id),alp if(id.eq.nd) * write(96,601) id,edisc,viscd(id),dens(id),pgs(id),omeg32 end do 601 format(i5,1p6e12.4) ELSE IF(IVISC.EQ.2) THEN X=0. THETAV(1)=0. DO ID=1,ND AN=DENS(ID)/WMM(ID)+ELEC(ID) PGS(ID)=BOLK*TEMP(ID)*AN TVISC(ID)=OMEG32*ALPHAV*PGS(ID)/12.5664 DTVIST(ID)=TVISC(ID)/TEMP(ID) DTVISN(ID)=TVISC(ID)/AN DTVISR(ID)=0. if(id.gt.1) then c X=X+HALF*(TVISC(ID)+TVISC(ID-1))*(DM(ID)-DM(ID-1)) X=X+HALF*(TVISC(ID)/DENS(ID)+TVISC(ID-1)/DENS(ID-1))* * (DM(ID)-DM(ID-1)) end if END DO VTOT=X X=0. write(6,602) 600 format(/' ID DM TVISC THETAV(orig) THETAV', * ' VISCD ALPHA'/) 602 format(/' ID DM TVISC THETAV PGAS', * ' VISCD ALPHA'/) DO ID=1,ND if(id.gt.1) then c X=X+HALF*(TVISC(ID)+TVISC(ID-1))*(DM(ID)-DM(ID-1)) X=X+HALF*(TVISC(ID)/DENS(ID)+TVISC(ID-1)/DENS(ID-1))* * (DM(ID)-DM(ID-1)) end if THETAV(ID)=X/VTOT viscd(id)=tvisc(id)/dens(id)/edisc write(6,601) id,dm(id),tvisc(id),thetav(id),pgs(id), * viscd(id),alphav write(96,601) id,dm(id),tvisc(id),thetav(id),pgs(id), * viscd(id),alphav if(id.eq.nd) * write(96,601) id,edisc,viscd(id),dens(id),pgs(id),omeg32 END DO END IF RETURN END C C C **************************************************************** C C SUBROUTINE DMEVAL C ================= C C Auxiliary procedure for RESOLV - for disks C recomputation of the m-scale in the case where z-scale is the C basic scale C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'ARRAY1.FOR' dimension dma(mdepth),dmb(mdepth) C C total pressure and gas pressure C DO ID=1,ND PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID) PGS0=(DENS(ID)/WMM(ID)+ELEC(ID))*BOLK*TEMP(ID) PGS(ID)=PGS0 PTOTL0=PGS(ID)+PRADT(ID)+PTURB PTOTAL(ID)=PTOTL0 END DO c C mass at the first depth point C ID=1 GRD=0. DO IJ=1,NFREQE IJT=IJFR(IJ) FLUXW=W(IJT)*FH(IJT)*RADEX(IJ,ID) GRD=GRD+FLUXW*ABSOEX(IJ,ID) END DO HG1=SQRT(TWO*PGS(1)/DENS(1)/QGRAV) HR1=PCK/QGRAV*(GRD+FPRD(1))/DENS(1) if(iter.eq.1) pgas0=pgs(1) X=(ZD(1)-HR1)/HG1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1=HALF*(UN-HALF/X/X)/X END IF C DMa(1)=HG1*DENS(1)*F1 DMb(1)=DMa(1) c c recompute the DM scale C write(6,600) 600 format(/' ID ZD DM(old) DMA DMB'/) DO ID=1,ND if(id.gt.1) then dmb(id)=dm(id) DMA(ID)=DMA(ID-1)-(ZD(ID)-ZD(ID-1))*TWO/ * (UN/DENS(ID)+UN/DENS(ID-1)) DMb(ID)=DMb(ID-1)-(ZD(ID)-ZD(ID-1))* * (DENS(ID)+DENS(ID-1))*half end if write(6,601) id,zd(id),dm(id),dma(id),dmb(id) c DM(ID)=DMB(ID) DM(ID)=DMa(ID) 601 format(i5,1p4e12.4) END DO DMTOT=DM(ND) EDISC=SIG4P*TEFF**4/DMTOT RETURN END C C C **************************************************************** C C SUBROUTINE GREYD C ================ C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'ALIPAR.FOR' PARAMETER (ERRM0=1.E-3, NTRM=50) C CHI0=20. IF(TEFF.GT.10000.) THEN XION=2. ELSE IF(TEFF.LT.6000.) THEN XION=1. ELSE XION=1.+(TEFF-6000.)/4000. END IF ANEREL=1.-1./XION C DMP=0. ID=1 C1=BOLK*XION/WMM(ID) C2=3.1415926/2./QGRAV C3=SQRT(C1*C2) C4=WBARM*OMEG32/ALPHAV C5=C4/C1 C6=C1/WBARM/OMEG32 C ITRM=0 10 CONTINUE ITRM=ITRM+1 C1=BOLK*XION/WMM(ID) C3=SQRT(C1*C2) C5=C4/C1 T=(0.375*TEFF**4*CHI0*C5)**0.2 DM0=C5/T RHO=DM0/SQRT(T)/C3 TEMP(ID)=T DENS(ID)=RHO CALL RHONEN(ID,T,RHO,AN,ANE) ELEC(ID)=ANE XION=AN/(AN-ANE) CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) C C evaluation of the Rosseland and Planck mean opacities C for the new values of temperature, electron density, and C populations (OPROS - Rosseland opacity per 1 cm**3; OPPLA - Planck C mean opacity per 1 cm**3) C CALL OPACF0(ID,NFREQ) CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA) ABROS=OPROS/DENS(ID) ABPLA=OPPLA/DENS(ID) if(abpla.lt.abpmin) abpla=abpmin CHI0=(ABROS+chi0)/2. WRITE(6,601) ITRM,T,DM0,RHO,CHI0,abros,CHI0*DM0,XION,ANE 601 FORMAT(i5,1p8e9.2) ERRM=ABS(DM0-DMP)/DM0 DMP=DM0 IF(ERRM.GT.ERRM0.AND.ITRM.LT.NTRM) GO TO 10 C DMTOT=DM0 RETURN END C C C **************************************************************** C C subroutine rhonen(id,t,rho,an,ane) c ================================== c c iterative determination of N and Ne from given T and RHO C C Input: T - temperature C RHO - mass density C Output: AN - total particle density C ANE - elctron density C ENRG- internal energy C ENTT- entropy c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C it=0 if(id.eq.1.and.anerel.eq.0.) then anerel=0.5 if(t.lt.9000.) anerel=0.4 if(t.lt.8000.) anerel=0.1 if(t.lt.7000.) anerel=0.01 if(t.lt.6000.) anerel=0.001 if(t.lt.5500.) anerel=0.0001 if(t.lt.5000.) anerel=1.e-5 if(t.lt.4000.) anerel=1.e-6 end if wm=wmm(id)*(un-anerel)/hmass wm0=wm 10 continue it=it+1 an=rho/wm/hmass ane0=anerel*an wm0=wm call eldens(id,t,an,ane,enrgi,entt,wm,0) anerel=ane/an if(abs((ane-ane0)/ane0).lt.1.e-5.and. * abs((wm-wm0)/wm0).lt.1.e-5) go to 20 if(it.lt.30) go to 10 20 continue return end c C C C ************************************************************** C C subroutine quasim(ij) c ===================== c c quasi-molecular opacity for Lyman alpha, beta, gamma c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal dimension sgd(mdepth) c if(iquasi.le.0) return fr=freq(ij) wlam=2.997925e18/fr if(wlam.lt.911..or.wlam.gt.1727.) return ii=nfirst(ielh) c do jup=2,iquasi+1 jj=ii+1 itr=itra(ii,jj) do id=1,nd anp=popul(nnext(ielh),id) t=temp(id) if(tqmprf.gt.0.) t=tqmprf call allard(wlam,t,popul(ii,id),anp,sg,1,jup) sgd(id)=sg end do if(ijlin(ij).ne.itr) then sg0=0. do ilint=1,nlines(ij) itt=itrlin(ilint,ij) if(itt.eq.itr) then IJ0=IFR0(ITR) DO IJT=IJ0,IFR1(ITR) IF(FREQ(IJT).LE.FR) THEN IJ0=IJT GO TO 20 END IF END DO 20 IJ1=IJ0-1 A1=(FR-FREQ(IJ0))/(FREQ(IJ1)-FREQ(IJ0)) A2=UN-A1 do id=1,nd SG0=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0) end do end if end do end if do id=1,nd abso1(id)=abso1(id)+sgd(id)*abtra(itr,id) emis1(id)=emis1(id)+sgd(id)*emtra(itr,id) end do end do c return end C C C ******************************************************************** C 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 INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (NXMAX=1400,NNMAX=5,NTAMAX=6) common/quasun/tqmprf,iquasi,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 common /calphatd/xlalpd(NXMAX,NTAMAX),plalpd(NXMAX,NNMAX,NTAMAX), * stnead(ntamax),stnchd(ntamax), * vneuad(ntamax),vchaad(ntamax), * talpd(ntamax),nxalpd(ntamax),ntalpd c c Lyman alpha c nxalp=0 nunalp=67 if(nunalp.gt.0) then 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 else if(nunalp.lt.0) then c c input of temperature-dependent profile c nualp=-nunalp read(nualp,*) ntalpd do it=1,ntalpd read(nualp,*) talpd(it) read(nualp,*) nxalpd(it),stnead(it),stnchd(it),vneuad(it), * vchaad(it) do i=1,nxalpd(it) read(nualp,*) xlalpd(i,it),(plalpd(i,j,it),j=1,NNMAX) end do stnead(it)=10.0**stnead(it) stnchd(it)=10.0**stnchd(it) end do close(nualp) 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 end if c c Lyman gamma c nxgam=0 if(nungam.gt.0) then nungam=67 open(unit=nungam,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 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 end if return end c C C C ******************************************************************** C C subroutine allard(xl,t,hneutr,hcharg,prof,iq,jq) c ================================================ c c quasi-molecular opacity for Lyman alpha, beta, and Balmer alpha c modified routine provided originally by D. Koester c c Input: xl: wavelength in [A] c hneutr: neutral H particle density [cm-3] c hcharg: ionized H particle density [cm-3] c iq: quantum number of the lower level c jq: quantum number of the upper level; c =2 - Lyman alpha c =3 - Lyman beta c Output: prof: Lyman alpha line profile, normalized to 1.0e8 c if integrated over A; c It then renormalized by multiplying by c 8.853e-29*lambda_0^2*f_ij c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (NXMAX=1400,NNMAX=5,NTAMAX=6) parameter (xnorma=8.8528e-29*1215.6*1215.6*0.41618, * xnormb=8.8528e-29*1025.73*1025.7*0.0791, * xnormg=8.8528e-29*972.53*972.53*0.0290, * xnormc=8.8528e-29*6562.*6562.*0.6407) common /callarda/xlalp(NXMAX),plalp(NXMAX,NNMAX),stnnea,stncha, * vneua,vchaa,nxalp,iwarna common /callardb/xlbet(NXMAX),plbet(NXMAX,NNMAX),stnneb,stnchb, * vneub,vchab,nxbet,iwarnb common /callardg/xlgam(NXMAX),plgam(NXMAX,NNMAX),stnneg,stnchg, * vneug,vchag,nxgam,iwarng common /callardc/xlbal(NXMAX),plbal(NXMAX,NNMAX),stnnec,stnchc, * vneuc,vchac,nxbal,iwarnc common /calphatd/xlalpd(NXMAX,NTAMAX),plalpd(NXMAX,NNMAX,NTAMAX), * stnead(ntamax),stnchd(ntamax), * vneuad(ntamax),vchaad(ntamax), * talpd(ntamax),nxalpd(ntamax),ntalpd common/quasun/tqmprf,iquasi,nunalp,nunbet,nungam,nunbal c prof=0. c c Lyman alpha c if(iq.eq.1.and.jq.eq.2) then if(nunalp.lt.0) then call allardt(xl,t,hneutr,hcharg,prof) else if(xl.lt.xlalp(1).or.xl.gt.xlalp(nxalp)) return vn1=hneutr/stnnea vn2=hcharg/stncha vns=vn1*vneua+vn2*vchaa if(iwarna.eq.0) then if(vn1*vneua.gt.0.3.or.vn2*vchaa.gt.0.3) then write(*,*) ' warning: density too high for', * ' Lyman alpha expansion' iwarna=1 endif endif vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) c jl=0 ju=nxalp+1 10 if(ju-jl.gt.1) then jm=(ju+jl)/2 if((xlalp(nxalp).gt.xlalp(1)).eqv.(xl.gt.xlalp(jm))) then jl=jm else ju=jm endif go to 10 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxalp) j=j-1 a1=(xl-xlalp(j))/(xlalp(j+1)-xlalp(j)) p1= vn1*((1.0-a1)*plalp(j,1)+a1*plalp(j+1,1)) p11=vn11*((1.0-a1)*plalp(j,2)+a1*plalp(j+1,2)) p2= vn2*((1.0-a1)*plalp(j,3)+a1*plalp(j+1,3)) p22=vn22*((1.0-a1)*plalp(j,4)+a1*plalp(j+1,4)) p12=vn12*((1.0-a1)*plalp(j,5)+a1*plalp(j+1,5)) prof=(p1+p2+p11+p22+p12)*xnorm*xnorma return end if end if c c Lyman beta c if(iq.eq.1.and.jq.eq.3) then if(nxbet.eq.0) return if(xl.lt.xlbet(1).or.xl.gt.xlbet(nxbet)) return vn1=hneutr/stnneb vn2=hcharg/stnchb vns=vn1*vneub+vn2*vchab if(iwarnb.eq.0) then if(vn1*vneub.gt.0.3.or.vn2*vchab.gt.0.3) then write(*,*) ' warning: density too high for', * ' Lyman beta expansion' iwarnb=1 endif endif vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) c jl=0 ju=nxbet+1 20 if(ju-jl.gt.1) then jm=(ju+jl)/2 if((xlbet(nxbet).gt.xlbet(1)).eqv.(xl.gt.xlbet(jm))) then jl=jm else ju=jm endif go to 20 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxbet) j=j-1 a1=(xl-xlbet(j))/(xlbet(j+1)-xlbet(j)) p1= vn1*((1.0-a1)*plbet(j,1)+a1*plbet(j+1,1)) p11=vn11*((1.0-a1)*plbet(j,2)+a1*plbet(j+1,2)) p2= vn2*((1.0-a1)*plbet(j,3)+a1*plbet(j+1,3)) p22=vn22*((1.0-a1)*plbet(j,4)+a1*plbet(j+1,4)) p12=vn12*((1.0-a1)*plbet(j,5)+a1*plbet(j+1,5)) prof=(p1+p2+p11+p22+p12)*xnorm*xnormb return end if c c Lyman gamma c if(iq.eq.1.and.jq.eq.4) then if(nxgam.eq.0) return if(xl.lt.xlgam(1).or.xl.gt.xlgam(nxgam)) return vn1=hneutr/stnneg vn2=hcharg/stnchg vns=vn1*vneug+vn2*vchag if(iwarng.eq.0) then if(vn1*vneug.gt.0.3.or.vn2*vchag.gt.0.3) then write(*,*) ' warning: density too high for', * ' Lyman gamma expansion' iwarng=1 endif endif vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) c jl=0 ju=nxgam+1 30 if(ju-jl.gt.1) then jm=(ju+jl)/2 if((xlgam(nxgam).gt.xlgam(1)).eqv.(xl.gt.xlgam(jm))) then jl=jm else ju=jm endif go to 30 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxgam) j=j-1 a1=(xl-xlgam(j))/(xlgam(j+1)-xlgam(j)) p1= vn1*((1.0-a1)*plgam(j,1)+a1*plgam(j+1,1)) p11=vn11*((1.0-a1)*plgam(j,2)+a1*plgam(j+1,2)) p2= vn2*((1.0-a1)*plgam(j,3)+a1*plgam(j+1,3)) p22=vn22*((1.0-a1)*plgam(j,4)+a1*plgam(j+1,4)) p12=vn12*((1.0-a1)*plgam(j,5)+a1*plgam(j+1,5)) prof=(p1+p2+p11+p22+p12)*xnorm*xnormg return end if c c Balmer alpha c if(iq.eq.2.and.jq.eq.3) then if(xl.lt.xlbal(1).or.xl.gt.xlbal(nxbal)) return vn1=0. vn2=hcharg/stnchc vns=vn1*vneuc+vn2*vchac vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) c jl=0 ju=nxbal+1 40 if(ju-jl.gt.1) then jm=(ju+jl)/2 if((xlbal(nxbal).gt.xlbal(1)).eqv.(xl.gt.xlbal(jm))) then jl=jm else ju=jm endif go to 40 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxbal) j=j-1 a1=(xl-xlbal(j))/(xlbal(j+1)-xlbal(j)) p1= vn1*((1.0-a1)*plbal(j,1)+a1*plbal(j+1,1)) p11=vn11*((1.0-a1)*plbal(j,2)+a1*plbal(j+1,2)) p2= vn2*((1.0-a1)*plbal(j,3)+a1*plbal(j+1,3)) p22=vn22*((1.0-a1)*plbal(j,4)+a1*plbal(j+1,4)) p12=vn12*((1.0-a1)*plbal(j,5)+a1*plbal(j+1,5)) prof=(p1+p2+p11+p22+p12)*xnorm*xnormc end if c return end C C C ******************************************************************** C C subroutine allardt(xl,t,hneutr,hcharg,prof) c =========================================== c c quasi-molecular opacity for Lyman alpha, with T-dependent c profile c c Input: xl: wavelength in [A] c hneutr: neutral H particle density [cm-3] c hcharg: ionized H particle density [cm-3] c Output: prof: Lyman alpha line profile, normalized to 1.0e8 c if integrated over A; c It then renormalized by multiplying by c 8.853e-29*lambda_0^2*f_ij c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' parameter (NXMAX=1400,NNMAX=5,NTAMAX=6) parameter (xnorma=8.8528e-29*1215.6*1215.6*0.41618) common /calphatd/xlalpd(NXMAX,NTAMAX),plalpd(NXMAX,NNMAX,NTAMAX), * stnead(ntamax),stnchd(ntamax), * vneuad(ntamax),vchaad(ntamax), * talpd(ntamax),nxalpd(ntamax),ntalpd c prof=0. c c find the two partial tables close to actual T c it0=0 do it=1,ntalpd it0=it if(t.lt.talpd(it)) then it0=it-1 go to 10 end if end do 10 continue if(it0.eq.0) then it0=1 go to 20 end if if(it0.ge.ntalpd) then it0=ntalpd go to 20 end if go to 30 20 continue c if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return vn1=hneutr/stnead(it0) vn2=hcharg/stnchd(it0) vns=vn1*vneuad(it0)+vn2*vchaad(it0) vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) c jl=0 ju=nxalpd(it0)+1 110 if(ju-jl.gt.1) then jm=(ju+jl)/2 if(xl.gt.xlalpd(jm,it0)) then jl=jm else ju=jm endif go to 110 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxalpd(it0)) j=j-1 a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0)) p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0)) p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0)) p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0)) p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0)) p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0)) prof=(p1+p2+p11+p22+p12)*xnorm*xnorma return c 30 continue c c interpolate in the tables for different T c c the lower T c if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return vn1=hneutr/stnead(it0) vn2=hcharg/stnchd(it0) vns=vn1*vneuad(it0)+vn2*vchaad(it0) vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) jl=0 ju=nxalpd(it0)+1 120 if(ju-jl.gt.1) then jm=(ju+jl)/2 if(xl.gt.xlalpd(jm,it0)) then jl=jm else ju=jm endif go to 120 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxalpd(it0)) j=j-1 a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0)) p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0)) p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0)) p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0)) p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0)) p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0)) prof0=(p1+p2+p11+p22+p12)*xnorm*xnorma c c the higher T c it0=it0+1 if(xl.lt.xlalpd(1,it0).or.xl.gt.xlalpd(nxalpd(it0),it0)) return vn1=hneutr/stnead(it0) vn2=hcharg/stnchd(it0) vns=vn1*vneuad(it0)+vn2*vchaad(it0) vn11=vn1*vn1 vn22=vn2*vn2 vn12=vn1*vn2 xnorm=1.0/(1.0+vns+0.5*vns*vns) jl=0 ju=nxalpd(it0)+1 130 if(ju-jl.gt.1) then jm=(ju+jl)/2 if(xl.gt.xlalpd(jm,it0)) then jl=jm else ju=jm endif go to 130 endif j=jl c if(j.eq.0) j=1 if(j.eq.nxalpd(it0)) j=j-1 a1=(xl-xlalpd(j,it0))/(xlalpd(j+1,it0)-xlalpd(j,it0)) p1= vn1*((1.0-a1)*plalpd(j,1,it0)+a1*plalpd(j+1,1,it0)) p11=vn11*((1.0-a1)*plalpd(j,2,it0)+a1*plalpd(j+1,2,it0)) p2= vn2*((1.0-a1)*plalpd(j,3,it0)+a1*plalpd(j+1,3,it0)) p22=vn22*((1.0-a1)*plalpd(j,4,it0)+a1*plalpd(j+1,4,it0)) p12=vn12*((1.0-a1)*plalpd(j,5,it0)+a1*plalpd(j+1,5,it0)) prof1=(p1+p2+p11+p22+p12)*xnorm*xnorma c c final profile coefficient c dt=talpd(it0)-talpd(it0-1) prof=(prof0*(talpd(it0)-t)+prof1*(t-talpd(it0-1)))/dt c return end C C C ************************************************************** C C subroutine hedif c ================ c c subroutine to calculate the depth dependent abundance profile for c a layered H+He atmosphere. c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' common/hediff/ hcmass,radstr c real depth(mdepth+1),qs(mdepth+1), dimension depth(mdepth+1),qs(mdepth+1), * ps(mdepth+1),gams(mdepth+1), * abunds(mdepth+1),hms(mdepth+1) c data smas,srad /1.9891e33,6.9599e10/ data z1,z2,a1,a2 /1.,2.,1.,4./ data bigg,pi / 6.6732e-8,3.141592654/ c c Set up starting values c do id=1,nd depth(id+1)=dm(id) end do if(radstr.lt.1.e3) radius=radstr*srad if(hcmass.gt.1.e-10) hcmass=hcmass*1.e-13 c gam=1.e-30 gams(1)=1.e-30 c 10 continue depth(1)=1.e-10 q1=(depth(1)*4*pi*radius**2/smas) p1=(q1*grav**2/(4*pi*bigg)) ps(1)=p1 qs(1)=q1 hms(1)=0 abunds(1)=0.0 dpsl=-6 hm=0.0 do i=2,nd+1,1 q2=(depth(i)*4*pi*radius**2/smas) p2=(q2*grav**2/(4*pi*bigg)) dp=p2-p1 dlp=log(p2)-log(p1) gam=gam+raph(gam,z1,z2,a1,a2)*dlp abun0=gam hm=hm+(q2-q1)/((1+gam*a2/a1)) p1=p2 ps(i)=p2 qs(i)=q2 gams(i)=gam abunds(i)=abun0 hms(i)=hm end do c dh1=(log10(hcmass)-log10(hms(nd+1))) dh=hcmass/hms(nd+1) if(dh.ge.0.99) go to 20 gam=gams(1)*1.1 gams(1)=gam hm=0.0 go to 10 c c Now work backwards to get the full profiles c 20 continue q1=(depth(nd+1)*4*pi*radius**2/smas) p1=(q1*grav**2/(4*pi*bigg)) c c store new helium abundance and corresponding new YTOT, MMY, WMM c write(6,600) do id=1,nd aheold=0. ahenew=abunds(id+1) if(iathe.gt.0) then aheold=abund(iathe,id) abund(iathe,id)=ahenew end if ytot(id)=ytot(id)-aheold+ahenew wmy(id)=wmy(id)+(ahenew-aheold)*4.003 wmm(id)=wmy(id)*hmass/ytot(id) write(6,601) id,aheold,ahenew,ytot(id),wmy(id),wmm(id) end do 600 format(' stratified helium abundance'/ *' id He(old) He(new) ytot wmm wmy'/) 601 format(i4,1p5e11.3) c return end C C C **************************************************************** C C function raph(gam,z1,z2,a1,a2) c ============================== c c auxiliary function for subroutine hedif c INCLUDE 'IMPLIC.FOR' c b=1+gam c=z1+z2*gam d=a1+a2*gam e=(1+z1)+gam*(1+z2) den=(c*d/(gam*b))+(d*(z1-z2)**2/(b*e)) dnum=e*(a2*z1-a1*z2)+d*(z2-z1) dgam=dnum/den raph=dgam return end C C C **************************************************************** C C SUBROUTINE TABINI 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 rhomat: 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' parameter (mtabto=100,mtabro=100) common/intcff/yint(mfreq),jint(mfreq) common/abntab/abunt(matom),abuno(matom),tmolit, * iophmt,ioph2t,iophet,iopcht,iopoht, * ioh2mt,ih2h2t,ih2het,ioh2ht,iohhet, * ifmolt common/eletab/elecgr(mtabt,mtabr) CHARACTER(len=100) :: DUM c real*4 absopa0 dimension frlt(mfrtab) dimension absopa0(mtabto,mtabro),indt(mtabto),indr(mtabro) dimension tempve0(100),rhove0(100,100), * elecg0(100,100) dimension rhov(mtabr),nden(mtabt) dimension typa(matom) character*(80) optable character*4 typa c istept=1 istepr=1 istepf=1 c read(15,*,err=10,end=10) optable,ibinop go to 20 10 optable='./data/absopac.dat' 20 if(ibinop.eq.0) then open(53,file=optable,status='old') else open(53,file=optable,form='unformatted',status='old') end if c read(15,*,err=30,end=30) istept,istepr,istepf 30 continue c write(6,601) optable,ibinop 601 format(/' ' * /' OPACITY TABLE: READ FROM THE FILE ',a70/' IBINOP=',i2/ * ' --------------'/) if(istept.gt.1.or.istepr.gt.1.or.istepf.gt.1) then write(6,*) ' BUT ONLY SELECTED DATA USED' write(6,*) end if c c reading the opacity table in the old mode c if(ioptab.lt.0.and.iopold.gt.0) then if(ibinop.eq.0) then read(53,*) numfre0,numtem0,numrh0 read(53,*) read(53,*) (tempve0(i),i=1,numtem0) read(53,*) read(53,*) (rhove0(1,j),j=1,numrh0) else read(53) numfre0,numtem0,numrh0 read(53) (tempve0(i),i=1,numtem0) read(53) (rhove0(1,j),j=1,numrh0) end if c c reading the opacity table in the new mode c else io2hmt=0 ih2h2t=0 ih2het=0 ioh2ht=0 iohhet=0 if(ibinop.eq.0) then read(53,*) read(53,*) do iat=1,matom read(53,'(a100)') dum read(dum,*,iostat=kst) typa(iat),abunt(iat),abuno(iat) if(kst.ne.0) go to 40 end do read(53,*) 40 continue read(53,*) read(53,*) ifmolt,tmolit read(53,*) read(53,*) read(53,'(a100)') dum read(dum,*,iostat=kst) iophmt,ioph2t,iophet,iopcht,iopoht, * ioh2mt,ih2h2t,ih2het,ioh2ht,iohhet if(kst.ne.0) read(dum,*) iophmt,ioph2t,iophet,iopcht,iopoht read(53,*) read(53,*) read(53,*) numfre0,numtem0,numrh0 if(numrh0.gt.0) then read(53,*) read(53,*) (tempve0(i),i=1,numtem0) read(53,*) read(53,*) (rhov(j),j=1,numrh0) nden(1)=numrh0 do j=1,numrh0 do i=1,numtem0 rhove0(i,j)=rhov(j) end do end do do i=1,numtem0 nden(i)=nden(1) end do read(53,*) read(53,*) ((elecg0(i,j),j=1,numrh0),i=1,numtem0) else read(53,*) (nden(i),i=1,numtem0) read(53,*) read(53,*) (tempve0(i),i=1,numtem0) read(53,*) do i=1,numtem0 read(53,*) (rhove0(i,j),j=1,nden(i)) end do read(53,*) do i=1,numtem0 read(53,*) (elecg0(i,j),j=1,nden(i)) end do end if else do iat=1,92 read(53) typa(iat),abunt(iat),abuno(iat) end do read(53) ifmolt,tmolit read(53) iophmt,ioph2t,iophet,iopcht,iopoht, * ioh2mt,ih2h2t,ih2het,ioh2ht,iohhet read(53) numfre0,numtem0,numrh0 if(numrh0.gt.0) then read(53) (tempve0(i),i=1,numtem0) read(53) (rhov(j),j=1,numrh0) read(53) ((elecg0(i,j),j=1,numrh0),i=1,numtem0) nden(1)=numrh0 do j=1,numrh0 do i=1,numtem0 rhove0(i,j)=rhov(j) end do end do do i=1,numtem0 nden(i)=nden(1) end do else read(53) (nden(i),i=1,numtem0) read(53) (tempve0(i),i=1,numtem0) do i=1,numtem0 read(53) (rhove0(i,j),j=1,nden(i)) end do do i=1,numtem0 read(53) (elecg0(i,j),j=1,nden(i)) end do end if end if c end if c C select only a part of tabular data (if required) C j=0 nrmax=0. do it=1,numtem0,istept j=j+1 tempvec(j)=tempve0(it) indt(j)=it k=0. numr=nden(it) nrmax=max(nrmax,numr) do ir=1,numr,istepr k=k+1 rhomat(j,k)=rhove0(it,ir) indr(k)=ir elecgr(j,k)=elecg0(it,ir) end do numrh(j)=k end do numtemp=j if(numrh0.gt.0) numrho=k if(numtemp.gt.mtabt) then write(*,*) 'number of temperatures in opac.table too large' write(*,*) 'numtemp,mtabt = ',numtemp,mtabt write(*,*) 'recompile with MTABT.ge.NUMTEMP in BASICS.FOR' stop end if c if(nrmax.gt.mtabr) then write(*,*) 'number of densities in opac,table too large' write(*,*) 'numrho,mtabr = ',numtemp,mtabr write(*,*) 'recompile with MTABR.ge.NUMRHO in BASICS.FOR' stop end if c ij=0 do k=1,numfre0 if(mod(k,istepf).eq.0) ij=ij+1 end do numfreq=ij if(numfreq.gt.mfreqc) then write(*,*) 'number of wavelengths in opac.table too large' write(*,*) 'numfreq,mfreqc = ',numfreq,mfreqc write(*,*) 'recompile with MFREQC.ge.NUMFREQ in BASICS.FOR' stop end if c write(6,602) numfre0,numtem0,numrh0 602 format(' original number of frequencies, temperatures', * ' densities: ',3i7/) C if(istept.gt.1.or.istepr.gt.1.or.istepf.gt.1) * write(6,603) numfreq,numtemp,numrho 603 format(' modified number of frequencies, temperatures', * ' densities: ',3i7/) C write(*,*) 'temperatures:' write(6,604) (exp(tempvec(i)),i=1,numtemp) write(*,*) 'densities:' do i=1,numtemp numr=numrh(i) write(6,605) exp(tempvec(i)),(exp(rhomat(i,j)),j=1,numr) end do 604 format(10f8.1) 605 format('for T=',f7.1,(1p10e10.2)) c c check the consistency (or a lack thereof) the parameters of c the opacity table c c if(ioptab.gt.0.or.iopold.eq.0) call chctab c RTAB1 = rhomat(1,1) RTAB2 = rhomat(1,numrho) TTAB1 = tempvec(1) TTAB2 = tempvec(numtemp) c if(ibinop.eq.0) then ij=0 nden0=numrh0 do k=1,numfre0 read(53,*) read(53,*) read(53,*) frta if(numrh0.gt.0) then do j = 1, numrh0 read(53,*) (absopa0(i,j),i=1,numtem0) end do else do i=1,numtem0 nden0=nden(i) read(53,*) (absopa0(i,j),j=1,nden0) end do end if if(mod(k,istepf).eq.0.and.frta.lt.frtlim) then ij=ij+1 frtab(ij)=frta frlt(ij)=log10(frta) do i=1,numtemp numr=numrh(i) do j=1,numr absopac(i,j,ij)=absopa0(indt(i),indr(j)) end do end do end if end do numfreq=ij close(53) else ij=0 do k=1,numfre0 read(53) frta if(numrh0.gt.0) then do j = 1, numrh0 read(53) (absopa0(i,j),i=1,numtem0) end do else do i=1,numtem0 nden0=nden(i) read(53,err=11) (absopa0(i,j),j=1,nden0) 11 continue end do end if if(mod(k,istepf).eq.0.and.frta.lt.frtlim) then ij=ij+1 frtab(ij)=frta frlt(ij)=log10(frta) do i=1,numtemp numr=numrh(i) do j=1,numr absopac(i,j,ij)=absopa0(indt(i),indr(j)) end do end do end if end do numfreq=ij c c write(*,*) 'final NUMFREQ, FREQ(1)',numfreq,freq(1) c DO K=1,NUMFREQ IF(FRTAB(K).GT.2.997925E13) THEN K0=K ELSE do i=1,numtemp numr=numrh(i) do j=1,numr absopac(i,j,k)=absopac(i,j,k0) end do end do END IF END DO close(53) end if c frtabm=max(frtab(1),frtab(numfreq)) RETURN END C C C ******************************************************************** C C SUBROUTINE RAYINI 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 rhomat: 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' c c read Rayleigh scattering opacity table (if needed) c numfreq2 = numfreq if(ifrayl.lt.0) then open(52,file='./data/rayleigh.tab',status='old') read(52,*) numfreq2,numtemp,numrho read(52,*) read(52,*) (tempvec(i),i=1,numtemp) read(52,*) read(52,*) ((rhomat(i,j),j=1,numrho),i=1,numtemp) read(52,*) do j = 1, numrho read(52,*) (raytab(i,j),i=1,numtemp) end do close(52) call rayset else if(ifrayl.gt.0) then call rayleigh(0,0,0,scr) end if c RETURN END C C C ******************************************************************** C C SUBROUTINE TABINT C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' common/intcff/yint(mfreq),jint(mfreq) dimension absort(mfrtab) C IF(IOPTAB.LT.0.AND.IFRSET.EQ.0) THEN c C if frequencies are exactly tabular c nfreq=numfreq nfreqc=numfreq do ij=1,nfreq freq(ij)=frtab(ij) ijfr(ij)=ij jik(ij)=ij ijali(ij)=1 end do w(1)=0.5*(frtab(1)-frtab(2)) w(nfreq)=0.5*(frtab(nfreq-1)-frtab(nfreq)) do ij=2,nfreq-1 w(ij)=0.5*(frtab(ij-1)-frtab(ij+1)) end do C ELSE C C if frequencies are already set c c set up interpolation coefficients for frequency interpolation c by bisection c fr1=frtab(1) fr2=frtab(numfreq) do ij=1,nfreq xint=freq(ij) jl=0 ju=numfreq+1 10 continue if(ju-jl.gt.1) then jm=(ju+jl)/2 if((fr2.gt.fr1).eqv.(xint.gt.frtab(jm))) then jl=jm else ju=jm end if go to 10 end if j=jl if(j.eq.numfreq) j=j-1 if(j.eq.0) j=j+1 jint(ij)=j yint(ij)=un/log10(frtab(j+1)/frtab(j)) end do c do it=1,numtemp numrho=numrh(it) do ir=1,numrho do k=1,numfreq absort(k)=absopac(it,ir,k) end do do ij=1,nfreq j=jint(ij) rc=(absort(j+1)-absort(j))*yint(ij) opac=rc*log10(freq(ij)/frtab(j))+absort(j) absopac(it,ir,ij)=opac end do end do end do c c reset tabular opacities to zero out of range of FREQ c do ij=1,nfreq if(freq(ij).lt.fr2*0.99.or.freq(ij).gt.fr1*1.01) then do it=1,numtemp numrho=numrh(it) do ir=1,numrho absopac(it,ir,ij)=0. end do end do end if end do END IF C RETURN END C C C ******************************************************************** C C subroutine chctab c ================= c c check the consistency of the opacities in the opacity c table; modify the input paramaters for additional opacities c if needed c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' common/abntab/abunt(matom),abuno(matom),tmolit, * iophmt,ioph2t,iophet,iopcht,iopoht, * ioh2mt,ih2h2t,ih2het,ioh2ht,iohhet, * ifmolt c character*4 typ dimension typ(matom) c DATA TYP/' H ',' He ',' Li ',' Be ',' B ',' C ', * ' N ',' O ',' F ',' Ne ',' Na ',' Mg ', * ' Al ',' Si ',' P ',' S ',' Cl ',' Ar ', * ' K ',' Ca ',' Sc ',' Ti ',' V ',' Cr ', * ' Mn ',' Fe ',' Co ',' Ni ',' Cu ',' Zn ', * ' Ga ',' Ge ',' As ',' Se ',' Br ',' Kr ', * ' Rb ',' Sr ',' Y ',' Zr ',' Nb ',' Mo ', * ' Tc ',' Ru ',' Rh ',' Pd ',' Ag ',' Cd ', * ' In ',' Sn ',' Sb ',' Te ',' I ',' Xe ', * ' Cs ',' Ba ',' La ',' Ce ',' Pr ',' Nd ', * ' Pm ',' Sm ',' Eu ',' Gd ',' Tb ',' Dy ', * ' Ho ',' Er ',' Tm ',' Yb ',' Lu ',' Hf ', * ' Ta ',' W ',' Re ',' Os ',' Ir ',' Pt ', * ' Au ',' Hg ',' Tl ',' Pb ',' Bi ',' Po ', * ' At ',' Rn ',' Fr ',' Ra ',' Ac ',' Th ', * ' Pa ',' U ',' Np ',' Pu ',' Am ',' Cm ', * ' Bk ',' Cf ',' Es '/ c write(6,600) do ia=1,matom write(6,601) typ(ia),abndd(ia,1),abunt(ia),abuno(ia) end do 600 format( * ' chemical abundances:'// * 7x,' HERE OP.TAB.EOS OP.TAB.OPACITIES') 601 format(2x,a4,1p3e12.3) 603 format(/' treatment of molecules: IFMOL here: ',i4/ * ' op.tab:',i4/ * ' TMOLIM here: ',f10.1/ * ' op.tab:',f10.1) c write(6,603) ifmol,ifmolt,tmolim,tmolit if(ifmol.ne.ifmolt) then if(keepop.eq.0) then ifmol=ifmolt tmolim=tmolit write(6,*) * ' IFMOL and TMILIM changed to the values of op.table' else write(6,*) ' but IFMOL and TMOLIM retained here' end if end if c write(6,604) 604 format(/' additional opacities'/) if(iophmt.gt.0.and.(iophmi.gt.0.or.ielhm.gt.0)) then write(6,*) 'H- opacity included in the op.table and here' if(keepop.eq.0) then iophmi=0 write(6,*) ' so removed here (IOPHMI=0)' if(ielhm.gt.0) * write(6,*) ' but H- is explicit here, needs to be changed!!' * ' else write(6,*) ' but retained here, so it is taken twice!' end if end if if(iophmi.gt.0.or.ielhm.gt.0) write(6,*) * 'H- opacity included here' c if(ioph2t.gt.0.and.ioph2p.gt.0) then write(6,*) 'H2+ opacity included in the op.table and here' if(keepop.eq.0) then ioph2p=0 write(6,*) ' so removed here (IOPH2P=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if if(ioph2p.gt.0) write(6,*) 'H2+ opacity included here' c if(iophet.gt.0.and.iophem.gt.0) then write(6,*) 'He- opacity included in the op.table and here' if(keepop.eq.0) then iophem=0 write(6,*) ' so removed here (IOPHEM=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(iopcht.gt.0.and.iopch.gt.0) then write(6,*) 'CH opacity included in the op.table and here' if(keepop.eq.0) then iopch=0 write(6,*) ' so removed here (IOPCH=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(iopoht.gt.0.and.iopoh.gt.0) then write(6,*) 'OH opacity included in the op.table and here' if(keepop.eq.0) then iopoh=0 write(6,*) ' so removed here (IOPOH=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(ioh2mt.gt.0.and.ioph2m.gt.0) then write(6,*) 'H2- opacity included in the op.table and here' if(keepop.eq.0) then ioph2m=0 write(6,*) ' so removed here (IOPH2M=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(ih2h2t.gt.0.and.ioh2h2.gt.0) then write(6,*) 'CIA H2-H2 opacity included in the op.table and here' if(keepop.eq.0) then ioh2h2=0 write(6,*) ' so removed here (IOH2H2=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(ih2het.gt.0.and.ioh2he.gt.0) then write(6,*) 'CIA H2-He opacity included in the op.table and here' if(keepop.eq.0) then ioh2he=0 write(6,*) ' so removed here (IOH2HE=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(ioh2ht.gt.0.and.ioh2h.gt.0) then write(6,*) 'CIA H2-H opacity included in the op.table and here' if(keepop.eq.0) then ioh2h=0 write(6,*) ' so removed here (IOH2H=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c if(iohhet.gt.0.and.iohhe.gt.0) then write(6,*) 'CIA H2-H2 opacity included in the op.table and here' if(keepop.eq.0) then iohhe=0 write(6,*) ' so removed here (IOHHE=0)' else write(6,*) ' but retained here, so it is taken twice!' end if end if c return end C C C ******************************************************************** C C subroutine rayset c =================== c c set up a table of Rayleigh scattering opacity c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' c do id=1,nd t=temp(id) rho=dens(id) c if(numtemp.eq.nd) then opac=raytab(id,1) go to 10 end if c TL=LOG(T) DELTAT=(TL-TTAB1)/(TTAB2-TTAB1)*FLOAT(numtemp-1) JT = 1 + IDINT(DELTAT) JU = JT + 1 IF(JT.LT.1) JT = 1 IF(JT.GT.numtemp-1) JT = numtemp-1 t1i=tempvec(jt) t2i=tempvec(jt+1) dti=(TL-T1i)/(T2i-T1i) if(deltat.lt.0.) dti = 0.d0 C if(numrho.gt.1) then rtab1=rhomat(jt,1) rtab2=rhomat(jt,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(jt,jr) r2i=rhomat(jt,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr1=raytab(jt,jr)+ * dri*(raytab(jt,jr+1)-raytab(jt,jr)) c rtab1=rhomat(ju,1) rtab2=rhomat(ju,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(ju,jr) r2i=rhomat(ju,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr2=raytab(ju,jr)+ * dri*(raytab(ju,jr+1)-raytab(ju,jr)) c opac=opr1+(opr2-opr1)*dti else jr=1 opac=raytab(jt,jr)+(raytab(ju,jr)-raytab(jt,jr))*dti end if 10 continue raysc(id)=exp(opac) end do return end C C C *********************************************************************** C C SUBROUTINE RAYLEIGH(MODE,IJ,ID,SCR) C =================================== C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' PARAMETER (FRRAY = 2.463D15, * FRAYHe = 5.150E15, * FRAYH2 = 2.922E15, * C18 = 2.997925D18, * CR0 = 5.799D-13, * CR1 = 1.422D-6, * CR2 = 2.784D0) COMMON/RAYSCT/RCS(MFREQ),RCHE(MFREQ),RCH2(MFREQ) common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) C IF(MODE.EQ.0) THEN DO IK=1,NFREQ FRM=MIN(FREQ(IK),FRRAY) x=UN/(C18/FRM)**2 RCS(IK)=(CR0+(CR1+CR2*X)*X)*X*X END DO IF(IRSCHE.NE.0) THEN DO IK=1,NFREQ X=(C18/MIN(FR,FRAYHe))**2 RCHE(IK)=5.484E-14/X/X*(1.+(2.44E5+5.94E10/ * (X-2.90E5))/X)**2 END DO END IF IF(IRSCH2.NE.0.AND.IFMOL.GT.0) THEN DO IK=1,NFREQ X=(C18/MIN(FR,FRAYH2))**2 X2=1./X/X RCH2(IK)=(8.14E-13+1.28E-6/X+1.61*X2)*X2 END DO END IF ELSE SCR=RCS(IJ)*anato(1,id) IF(IRSCHE.NE.0) SCR=SCR+RCHE(IJ)*ANATO(2,ID) IF(IRSCH2.NE.0.AND.IFMOL.GT.0) SCR=SCR+RCH2(IJ)*ANMOL(2,ID) END IF RETURN END C C C ******************************************************************** C C SUBROUTINE OPCTAB(FR,IJ,ID,T,RHO,AB,SC,SCT,IGRAM) C ================================================= C C opacity for a given temperature and density computed C by an interpolation of the precalculated opacity table C C This is a simplified routine with all interpolations linear C C Input: FR - frequency (Hz) C T - temperature (K) C RHO - density (g cm^-3) C Outout: AB - absorptive opacity (per gram) C SC - scattering opacity (per gram) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' parameter (frray0 = 5.0872638d14) C jf=ij frij=fr c if(numtemp.eq.nd) then opac=absopac(id,1,jf) go to 10 end if c TL=LOG(T) DELTAT=(TL-TTAB1)/(TTAB2-TTAB1)*FLOAT(numtemp-1) JT = 1 + IDINT(DELTAT) JU = JT + 1 IF(JT.LT.1) JT = 1 IF(JT.GT.numtemp-1) JT = numtemp-1 t1i=tempvec(jt) t2i=tempvec(jt+1) dti=(TL-T1i)/(T2i-T1i) if(deltat.lt.0.) dti = 0.d0 C if(numrh(1).ne.1) then c c lower temperature c numrho=numrh(jt) rtab1=rhomat(jt,1) rtab2=rhomat(jt,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(jt,jr) r2i=rhomat(jt,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr1=absopac(jt,jr,jf)+ * dri*(absopac(jt,jr+1,jf)-absopac(jt,jr,jf)) c c higher temperature c ju=jt+1 numrho=numrh(ju) rtab1=rhomat(ju,1) rtab2=rhomat(ju,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(ju,jr) r2i=rhomat(ju,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr2=absopac(ju,jr,jf)+ * dri*(absopac(ju,jr+1,jf)-absopac(ju,jr,jf)) opac=opr1+(opr2-opr1)*dti else jr=1 opac=absopac(jt,jr,jf)+(absopac(ju,jr,jf)- * absopac(jt,jr,jf))*dti end if 10 continue opac=exp(opac) C AB=opac C C ************************************************************ C scattering C ************************************************************ C 1. Rayleigh scattering C sct=0. if(ifrayl.lt.0) then sct=raysc(id)*(freq(jf)/frray0)**4 else if(ifrayl.gt.0) then call rayleigh(1,ij,id,scr) sct=scr/dens(id) end if if(ioptab.lt.0) sct=sct+sige*elec(id)/rho c sct=sc+sige*elec(id)/dens(id) c sct=sc C c 2. cloud scattering (not yet implemented) c if(iter.le.0) return c c ab=ab+abscld(id,jf) c sct=sct+scacld(id,jf,1) c if(igram.eq.0) then ab = ab*rho sc = sc*rho sct=sct*rho end if c RETURN END C C C ******************************************************************** C C SUBROUTINE OPACT1(IJ) C ===================== C C Absorption, emission, and scattering coefficients C at frequency IJ and for all depths C C Input: IJ opacity and emissivity is calculated for the C frequency points with index IJ C Output: ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' common/hmolab/anh2(mdepth),anhm(mdepth) C FR=FREQ(IJ) DO ID=1,ND T=TEMP(ID) RHO=DENS(ID) HKT1(ID)=HK/T XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) PLAN=XKFB(ID)/XKF1(ID) CALL OPCTAB(FR,IJ,ID,T,RHO,AB,SC,SCT,0) if(ioptab.lt.0) then ABSO1(ID)=AB+sct SCAT1(ID)=SCT ABSOT(ID)=ABSOT(ID)+ABSO1(ID)/DENS(ID) else if(ioptab.gt.0) then ABSO1(ID)=ABSO1(ID)+AB end if EMIS1(ID)=EMIS1(ID)+AB*PLAN END DO RETURN END C C C **************************************************************** C C SUBROUTINE OPACTD(IJ) C ===================== C C Absorption and emission coefficients, and their derivatives C C This procedure is very similar to OPACT1, the only difference is C the evaluation of derivatives C C Input: C IJ - depth index C Output: C ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient C Dxxy - array of derivatives of xx (=AB for absorption, =EM for C emission, =SC for scattering) coefficient C wrt y (=T for temperature, =N for density) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' common/rhoder/drhodt(mdepth) PARAMETER (DELT=1.D-3, DELR=1.D-3) common/dsctva/dsct1(mdepth),dscn1(mdepth) common/hmolab/anh2(mdepth),anhm(mdepth) C imodf=0 if(ifryb.gt.0) imodf=1 FR=FREQ(IJ) DO ID=1,ND T=TEMP(ID) T1=T*(UN+DELT) RHO=DENS(ID) RHO1=RHO*(UN+DELR) XKF(ID)=EXP(-HKT1(ID)*FR) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) PLAN=XKFB(ID)/XKF1(ID) DPLAN=PLAN/XKF1(ID)*HKT1(ID)*FR/T CALL OPCTAB(FR,IJ,ID,T,RHO,AB,SC,SCT,imodf) CALL OPCTAB(FR,IJ,ID,T1,RHO,AB1,SC1,SCT1,imodf) CALL OPCTAB(FR,IJ,ID,T,RHO1,AB2,SC2,SCT2,imodf) ABSO1(ID)=AB+sct SCAT1(ID)=SCT EMIS1(ID)=AB*PLAN ABSOT(ID)=ABSO1(ID) IF(IMODF.EQ.0) ABSOT(ID)=ABSO1(ID)/DENS(ID) c c derivatives w.r.t. temperature c DABT1(ID)=(AB1-AB)/T/DELT DEMT1(ID)=AB*DPLAN+DABT1(ID)*PLAN DSCT1(ID)=(SCT1-SCT)/T/DELT dabt1(id)=dabt1(id)+dsct1(id) if(ifryb.gt.0) then c c derivatives w.r.t. density c DABN1(ID)=(AB2-AB)/RHO/DELR DEMN1(ID)=DABN1(ID)*PLAN DSCN1(ID)=(SCT2-SCT)/RHO/DELR dabn1(id)=dabn1(id)+dscn1(id) c c modify derivatives in case density is not a state parameter c IF(INHE.LE.0) THEN DABT1(ID)=DABT1(ID)+DABN1(ID)*DRHODT(ID) DEMT1(ID)=DEMT1(ID)+DEMN1(ID)*DRHODT(ID) DSCT1(ID)=DSCT1(ID)+DSCN1(ID)*DRHODT(ID) DABN1(ID)=0. DEMN1(ID)=0. DSCN1(ID)=0. END IF end if END DO C C store quantities for explicit (linearized) frequencies C IF(IJEX(IJ).LE.0.OR.IFRYB.GT.0) RETURN IJE=IJEX(IJ) DO ID=1,ND ABSOEX(IJE,ID)=ABSO1(ID) SCATEX(IJE,ID)=SCAT1(ID) EMISEX(IJE,ID)=EMIS1(ID) DABTEX(IJE,ID)=DABT1(ID) DEMTEX(IJE,ID)=DEMT1(ID) DABNEX(IJE,ID)=DABN1(ID) DEMNEX(IJE,ID)=DEMN1(ID) END DO C RETURN END C C C **************************************************************** C C SUBROUTINE SETTRM C ================= C C reads the equation-of-state tables for the pressure (P) C and entropy (S), as a function of T and rho; C C stores P(rho,T) and S(rho,t) in arrays PL and SL C INCLUDE 'IMPLIC.FOR' COMMON/THERM/SL(330,100),PL(330,100) COMMON/TABLTD/R1,R2,T1,T2,T12,T22,INDEX common/tdedge/redge,pedge(100),sedge(100),cvedge(100), & cpedge(100),gammaedge(100),tedge(100) common/tdflag/JON parameter (RCON=8.31434E7) C open(58,file='./data/stab.dat',status='old') open(59,file='./data/ptab.dat',status='old') C READ(58,*) YHEA,INDEX,R1,R2,T1,T2,T12,T22 DO JR = 1,INDEX DO JQS=1,10 JL = 1 + (JQS-1)*10 JU = JL + 9 READ(58,130) (SL(JR,JQ),JQ=JL,JU) 130 FORMAT(10F8.5) END DO END DO C READ(59,*) YHEA,INDEX,R1,R2,T1,T2,T12,T22 DO JR=1,INDEX DO JQP=1,10 JL = 1 + (JQP-1)*10 JU = JL + 9 READ(59,130) (PL(JR,JQ),JQ=JL,JU) END DO END DO C CLOSE(58) CLOSE(59) c c Edge arrays c r = 1.5d0*10.d0**r1 tmin = 1.5d0*10.d0**t1 tmax = 0.9d0*10.d0**t2 redge = r do i = 1, 100 t = t1 + (t2-t1)*dfloat(i-1)/dfloat(99) t = 10.d0**t t = min(tmax,max(t,tmin)) tedge(i) = t rho=r CALL PRSENT(RHO*1.1,T,P1,S1) CALL PRSENT(RHO,T*1.1,P2,S2) CALL PRSENT(RHO,T,P0,S0) S1=RCON*S1 S2=RCON*S2 S0=RCON*S0 DPDR=(P1-P0)/(.1*RHO) DPDT=(P2-P0)/(.1*T) DSDT=(S2-S0)/(.1*T) DSDR=(S1-S0)/(.1*RHO) DEN=DPDR*DSDT-DPDT*DSDR P=P0 S=S0/RCON CV=T*DSDT CP=T*DEN/DPDR DQ=DSDT*P/(DEN*RHO) GAMMA=1.d0/DQ c pedge(i) = p sedge(i) = s cvedge(i) = cv cpedge(i) = cp gammaedge(i) = gamma write(44,45) i,tedge(i),cvedge(i),cpedge(i),sedge(i), & gammaedge(i) 45 format(i4,5e14.5) enddo c RETURN END c C C C *************************************************************** C C FUNCTION RHOEOS(T,P) C ==================== C C equation of state - determining density from C temperature and pressure C C Input: T - temperature (K) C P - total pressure (cgs) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' parameter(wmol0=1.67333E-24/2.3) data inirea /0/ C C initialize EOS tables C if(inirea.eq.0) then call settrm inirea=1 end if C AN=P/BOLK/T RHO=AN*wmol0 C niteos=0 10 niteos=niteos+1 CALL PRSENT(RHO,T,P0,S0) CALL PRSENT(RHO*1.01,T,P1,S1) DPDR=(P1-P0)/(.01*RHO) DRXX=(P-P0)/DPDR/rho if(drxx.lt.-0.9) drxx=-0.9 rho=rho*(un+drxx) IF(ABS(DRXX).GT.1.d-5.and.niteos.lt.20) GO TO 10 C rhoeos=rho return end C C C ******************************************************************** C C SUBROUTINE SETDRT C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' COMMON/RHODER/DRHODT(MDEPTH) PARAMETER(DDTMIN=0., DDTPLU=0.001) C DO ID=1,ND T=TEMP(ID) P=PTOTAL(ID) RHO1=RHOEOS(T*(UN-DDTMIN),P) RHO2=RHOEOS(T*(UN+DDTPLU),P) DRHODT(ID)=(RHO2-RHO1)/T/(DDTMIN+DDTPLU) END DO RETURN END C C C ******************************************************************** C C SUBROUTINE TRMDRT(ID,T,P,HEATCP,DLRDLT,GRDADB,RHO) C ================================================== C C Thermodynamic derivatives - based on statew equation and entropy C tables C C Input: T - temperature C P - gas pressure C C Output: HEATCP - specific heat at constant pressure C DLRDLT - d(ln rho)/d(ln T) C GRDADB - adiabatic gradient d(ln T)/d(ln P)_ad C etdrt C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' COMMON/CC/DPDR,DPDT,DSDT,DSDR,CV,S,GAMMA COMMON/CONVOUT/CFLX(MDEPTH),VELCON(MDEPTH),GRADAD(MDEPTH), & ENT(MDEPTH) C parameter (RCON=8.31434E7) parameter(wmol0=1.67333E-24/2.3) common/tdedge/redge,pedge(100),sedge(100),cvedge(100), & cpedge(100),gammaedge(100),tedge(100) common/tdflag/JON C C numerical evaluation of thermodynamic derivatives C rho=rhoeos(t,p) drho=0.01*rho dt=0.01*t call prsent(rho,t,p0,s0) call prsent(rho+drho,t,p1,s1) call prsent(rho-drho,t,p2,s2) call prsent(rho,t+dt,p3,s3) call prsent(rho,t-dt,p4,s4) dpdr=(p1-p2)/(2.*drho) dpdt=(p3-p4)/(2.*dt) dsdr=(s1-s2)/(2.*drho)*rcon dsdt=(s3-s4)/(2.*dt)*rcon DEN=DPDR*DSDT-DPDT*DSDR c if(jon .eq. 0) then HEATCV=T*DSDT HEATCP=T*DEN/DPDR DQ=DSDT*P/(DEN*RHO) GAMMA=1.d0/DQ DLRDLT = -RHO*DPDR/(T*DPDT) DLRDLT = 1.D0/DLRDLT GRDADB = -P/(HEATCP*RHO*T)*DLRDLT TDPT=T*DPDT else if(jon .ne. 0) then HEATCV = cvedge(JON) HEATCP = cpedge(JON) DLRDLT = -1.d0 GRDADB = -P/(HEATCP*RHO*T)*DLRDLT ! 0.4d0 GAMMA = gammaedge(JON) endif C grdadb=p/t*(dsdr/(dsdr*dpdt-dsdt*dpdr)) GRADAD(ID) = GRDADB ENT(ID) = S0 C RETURN END C C C *************************************************************** C C SUBROUTINE PRSENT(R,T,FP,FS) C ============================ C C interpolates pressure and entropy from tables C INCLUDE 'IMPLIC.FOR' COMMON/THERM/SL(330,100),PL(330,100) COMMON/TABLTD/R1,R2,T1,T2,T12,T22,INDEX common/tdedge/redge,pedge(100),sedge(100),cvedge(100), & cpedge(100),gammaedge(100),tedge(100) common/tdflag/JON C JON=0 RL = DLOG10(R) ALPHA=T1+(RL-R1)/(R2-R1)*(T12-T1) BETA=T2-T1+((T22-T12)-(T2-T1))*(RL-R1)/(R2-R1) QL = (DLOG10(T) - ALPHA)/BETA DELTA=(RL-R1)/(R2-R1)*FLOAT(INDEX-1) JR = 1 + IDINT(DELTA) JQ = 1 + IDINT(99.*QL) IF(JR.LT.2) GO TO 300 IF(JR.GT.(INDEX-1)) GO TO 300 IF(JQ.LT.2) GO TO 300 IF(JQ.GT.99) GO TO 300 P = DELTA - (JR-1) Q = 99.*QL - (JQ-1) C interpolate: FS = 0.5D0*Q*(Q-1.D0)*SL(JR,JQ-1) 1 + 0.5D0*P*(P-1.D0)*SL(JR-1,JQ) 2 + (1.D0+P*Q-P*P-Q*Q)*SL(JR,JQ) 3 + 0.5D0*P*(P-2.D0*Q+1.D0)*SL(JR+1,JQ) 4 + 0.5D0*Q*(Q-2.D0*P+1.D0)*SL(JR,JQ+1) 5 + P*Q*SL(JR+1,JQ+1) FS = 10.D0**FS C FP = 0.5D0*Q*(Q-1.D0)*PL(JR,JQ-1) 1 + 0.5D0*P*(P-1.D0)*PL(JR-1,JQ) 2 + (1.D0+P*Q-P*P-Q*Q)*PL(JR,JQ) 3 + 0.5D0*P*(P-2.D0*Q+1.D0)*PL(JR+1,JQ) 4 + 0.5D0*Q*(Q-2.D0*P+1.D0)*PL(JR,JQ+1) 5 + P*Q*PL(JR+1,JQ+1) FP = 10.D0**FP RETURN C C off the table C 300 CONTINUE C write(60,*) ' Off the table!' C JQ = min(98,max(JQ, 2)) JON = JQ FP = pedge(JQ)*R*T/(redge*tedge(JQ)) FS = sedge(JQ) + 1.d0/(gammaedge(JQ)-1.d0)* & dlog(FP/pedge(JQ)*(redge/R)**gammaedge(JQ)) write(60,*) JQ, R, T, FP, FS C RETURN END C C C *************************************************************** C C subroutine moleq(id,tt,an,aein,ane,energ,entt,wm,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 - total particle number density c aein - initial estimate of the electron density c c Output: 1) parameters transported through formal parameters" C ane - electron density c entt - entropy c energ - internal energy c 2) parameters transported through COMMON blocks c ELEC(ID) - electron denity c DENS(ID) - mass density c WMM(ID) - mean molecular weight c QADD(ID) - total charge of non-explicit species c ABUND(I,ID) - abundances of explicit atoms, c counting only atoms and ions c (not atoms sequestered in molecules) c c Input data for molecules given in file tsuji.molec c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' c character*128 MOLEC COMMON/COMFH1/C(600,5),PPMOL(600),APMLOG(600), * XIP(100),XIP2(100),CCOMP(100),UIIDUI(100), * P(100),FP(100),XKP(100),XK2(100),EPS,SWITER, * NELEM(5,600),NATO(5,600),MMAX(600), * NELEMX(100),NMETAL,NMOLEC,NIMAX common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) common/ioniz2/anion2(30,mdepth) common/entrop/entato(100),ention(100),entmol(600) common/hmolab/anh2(mdepth),anhm(mdepth) common/terden/rhoter,anta,entrp common/adchar/qadd(mdepth) common/moldat/moltab,irwtab DIMENSION NATOMM(5),NELEMM(5), * emass(100),uelem(100),ull(100),anden(800), * aelem(100),ammol(600),cmol(600) dimension anat0(100),anio0(100),anmo0(600),pfmol(600) dimension denso(mdepth),eleco(mdepth),wmmo(mdepth) c data nmetal/92/ c data iread/1/ c if(ifmol.eq.0) return MOLEC ='data/tsuji.molec_bc2' if(moltab.eq.0) MOLEC='data/tsuji.molec_orig' c ECONST=4.342945E-1 tk=1./(tt*bolk) pgas=an/tk sahcon=1.87840e20*tt*sqrt(tt) ev2erg=1.6018e-12 nimax=3000 eps=0.001 switer=1 C if(iread.eq.1) then c C---- data for atoms ---------------- C do i=1,nmetal ia=i nelemx(i)=ia ccomp(ia)=abndd(ia,id) xip(ia)=enev(ia,1) xip2(ia)=enev(ia,2) emass(ia)=amas(ia) end do c c---- read molecular data from tsuji.molec ---------------------- c J=0 OPEN(UNIT=26,FILE=MOLEC,STATUS='OLD') 10 J=J+1 READ(26,510,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) 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 MMAXJ=MMAX(J) IF(MMAXJ.GT.0) THEN DO M=1,MMAXJ NELEM(M,J)=NELEMM(M) NATO(M,J)=NATOMM(M) END DO GO TO 10 END IF 20 CONTINUE NMOLEC=J-1 close(26) c DO I=1,NMETAL NELEMI=NELEMX(I) P(NELEMI)=1.D-70 END DO iread=0 end if c c---- end of reading atomic and molecular data ---------------------- c p(99)= aein/tk pesave=p(99) p(99)=pesave c THET=5040./tt TEM=tt PGLOG=log10(Pgas) PG=Pgas tkln25=-log(tk)*2.5 tkln15=log(bolk*tt)*1.5 tkev=5040./tt 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)) idstd=nd*2/3 entcon=103.973 ann=an-ane tkk=bolk*tt*tt c c----atoms----------------------------------------------------------------- c entt=0 antt=0. energ=0. 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 mpartf(nelemi,1,0,tt,u0,dulog) uelem(nelemi)=u0 aelem(nelemi)=anden(i)/(u0*sahcon*emass(nelemi)**1.5) ull(nelemi)=log10(aelem(nelemi)) anat0(nelemi)=anden(i) if(dulog.lt.0.) dulog=0. entato(nelemi)=tkln15-log(anden(i))+log(u0)+ * 1.5*log(emass(nelemi))+entcon+tkk*dulog anx=anden(i)/ann antt=antt+anx entt=entt+entato(nelemi)*anden(i) energ=energ+dulog/tk*anden(i) 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 mpartf(nelemi,2,0,tt,u1,dulog) if(dulog.lt.0.) dulog=0. anio0(nelemi)=anden(i+nmetal) ention(nelemi)=tkln15-log(anden(i+nmetal))+log(u1)+ * 1.5*log(emass(nelemi))+entcon+tkk*dulog anx=anio0(nelemi)/ann antt=antt+anx entt=entt+ention(nelemi)*anio0(nelemi) energ=energ+(xip(nelemi)*1.6018e-12+ * dulog/tk)*anio0(nelemi) 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 c c H- (incorrect in the original Tsuji's table) c jbeg=1 if(moltab.eq.0) then j=1 anmo0(1)=1.0353e-16/tt/sqrt(tt)*exp(8762.9/tt)* * anat0(1)*ane ammol(1)=emass(1) pfmol(1)=1. entmol(1)=tkln15-log(anmo0(1))+1.5*log(emass(1))+entcon anx=anmo0(1)/ann antt=antt+anx entt=entt+entmol(j)*anmo0(1) tmass=tmass+emass(1)*anmo0(1) jbeg=2 end if c c---- molecules------------------------------------------------------------- c DO J=jbeg,NMOLEC jm=j+2*nmetal PMOLL=log10(PPMOL(J)+1.0D-70) anden(jm)=exp(pmoll/econst)*tk if(pmoll.lt.-20.) go to 100 umoll=log10(anden(jm))+c(j,2)*thet 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 Irwin data whenever available c call mpartf(0,0,j,tt,um,dulog) if(um.gt.0.) umoll=um if(umoll.lt.1.) umoll=1. c anmo0(j)=anden(jm) pfmol(j)=umoll if(dulog.lt.0.) dulog=0. entmol(j)=tkln15-log(anden(jm))+log(umoll)+ * 1.5*log(amasm)+entcon+tkk*dulog anx=anden(jm)/ann antt=antt+anx entt=entt+entmol(j)*anden(jm) energ=energ+dulog/tk*anden(jm) if(j.eq.2) energ=energ-4.476*ev2erg*anden(jm) c if(ipri.gt.0.and.ipmole.gt.0.and.mod(id,10).eq.1.and.j.le.10) c * write(80,680) id,j,anmo0(j),anx,antt,pfmol(j), c * entmol(j),entt,dulog,dulog/tk*anden(jm),energ 100 continue END DO c c electrons c entel=tkln15-log(ane)+1.5*log(emass(99))+entcon entt=entt+entel*ane antt=antt+ane/ann c c final entropy, density, and mean mnolecular weight c entt=entt*bolk rhoter=tmass*hmass ahtot=anat0(1)+anio0(1)+anmo0(1)+2.*anmo0(2) wm=tmass/antt/ann c if(ipri.eq.0) return c do i=1,nmetal j=nelemx(i) anato(j,id)=anat0(j) anion(j,id)=anio0(j) end do c do j=1,nmolec anmol(j,id)=anmo0(j) end do c anhm(id)=anmol(1,id) anh2(id)=anmol(2,id) C C save new density, molecular weight, and abundances of c atomic species c denso(id)=dens(id) eleco(id)=elec(id) wmmo(id)=wmm(id) dens(id)=tmass*hmass elec(id)=ane wmm(id)=dens(id)/(an-elec(id)) qadd(id)=0. do i=1,nmetal NELEMI=NELEMX(I) ia=iatex(nelemi) if(ia.gt.0) then abund(ia,id)=(anato(nelemi,id)+anion(nelemi,id))* * wmm(id)/dens(id)*ytot(id) else qadd(id)=qadd(id)+anion(nelemi,id) end if end do if(ielhm.eq.0) qadd(id)=qadd(id)-anhm(id) c if(ipri.eq.0) return c c don't change structure if particle conservation in not solved c c IF(INPC.eq.0.and.ifryb.eq.0) THEN IF(INPC.eq.0) THEN dens(id)=denso(id) elec(id)=eleco(id) wmm(id)=wmmo(id) ENDIF c RETURN END C C C ************************************************************************* C C SUBROUTINE RUSSEL(TEM,PG) c ========================= c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' COMMON/COMFH1/C(600,5),PPMOL(600),APMLOG(600), * XIP(100),XIP2(100),CCOMP(100),UIIDUI(100), * P(100),FP(100),XKP(100),XK2(100),EPS,SWITER, * NELEM(5,600),NATO(5,600),MMAX(600), * NELEMX(100),NMETAL,NMOLEC,NIMAX DIMENSION FX(100),DFX(100),Z(100),PREV(100),WA(100), * UIIDU2(100) C C ECONST=4.342945E-1 ECONST=4.3426E-1 XKCON=6.667343E-1 EPSDIE=5.0E-5 T=5040.4/TEM PGLOG=log10(PG) tk=1./(tem*1.38054e-16) C C HEH=helium/hydrogen ratio by number C c HEH=CCOMP(2)/CCOMP(1) HEH=YTOT(1)-UN C C evaluation of log XKP(MOL) C DO J=1,NMOLEC APLOGJ=C(J,5) DO K=1,4 KM5=5-K APLOGJ=APLOGJ*T + C(J,KM5) END DO APMLOG(J)=APLOGJ END DO apmlog(1)=-log10(1.0353e-16/tem/sqrt(tem)*tk*exp(8762.9/tem)) DHH=(((0.1196952E-02*T-0.2125713E-01)*T+0.1545253E+00)*T * -0.5161452E+01)*T+0.1277356E+02 DHH=EXP(DHH/ECONST) C C evaluation of the ionization constants C TEM25=TEM**2*SQRT(TEM) DO I=1,NMETAL NELEMI = NELEMX(I) * * calculation of the partition functions following Irwin (1981) C call mpartf(nelemi,1,0,tem,g0,dulog) call mpartf(nelemi,2,0,tem,g1,dulog) call mpartf(nelemi,3,0,tem,g2,dulog) uiidui(nelemi)=g1/g0*xkcon uiidu2(nelemi)=g2/g1*xkcon uiidui(nelemi)=g1/g0*xkcon XKP(NELEMI)=UIIDUI(NELEMI)*TEM25* * EXP(-XIP(NELEMI)*T/ECONST) XK2(NELEMI)=UIIDU2(NELEMI)*TEM25* * EXP(-XIP2(NELEMI)*T/ECONST) xk2(nelemi)=max(xk2(nelemi),1.d-70) END DO XK2(1)=0. C C preliminary value of PH at high temperatures C HKP=XKP(1) IF(T.LT.0.6) THEN PPH=SQRT(HKP*(PG/(1.0+HEH)+HKP))-HKP PH=PPH**2/HKP ELSE IF(PG/DHH.LE.0.1) THEN PH=PG/(1.0+HEH) ELSE PH=0.5 * (SQRT(DHH*(DHH+4.0 *PG/(1.0+HEH)))-DHH) END IF END IF C C evaluation of the fictitious pressures of hydrogen C PG=PH+PHH+2.0*PPH+HEH*(PH+2.0*PHH+PPH) C U=(1.0+2.0*HEH)/DHH Q=1.0+HEH R=(2.0+HEH)*SQRT(HKP) S=-1.0*PG X=SQRT(PH) C C Russell iterations C ITERAT=0 10 CONTINUE F=((U*X**2+Q)*X+R)*X+S DF=2.0*(2.0*U*X**2+Q)*X+R XR=X-F/DF C IF(ABS((X-XR)/XR).GT.EPSDIE) THEN ITERAT=ITERAT+1 IF(ITERAT.GT.50) THEN WRITE(6,710) TEM,PG,X,XR,PH 710 FORMAT(1H1, ' NOT CONVERGE IN RUSSEL '/// 'TEM=',F9.2,5X,'PG=', * E12.5,5X,'X1=',E12.5,5X,'X2=',E12.5,5X,'PH=',E12.5/////) ELSE X=XR GO TO 10 END IF END IF PH=XR**2 PHH=PH**2/DHH PPH=SQRT(HKP*PH) FPH=PH+2.0*PHH+PPH P(100)=PPH C C evaluation of the fictitious pressure of each element C DO I=1,NMETAL NELEMI=NELEMX(I) FP(NELEMI)=CCOMP(NELEMI)*FPH END DO C C check of initialization C PE=P(99) C C Russell equations C NITERR = 0 20 CONTINUE DO I=1,NMETAL NELEMI=NELEMX(I) c FX(NELEMI)=-FP(NELEMI)+P(NELEMI)*(1.0+XKP(NELEMI)/PE) c DFX(NELEMI)=1.0+XKP(NELEMI)/PE DFX(NELEMI)=1.0+XKP(NELEMI)/PE*(1.0+XK2(NELEMI)/PE) FX(NELEMI)=-FP(NELEMI)+P(NELEMI)*DFX(NELEMI) END DO C SPNION=0.0 spnplu=0. DO J=1,NMOLEC MMAXJ=MMAX(J) PMOLJL=-APMLOG(J) DO M=1,MMAXJ NELEMJ=NELEM(M,J) NATOMJ=NATO(M,J) PMOLJL=PMOLJL+DFLOAT(NATOMJ)*log10(P(NELEMJ)) END DO C PMOLJ=EXP(PMOLJL/ECONST) DO M=1,MMAXJ NELEMJ=NELEM(M,J) NATOMJ=NATO(M,J) ATOMJ=DFLOAT(NATOMJ) IF(NELEMJ.EQ.99) then if(natomj.ge.0) then SPNION=SPNION+PMOLJ*NATOMJ else SPNPLU=SPNPLU-PMOLJ*NATOMJ end if end if DO I=1,NMETAL NELEMI=NELEMX(I) IF(NELEMJ.EQ.NELEMI) THEN FX(NELEMI)=FX(NELEMI)+ATOMJ*PMOLJ DFX(NELEMI)=DFX(NELEMI)+ATOMJ**2* * PMOLJ/P(NELEMI) END IF END DO END DO PPMOL(J)=PMOLJ END DO C C solution of the Russell equations by Newton-Raphson method C DO I=1,NMETAL NELEMI=NELEMX(I) WA(I)=log10(P(NELEMI)+1.0D-70) END DO IMAXP1=NMETAL+1 WA(IMAXP1)=log10(PE+1.0D-70) DELTRS = 0.0 DO I=1,NMETAL NELEMI=NELEMX(I) PREV(NELEMI)=P(NELEMI)-FX(NELEMI)/DFX(NELEMI) PREV(NELEMI)=ABS(PREV(NELEMI)) IF(PREV(NELEMI).LT.1.0D-70) PREV(NELEMI)=1.0D-70 Z(NELEMI)=PREV(NELEMI)/P(NELEMI) DELTRS=DELTRS+ABS(Z(NELEMI)-1.0) IF(SWITER.GT.0.0) THEN P(NELEMI)=(PREV(NELEMI)+P(NELEMI))*0.5 ELSE P(NELEMI)=PREV(NELEMI) END IF END DO C C ionization equilibrium C PEREV =0.0 DO I=1,NMETAL NELEMI = NELEMX(I) PEREV=PEREV+XKP(NELEMI)*P(NELEMI)*(1.+xk2(nelemi)/pe) END DO C PEREV=SQRT(PEREV/(1.0+SPNION/PE)) DELTRS=DELTRS+ABS((PE-PEREV)/PE) PE=(PEREV+PE)*0.5 P(99)=PE IF(DELTRS.GT.EPS) THEN NITERR=NITERR+1 IF(NITERR.LE.NIMAX) THEN GO TO 20 ELSE WRITE(6,605) NIMAX END IF END IF 605 FORMAT(1H0,'*DOES NOT CONVERGE AFTER ',I4,' ITERATIONS') C RETURN END C C C ******************************************************************** C C c subroutine mpartf(jatom,ion,indmol,t,u,dulog) c ============================================= c c yields partition functions with polynomial data from c ref. Irwin, A.W., 1981, ApJ Suppl. 45, 621. c ln u(temp)=sum(a(i)*(ln(temp))**(i-1)) 1<=a<=6 c c Input: c jatom = element number in periodic table c ion = 1 for neutral, 2 for once ionized and 3 for twice ionized c indmol= index of a molecular specie (Tsuji index) c temp = temperature c Output: c u = partf.(linear scale) for iat,ion, or indmol, and temperature t c dulog = d ln(u)/d ln(T) c c implicit real*8 (a-h,o-z) common/moldat/moltab,irwtab real*8 a(6,3,92),aa(6),am(6,600) dimension indtsu(324),irw(600),igle(28) save iread,a,am DATA IGLE/2,1,2,1,6,9,4,9,6,1,2,1,6,9,4,9,6,1, * 10,21,28,25,6,25,28,21,10,21/ C data indtsu / 2, 5, 12, 4, 8, 7, 6, * 9, 11, 10, 29, 50, 59, 46, 133, 52, 19, * 13, 42, 38, 39, 37, 44, 36, 14, 118, 33, * 3, 16, 57, 32, 49, 60, 54, 41, 107,304, * 148, 152, 153, 155, 303, 17, 24, 25, 28, 51, * 112, 119, 102, 0, 21, 15, 43, 22,478, 64, * 47, 65, 414, 61, 191, 62 ,109, 40, 66,214, * 120*0, 30, 136*0/ c data iread /0/ 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') nmoli=66 else open(67,file= './data/irwin_bc.dat',status='old') nmoli=324 end if read(67,*) read(67,*) do j=1,92 do i=1,3 if(j.eq.1.and.i.eq.3) go to 10 sp=float(j)+float(i-1)/100. read(67,*) spec,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,600 irw(i)=0 end do do i=1,nmoli read(67,*) spec,aa indm=indtsu(i) if(indm.gt.0) then irw(indm)=i do j=1,6 am(j,indm)=aa(j) end do end if end do 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 u=1. dulog=0. if(t.lt.1000.) then stop 'partf; temp<1000 K' else if(t.gt.16000.) then c stop 'partf; temp>16000 K' c write(6,601) t c 601 format(' warning! T = ',f12.1, 'larger than 16000.'/) if(indmol.eq.0) then if(jatom.le.28.and.ion.le.jatom) u=igle(jatom-ion+1) end if return 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. u=exp(ulog) dulog= a(2,ion,jatom)+ * tl*(a(3,ion,jatom)*2.+ * tl*(a(4,ion,jatom)*3.+ * tl*(a(5,ion,jatom)*4.+ * tl*(a(6,ion,jatom)*5.)))) end if c c molecular species c if(indmol.gt.0) then indm=indmol if(irw(indm).gt.0) then 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) dulog= am(2,indm)+ * tl*(am(3,indm)*2.+ * tl*(am(4,indm)*3.+ * tl*(am(5,indm)*4.+ * tl*(am(6,indm)*5.)))) end if end if return end C C C ************************************************************************* C C subroutine tiopf(t,pf) c ====================== c c TiO partition function (data from Kurucz web site) c INCLUDE 'IMPLIC.FOR' dimension pf0(800) data pf0/ * 29.107, 55.425, 82.417, 111.190, 142.564, 176.916, * 214.340, 254.774, 298.065, 344.021, 392.431, 443.089, * 495.795, 550.365, 606.632, 664.449, 723.686, 784.230, * 845.981, 908.862, 972.800, 1037.739, 1103.636, 1170.451, * 1238.155, 1306.723, 1376.144, 1446.403, 1517.492, 1589.409, * 1662.152, 1735.724, 1810.122, 1885.352, 1961.428, 2038.351, * 2116.119, 2194.758, 2274.260, 2354.633, 2435.907, 2518.063, * 2601.125, 2685.096, 2769.992, 2855.809, 2942.560, 3030.257, * 3118.897, 3208.496, 3299.067, 3390.598, 3483.106, 3576.598, * 3671.095, 3766.569, 3863.048, 3960.522, 4059.035, 4158.545, * 4259.074, 4360.642, 4463.259, 4566.905, 4671.582, 4777.321, * 4884.105, 4991.937, 5100.852, 5210.813, 5321.838, 5433.972, * 5547.154, 5661.417, 5776.789, 5893.211, 6010.774, 6129.422, * 6249.173, 6370.026, 6491.973, 6615.042, 6739.240, 6864.542, * 6990.959, 7118.533, 7247.214, 7377.053, 7508.012, 7640.121, * 7773.370, 7907.764, 8043.309, 8180.032, 8317.835, 8456.861, * 8597.055, 8738.396, 8880.926, 9024.672, 9169.570, 9315.610, * 9462.927, 9611.339, 9760.963, 9911.798, 10063.900, 10217.148, * 10371.572, 10527.253, 10684.109, 10842.173, 11001.469, 11161.970, * 11323.751, 11486.758, 11650.978, 11816.415, 11983.159, 12151.134, * 12320.243, 12490.668, 12662.333, 12835.234, 13009.470, 13184.926, * 13361.601, 13539.660, 13718.891, 13899.456, 14081.252, 14264.326, * 14448.643, 14634.341, 14821.225, 15009.476, 15199.021, 15389.829, * 15581.955, 15775.377, 15970.188, 16166.239, 16363.513, 16562.006, * 16761.930, 16963.301, 17165.906, 17369.881, 17575.236, 17781.814, * 17989.816, 18198.996, 18409.707, 18621.680, 18835.068, 19049.715, * 19265.768, 19483.375, 19702.006, 19922.209, 20143.668, 20366.555, * 20590.742, 20816.402, 21043.338, 21271.672, 21501.369, 21732.563, * 21965.119, 22199.068, 22434.432, 22671.266, 22909.307, 23148.898, * 23389.893, 23632.322, 23875.969, 24121.160, 24367.707, 24615.848, * 24865.471, 25116.320, 25368.604, 25622.342, 25877.512, 26134.055, * 26392.404, 26651.764, 26912.826, 27175.250, 27439.197, 27704.539, * 27971.287, 28239.572, 28509.373, 28780.707, 29053.516, 29327.602, * 29603.338, 29880.539, 30159.105, 30439.322, 30721.055, 31004.254, * 31288.818, 31575.061, 31862.693, 32151.781, 32442.586, 32734.619, * 33027.777, 33323.023, 33619.535, 33917.707, 34217.711, 34518.996, * 34821.676, 35126.195, 35432.141, 35739.602, 36048.926, 36359.488, * 36672.023, 36985.633, 37300.863, 37617.965, 37936.469, 38256.309, * 38578.074, 38901.668, 39226.461, 39552.969, 39880.852, 40210.785, * 40541.852, 40874.691, 41209.359, 41545.535, 41883.602, 42222.715, * 42563.895, 42906.508, 43250.656, 43596.902, 43944.355, 44293.695, * 44644.504, 44997.621, 45351.590, 45707.242, 46065.008, 46424.367, * 46785.605, 47148.023, 47512.496, 47878.418, 48246.426, 48615.895, * 48987.336, 49360.082, 49734.758, 50111.004, 50489.383, 50868.996, * 51250.250, 51633.691, 52018.945, 52405.715, 52794.090, 53184.340, * 53576.375, 53970.605, 54366.176, 54763.148, 55162.430, 55563.215, * 55966.391, 56371.000, 56777.176, 57185.570, 57596.074, 58007.617, * 58421.418, 58837.172, 59254.539, 59673.418, 60094.066, 60517.410, * 60941.844, 61368.660, 61797.395, 62227.590, 62659.789, 63094.238, * 63529.695, 63967.488, 64407.887, 64849.496, 65292.867, 65735.922, * 66182.000, 66631.266, 67082.055, 67534.391, 67988.992, 68446.117, * 68904.789, 69365.180, 69827.914, 70292.781, 70759.352, 71228.500, * 71699.375, 72171.672, 72647.086, 73123.984, 73603.023, 74083.516, * 74566.359, 75050.555, 75537.758, 76027.258, 76518.125, 77012.008, * 77507.063, 78003.813, 78503.977, 79006.125, 79509.320, 80015.375, * 80522.461, 81031.938, 81544.164, 82058.313, 82574.352, 83093.914, * 83614.367, 84136.820, 84662.211, 85188.867, 85719.375, 86249.977, * 86783.781, 87319.219, 87857.180, 88396.797, 88939.805, 89484.266, * 90032.023, 90580.930, 91132.563, 91686.148, 92242.742, 92799.406, * 93360.016, 93923.453, 94488.313, 95055.211, 95625.297, 96197.477, * 96771.531, 97348.156, 97926.922, 98507.453, 99091.563, 99677.938, *100267.234,100856.438,101449.828,102045.750,102643.094,103244.117, *103846.969,104450.313,105057.641,105667.188,106279.516,106894.937, *107512.789,108133.117,108754.758,109377.687,110005.039,110634.602, *111266.141,111902.133,112537.984,113178.891,113819.766,114464.312, *115110.969,115760.687,116412.469,117068.055,117724.547,118384.383, *119047.469,119712.469,120380.187,121051.336,121724.102,122399.250, *123076.266,123756.977,124441.195,125126.406,125816.453,126506.766, *127202.367,127899.086,128598.266,129299.969,130004.969,130712.016, *131409.266,132117.719,132828.969,133544.016,134262.750,134986.344, *135712.891,136439.937,137170.969,137905.562,138641.578,139380.266, *140122.937,140868.641,141615.484,142366.703,143123.078,143880.000, *144638.484,145401.594,146168.125,146935.359,147707.484,148482.641, *149256.578,150037.281,150821.953,151606.750,152396.094,153188.766, *153983.391,154782.141,155582.203,156387.234,157192.719,158003.156, *158815.125,159632.437,160450.766,161274.750,162098.172,162926.000, *163756.609,164593.141,165430.859,166270.937,167114.750,167960.797, *168811.562,169663.906,170517.203,171376.531,172239.469,173105.891, *173975.250,174847.203,175721.453,176597.250,177480.984,178366.094, *179253.828,180145.734,181038.000,181936.031,182837.969,183739.922, *184645.937,185558.281,186470.844,187387.422,188307.234,189232.281, *190156.000,191088.234,192022.062,192957.250,193899.328,194842.984, *195788.391,196736.156,197687.828,198645.719,199603.422,200569.234, *201536.437,202508.641,203481.000,204459.016,205438.750,206424.312, *207409.953,208398.734,209393.234,210391.047,211390.984,212395.516, *213401.547,214420.141,215431.812,216453.453,217476.734,218501.266, *219530.219,220560.719,221597.891,222637.875,223677.750,224725.500, *225777.406,226829.297,227893.125,228954.547,230020.969,231086.453, *232157.469,233233.047,234315.406,235395.625,236480.953,237572.125, *238666.484,239765.125,240863.281,241969.750,243079.250,244191.719, *245304.812,246427.937,247548.234,248673.562,249804.984,250942.781, *252078.953,253222.812,254369.641,255519.359,256671.406,257827.906, *258988.859,260154.734,261322.281,262458.781,263606.437,264770.625, *265947.750,267125.156,268314.125,269507.687,270702.344,271905.156, *273110.156,274318.937,275531.687,276751.344,277970.781,279198.531, *280425.750,281663.250,282897.469,284138.906,285383.594,286637.031, *287891.156,289147.625,290413.312,291678.719,292946.031,294225.875, *295501.344,296782.656,298070.094,299363.875,300652.250,301953.750, *303260.062,304563.781,305874.375,307191.437,308517.031,309835.750, *311159.375,312490.937,313827.469,315166.781,316511.031,317860.406, *319214.969,320565.875,321929.344,323296.906,324660.219,326035.687, *327413.844,328794.406,330173.156,331566.156,332953.469,334356.187, *335757.625,337165.562,338566.094,339984.750,341402.937,342828.125, *344257.562,345686.750,347123.125,348564.250,350008.906,351453.219, *352908.062,354361.469,355828.000,357292.500,358765.719,360233.687, *361713.562,363200.187,364685.656,366174.500,367673.594,369174.906, *370678.969,372191.125,373708.937,375225.281,376743.719,378270.406, *379804.500,381334.250,382879.125,384420.812,385969.531,387519.812, *389078.937,390639.781,392213.875,393782.437,395359.156,396943.625, *398527.625,400110.937,401711.750,403310.344,404908.937,406513.875, *408125.781,409741.906,411356.875,412979.500,414613.125,416245.500, *417889.094,419530.000,421179.906,422831.531,424484.344,426153.187, *427816.406,429489.094,431161.312,432840.656,434517.000,436215.281, *437896.000,439602.594,441300.625,443016.156,444722.906,446445.437, *448164.812,449885.937,451615.094,453351.594,455090.125,456833.281, *458582.719,460335.344,462094.844,463857.094,465629.906,467402.781, *469178.406,470963.750,472745.906,474539.594,476333.312,478131.125, *479934.000,481740.750,483557.844,485376.625,487202.937,489033.562, *490868.031,492709.281,494547.375,496401.094,498249.594,500110.250, *501966.594,503836.062,505704.437,507580.687,509469.187,511349.781, *513239.000,515137.187,517038.812,518942.906,520858.156,522767.094, *524610.625,526433.812,528331.062,530253.437,532185.500,534127.875, *536073.937,538028.312,539983.375,541954.687,543916.312,545902.500, *547874.812,549857.125,551850.937,553839.937,555836.625,557838.500, *559849.937,561859.375,563880.625,565889.875,567916.000,569953.625, *571990.375,574034.937,576085.062,578127.375,580188.937,582251.000, *584328.812,586385.562,588464.062,590551.875,592644.625,594722.250, *596829.937,598931.375,601029.687,603142.812,605262.812,607384.625, *609513.125,611644.000,613775.875,615930.375,618073.750,620218.437, *622381.937,624524.312,626697.500,628869.000,631040.937,633223.562, *635409.187,637597.562,639800.187,642002.125,644212.562,646416.250, *648633.562,650864.187,653083.687,655315.312,657549.687,659795.500, *662032.250,664292.875,666542.312,668806.250,671071.312,673340.937, *675626.938,677898.750/ c it=int(t/10.) if(it.gt.800) it=800 pf=pf0(it) return end C C C ******************************************************************** C C SUBROUTINE RYBSOL C ================= C C driver of the complete-linearization solution in the Rybicki C formalism C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' INCLUDE 'ITERAT.FOR' COMMON/RYBMTX/RA(MDEPTH),RB(MDEPTH),RC(MDEPTH),VR(MDEPTH), * UA(MDEPTH),UB(MDEPTH),UC(MDEPTH), * VA(MDEPTH),VB(MDEPTH),VC(MDEPTH),WR(MDEPTH), * WM(MDEPTH,MDEPTH) common/imodlc/imodl0(mlevel) DIMENSION AL(MDEPTH),AU(MDEPTH),VAL(MDEPTH),UCOL(MDEPTH), * VAU(MDEPTH,MDEPTH),CHANGT(MDEPTH) dimension pop1(mlevel),babs(mlevel,mdepth) C C zeroing needed quantities C DO ID=1,ND REIT(ID)=0. REIN(ID)=0. AREIT(ID)=0. AREIN(ID)=0. CREIT(ID)=0. CREIN(ID)=0. REDT(ID)=0. REDTM(ID)=0. REDTP(ID)=0. REDN(ID)=0. REDNM(ID)=0. REDNP(ID)=0. FCOOLI(ID)=0. FLFIX(ID)=0. FLRD(ID)=0. ABROSD(ID)=0. SUMDPL(ID)=0. END DO C C zero vectors and matrices of the Rybicki formalism C DO ID=1,ND RA(ID)=0. RB(ID)=0. RC(ID)=0. UA(ID)=0. UB(ID)=0. UC(ID)=0. VA(ID)=0. VB(ID)=0. VC(ID)=0. VR(ID)=0. WR(ID)=0. AL(ID)=0. AU(ID)=0. VAL(ID)=0. DO ID1=1,ND WM(ID1,ID)=0. VAU(ID1,ID)=0. END DO END DO C if(ioptab.lt.-1) call setdrt c DO IJ=1,NFREQ FR=FREQ(IJ) W0=W0E(IJ) c IF(IOPTAB.GE.0) THEN CALL OPACTR(IJ) c ELSE c CALL OPACFD(IJ) c END IF CALL RTEFR1(IJ) CALL ALIFR1(IJ) CALL ROSSTD(IJ) C CALL RYBMAT(IJ) CALL TRIDAG(RA,RB,RC,VR,AL,ND) ID=1 VAL(ID)=VAL(ID)+VB(ID)*AL(ID)+VC(ID)*AL(ID+1) DO ID=2,ND-1 VAL(ID)=VAL(ID)+VA(ID)*AL(ID-1)+VB(ID)*AL(ID)+ * VC(ID)*AL(ID+1) END DO ID=ND VAL(ID)=VAL(ID)+VA(ID)*AL(ID-1)+VB(ID)*AL(ID) C DO IDC=1,ND DO ID=1,ND UCOL(ID)=0. END DO UCOL(IDC)=UB(IDC) IF(IDC.GT.1) UCOL(IDC-1)=UC(IDC-1) IF(IDC.LT.ND) UCOL(IDC+1)=UA(IDC+1) CALL TRIDAG(RA,RB,RC,UCOL,AU,ND) ID=1 VAU(ID,IDC)=VAU(ID,IDC)+VB(ID)*AU(ID)+VC(ID)*AU(ID+1) DO ID=2,ND-1 VAU(ID,IDC)=VAU(ID,IDC)+ * VA(ID)*AU(ID-1)+VB(ID)*AU(ID)+VC(ID)*AU(ID+1) END DO ID=ND VAU(ID,IDC)=VAU(ID,IDC)+VA(ID)*AU(ID-1)+VB(ID)*AU(ID) END DO END DO C DO ID=1,ND ABROSD(ID)= SUMDPL(ID)/ABROSD(ID) FCOOL(ID)=REINT(ID)*FCOOLI(ID)*DENS(ID)-REDIF(ID)*FLFIX(ID) END DO if(ioptab.lt.0) CALL ROSSTD(0) C C final evaluation of matrices and the global inversion C CALL RYBENE C do id=1,70,34 write(6,603) id,wm(id,id),wm(id,id+1),wr(id) end do 603 format('rybene ',8x,i4,1p4e11.3) DO ID=1,ND DO IDC=1,ND WM(ID,IDC)=WM(ID,IDC)-VAU(ID,IDC) END DO WR(ID)=WR(ID)-VAL(ID) END DO CALL LINEQS(WM,WR,CHANGT,ND,MDEPTH) C IF(.NOT.LTE.and.ifryb.gt.1) THEN lte=.true. iflev0=iflev iflev=1 do i=1,nlevel imodl(i)=imodl0(i) end do call levset do id=1,nd call steqeq(id,pop1,0) do i=1,nlevel babs(i,id)=un if(pop1(i).gt.0.) babs(i,id)=popul(i,id)/pop1(i) end do end do lte=.false. iflev=iflev0 do i=1,nlevel imodl(i)=imodl0(i) end do call levset end if C IF(.NOT.LTE.and.ifryb.gt.2) THEN DO IJ=1,NFREQ CALL OPACTR(IJ) CALL RTEFR1(IJ) CALL ALIFR1(IJ) CALL ROSSTD(IJ) CALL RYBMAT(IJ) ID=1 WR(ID)=VR(ID)-UB(ID)*CHANGT(ID)-UC(ID)*CHANGT(ID+1) DO ID=2,ND-1 WR(ID)=VR(ID)-UA(ID)*CHANGT(ID-1)-UB(ID)*CHANGT(ID)- * UC(ID)*CHANGT(ID+1) END DO ID=ND WR(ID)=VR(ID)-UA(ID)*CHANGT(ID-1)-UB(ID)*CHANGT(ID) CALL TRIDAG(RA,RB,RC,WR,AL,ND) RAD(IJ,ID)=RAD1(ID)+AL(ID) END DO END IF C CALL RYBCHN(CHANGT) c if(.not.lte.and.ifryb.gt.1) then lte=.true. iflev0=iflev iflev=1 do i=1,nlevel imodl(i)=imodl0(i) end do call levset do id=1,nd call steqeq(id,pop1,0) do i=1,nlevel popul(i,id)=pop1(i)*babs(i,id) end do end do lte=.false. iflev=iflev0 do i=1,nlevel imodl(i)=imodl0(i) end do call levset end if c RETURN END SUBROUTINE RYBMAT(IJ) C ===================== C C evaluation of the complete-linearization matrices in the Rybicki c formalism c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' COMMON/RYBMTX/RA(MDEPTH),RB(MDEPTH),RC(MDEPTH),VR(MDEPTH), * UA(MDEPTH),UB(MDEPTH),UC(MDEPTH), * VA(MDEPTH),VB(MDEPTH),VC(MDEPTH),WR(MDEPTH), * WM(MDEPTH,MDEPTH) common/dsctva/dsct1(mdepth),dscn1(mdepth) PARAMETER (SIXTH=UN/6.D0, * THIRD=UN/3.D0, * TWOTHR=TWO/3.D0) C IJT=IJFR(IJ) C C ============================================================== C 1. components corresponding to the radiative transfer equation C ============================================================== C C ----------------------------------- C ID = 1 - upper boundary condition C ID=1 DDM=(DM(ID+1)-DM(ID))*HALF DTM=UN/((ABSO1(ID)+ABSO1(ID+1))*DDM) DTM2=DTM*DTM ALF=DTM*DDM FD=TWO*FH(IJ) EXTI=EXTRAD(IJ) BET=(EXTI-FD*RAD1(ID))*DTM GAM=(FAK1(ID)*RAD1(ID)-FAK1(ID+1)*RAD1(ID+1))*TWO*DTM2 S0=(EMIS1(ID)+SCAT1(ID)*RAD1(ID))/ABSO1(ID) C1=ALF*(TWO*GAM-BET) B1=C1-S0/ABSO1(ID) UNQ=UN+TWO*DTM*Q0(IJ) c unq=un RB(ID)=-(UN+DTM*(FD+TWO*FAK1(ID)*DTM))+ * SCAT1(ID)/ABSO1(ID)*UNQ RC(ID)= TWO*FAK1(ID+1)*DTM2 VR(ID)= GAM-BET+RAD1(ID)-S0*UNQ UB(ID)= B1*DABT1(ID)+(DEMT1(ID)+ * DSCT1(ID)*RAD1(ID))/ABSO1(ID)*UNQ- * emis1(id)/abso1(id)**2*dabt1(id)*two*dtm*q0(ij)+ * dtm*s0*(uu0(ij)*dm(1)*dabt1(id)- * two*q0(ij)*dtm*ddm*dabt1(id)) UC(ID)= C1*DABT1(ID+1)-two*dtm*q0(ij)*s0*dtm*ddm*dabt1(id+1) c if(iubc.gt.0) then corf=half/dtm rb(id)=rb(id)*corf rc(id)=rc(id)*corf vr(id)=vr(id)*corf c1=(gam-rad1(id)+s0)*corf*alf b1=c1-corf*s0/abso1(id) UB(ID)= B1*DABT1(ID)+(DEMT1(ID)+ * DSCT1(ID)*RAD1(ID))/ABSO1(ID)*corf UC(ID)= C1*DABT1(ID+1) end if C C C ---------------------------------- C 1 < ID < ND - normal depth point C DO ID=2,ND-1 DDM=(DM(ID)-DM(ID-1))*HALF DDP=(DM(ID+1)-DM(ID))*HALF DZM=ABSO1(ID)+ABSO1(ID-1) DZP=ABSO1(ID)+ABSO1(ID+1) DTAUP=DZP*DDP DTAUM=DZM*DDM DTAU0=HALF *(DTAUP+DTAUM) FRD=FAK1(ID)*RAD1(ID) ALF1=(FRD-FAK1(ID+1)*RAD1(ID+1))/DTAUP/DTAU0 GAM1=(FRD-FAK1(ID-1)*RAD1(ID-1))/DTAUM/DTAU0 BET1=ALF1+GAM1 X1=HALF *BET1/DTAU0 A1=(GAM1+X1*DTAUM)/DZM C1=(ALF1+X1*DTAUP)/DZP B1=A1+C1 BS=UN CHIELM=SCAT1(ID-1) CHIEL0=SCAT1(ID) CHIELP=SCAT1(ID+1) S0=(EMIS1(ID)+CHIEL0*RAD1(ID))/ABSO1(ID) AS=0. CS=0. A2=0. C2=0. A3=0. C3=0. BET2=0. SM=0. SP=0. IF(MOD(ISPLIN,3).EQ.0) GO TO 60 SM=(EMIS1(ID-1)+RAD1(ID-1)*CHIELM)/ABSO1(ID-1) SP=(EMIS1(ID+1)+RAD1(ID+1)*CHIELP)/ABSO1(ID+1) IF(ISPLIN.EQ.1) THEN C C spline collocation (ISPLIN=1) C AS=DTAUM/DTAU0*SIXTH CS=DTAUP/DTAU0*SIXTH BS=0.666666666666667D0 ALF2=AS*(RAD1(ID-1)-SM) GAM2=CS*(RAD1(ID+1)-SP) BET2=ALF2+GAM2 X =HALF *BET2/DTAU0 A2=(GAM2-X*DTAUM)/DZM C2=(ALF2-X*DTAUP)/DZP ELSE C C Hermitian method (ISPLIN=2) C AS=DTAUP*DTAUP/DTAUM/DTAU0 CS=DTAUM*DTAUM/DTAUP/DTAU0 AL3=(RAD1(ID+1)-SP-RAD1(ID)+S0)*SIXTH GA3=(RAD1(ID-1)-SM-RAD1(ID)+S0)*SIXTH AV=AL3*CS CV=GA3*AS AS=(UN-HALF *AS)*SIXTH CS=(UN-HALF *CS)*SIXTH BS=UN-AS-CS X=(AV+CV)/DTAU0/4.D0 A2=(X*DTAUM+HALF *CV-AV)/DZM C2=(X*DTAUP+HALF *AV-CV)/DZP BET2=AS*(RAD1(ID-1)-SM)+CS*(RAD1(ID+1)-SP) END IF C C auxiliary quantities C B1=B1-(A2+C2) A1=A1-A2 C1=C1-C2 A2=AS/ABSO1(ID-1) C2=CS/ABSO1(ID+1) A3=A2*SM C3=C2*SP C 60 CONTINUE B2=BS/ABSO1(ID) B3=B2*S0 A1=A1-A3 B1=B1-B3 C1=C1-C3 C C *** elements of the matrices C RA(ID)= FAK1(ID-1)/DTAUM/DTAU0-AS*(UN-CHIELM/ABSO1(ID-1)) RB(ID)=-FAK1(ID)/DTAU0*(UN/DTAUP+UN/DTAUM)- * BS*(UN-CHIEL0/ABSO1(ID)) RC(ID)= FAK1(ID+1)/DTAUP/DTAU0-CS*(UN-CHIELP/ABSO1(ID+1)) VR(ID)= BET1+BET2+BS*(RAD1(ID)-S0) UA(ID)= A1*DABT1(ID-1)+A2*(DEMT1(ID-1)+DSCT1(ID-1)*RAD1(ID-1)) UB(ID)= B1*DABT1(ID)+B2*(DEMT1(ID)+DSCT1(ID)*RAD1(ID)) UC(ID)= C1*DABT1(ID+1)+C2*(DEMT1(ID+1)+DSCT1(ID+1)*RAD1(ID+1)) END DO C C ---------------------------------- C ID=ND - lower boundary condition C ID=ND DDM=HALF*(DM(ID)-DM(ID-1)) T0=TEMP(ID) TM=TEMP(ID-1) IF(IBC.GT.0.AND.IBC.LT.4.AND.IDISK.EQ.0) THEN DTM=UN/((ABSO1(ID-1)+ABSO1(ID))*DDM) DTM2=DTM*DTM FD=TWO*FHD(IJT) FR=FREQ(IJT) FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 X0=HK*FR/T0 XM=HK*FR/TM PLAND=BNU/(EXP(X0)-UN) PLANM=BNU/(EXP(XM)-UN) DPLDT0=PLAND/(UN-EXP(-X0))*X0/T0 DPLDTM=PLANM/(UN-EXP(-XM))*XM/TM DPLAN=(PLAND-PLANM)*DTM ALF=DTM*DDM BET=(PLAND-FD*RAD1(ID))*DTM GAM=(FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1)- * THIRD*(PLAND-PLANM))*TWO*DTM2 S0=(EMIS1(ID)+SCAT1(ID)*RAD1(ID))/ABSO1(ID) A1=ALF*(TWO*GAM-BET) B1=A1-S0/ABSO1(ID) RA(ID)= TWO*FAK1(ID-1)*DTM2 RB(ID)=-(UN+DTM*(FD+TWO*FAK1(ID)*DTM))+ * SCAT1(ID)/ABSO1(ID) VR(ID)= GAM-BET+RAD1(ID)-S0 UA(ID)= B1*DABT1(ID-1) * +(DEMT1(ID-1)+ * DSCT1(ID-1)*RAD1(ID-1))/ABSO1(ID-1) * -DPLDTM*DTM2*TWOTHR UB(ID)= B1*DABT1(ID)+(DEMT1(ID)+ * DSCT1(ID)*RAD1(ID))/ABSO1(ID)+ * DPLDT0*DTM*(UN+TWOTHR*DTM) C if(ifryb.gt.0) then DTM=UN/((ABSO1(ID-1)+ABSO1(ID))*DDM) FR=FREQ(IJT) FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 X0=HK*FR/T0 XM=HK*FR/TM PLAND=BNU/(EXP(X0)-UN) PLANM=BNU/(EXP(XM)-UN) DPLDT0=PLAND/(UN-EXP(-X0))*X0/T0 DPLDTM=PLANM/(UN-EXP(-XM))*XM/TM GAM=(FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1)- * THIRD*(PLAND-PLANM))*DTM S0=(EMIS1(ID)+SCAT1(ID)*RAD1(ID))/ABSO1(ID) BS=HALF/DTM BET=BS*(RAD1(ID)-S0) A1=(GAM-BET)*DTM*DDM B1=A1-BS*S0/ABSO1(ID) RA(ID)=FAK1(ID-1)*DTM RB(ID)=-FAK1(ID)*DTM-BS*(UN-SCAT1(ID)/ABSO1(ID))-FHD(IJT) VR(ID)=GAM+BET-HALF*PLAND+FHD(IJT)*RAD1(ID) UA(ID)=A1*DABT1(ID-1)-DPLDTM*DTM*THIRD UB(ID)=B1*DABT1(ID)+ * BS*(DEMT1(ID)+DSCT1(ID)*RAD1(ID))/ABSO1(ID)+ * (HALF+THIRD*DTM)*DPLDT0 end if C ELSE C C for disks - C lower b.c. expresses just I(taumax,-mu,nu)=I(taumax,+mu,nu) C DZM=ABSO1(ID)+ABSO1(ID-1) FRD=FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1) DTAUM=DZM*DDM GAM1=FRD/DTAUM A1=GAM1/DZM AS=0. BS=DTAUM*HALF S0=(EMIS1(ID)+SCAT1(ID)*RAD1(ID))/ABSO1(ID) GAM2=BS*(RAD1(ID)-S0) X1=GAM2/DZM A1=A1-X1 B2=BS/ABSO1(ID) B1=A1-B2*S0 RA(ID)=FAK1(ID-1)/DTAUM-AS*(UN-SCAT1(ID-1)/ABSO1(ID-1)) RB(ID)=-FAK1(ID)/DTAUM-BS*(UN-SCAT1(ID)/ABSO1(ID)) UA(ID)=A1*DABT1(ID-1)+A2*(DEMT1(ID-1)+DSCT1(ID-1)*RAD1(ID-1)) UB(ID)=B1*DABT1(ID)+B2*(DEMT1(ID)+DSCT1(ID)*RAD1(ID)) VR(ID)=GAM1+GAM2 END IF C C C ===================================================== C components corresponding to the radiative equilibrium C ===================================================== C DO ID=1,ND C C ********* integral equation part C IF(REINT(ID).GT.0.) THEN HEAT = ABSO1(ID)-SCAT1(ID) DHEAT = (DABT1(ID)-DSCT1(ID))*RAD1(ID) WDR = W(IJ)*dens(id)*reint(id) VB(ID) = HEAT*WDR WM(ID,ID)= WM(ID,ID)+(DHEAT-DEMT1(ID))*WDR WR(ID) = WR(ID)-(HEAT*RAD1(ID)-EMIS1(ID))*WDR END IF END DO C C ********* differential equation part C ID=1 IF(REDIF(ID).GT.0.) THEN WF=W(IJ)*FH(IJT)*REDIF(ID) VB(ID)=VB(ID)+WF WR(ID)=WR(ID)-WF*RAD1(ID) END IF c c original variant with 1st-order mid-point differences c if(icentr.eq.0) then nd1=nd if(ilbc.ne.0) nd1=nd-1 DO ID=2,nd1 IF(REDIF(ID).GT.0.) THEN DDM=(DM(ID)-DM(ID-1))*HALF OMEG0=ABSO1(ID) OMEGM=ABSO1(ID-1) DTAUM=(OMEG0+OMEGM)*DDM FRD=FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1) GAMR=FRD/DTAUM*redif(id) A1=GAMR/(OMEG0+OMEGM) VA(ID) =-W(IJ)*FAK1(ID-1)/DTAUM*redif(id) VB(ID) = VB(ID)+W(IJ)*FAK1(ID)/DTAUM*redif(id) WM(ID,ID-1)= WM(ID,ID-1)-A1*W(IJ)*DABT1(ID-1) WM(ID,ID) = WM(ID,ID)-A1*W(IJ)*DABT1(ID) WR(ID) = WR(ID)-W(IJ)*GAMR END IF END DO c if(ilbc.gt.0) then id=nd IF(REDIF(ID).GT.0.) THEN DDM=(DM(ID)-DM(ID-1))*HALF DTAUM=(ABSO1(ID)+ABSO1(ID-1))*DDM*3.D0 FR=FREQ(IJT) FR15=FR*1.D-15 BNU=BN*FR15*FR15*FR15 X0=HK*FR/TEMP(ID) XM=HK*FR/TEMP(ID-1) PLAND=BNU/(EXP(X0)-UN) PLANM=BNU/(EXP(XM)-UN) DPLDT0=PLAND/(UN-EXP(-X0))*X0/TEMP(ID) DPLDTM=PLANM/(UN-EXP(-XM))*XM/TEMP(ID-1) FLX=(PLAND-PLANM)/DTAUM*redif(id) A1=FLX/(ABSO1(ID)+ABSO1(ID-1)) WM(ID,ID-1)= WM(ID,ID-1)+W(IJ)*(DPLDTM-A1*DABT1(ID-1)) WM(ID,ID) = WM(ID,ID)+W(IJ)*(DPLDT0-A1*DABT1(ID)) WR(ID) = WR(ID)-W(IJ)*FLX END IF end if c c centered difference variant c else do id=2,nd-1 if(redif(id).gt.0) then wwr=w(ij)*redif(id) ddm=half*(dm(id)-dm(id-1)) ddp=half*(dm(id+1)-dm(id)) dtm=(abso1(id-1)+abso1(id))*ddm dtp=(abso1(id+1)+abso1(id))*ddp dt0=dtm+dtp frm=fak1(id)*rad1(id)-fak1(id-1)*rad1(id-1) frp=fak1(id+1)*rad1(id+1)-fak1(id)*rad1(id) alp=dtp/dtm/dt0 gam=dtm/dtp/dt0 flx=alp*frm+gam*frp c c matrix elements c va(id)=-wwr*fak1(id-1)*alp vb(id)=vb(id)+wwr*fak1(id)*(alp-gam) vc(id)=wwr*fak1(id+1)*gam c dmtm=ddm/(dtm*dtm) dmtp=ddp/(dtp*dtp) rm=dtm/dt0 rp=dtp/dt0 wm(id,id-1) = wm(id,id-1)+wwr*dabt1(id-1)*dmtm* * (rm*rm*frp-(un+rm)*frm) wm(id,id) = wm(id,id)+wwr*dabt1(id)* * ((dmtp*rp*rp-dmtm*rp*(un+rm))*frm + * (dmtm*rm*rm-dmtp*rm*(un+rp)*frp)) wr(id)=wr(id)-wwr*flx end if end do c id=nd IF(REDIF(ID).GT.0.) THEN DDM=(DM(ID)-DM(ID-1))*HALF DTAUM=(ABSO1(ID)+ABSO1(ID-1))*DDM FRD=FAK1(ID)*RAD1(ID)-FAK1(ID-1)*RAD1(ID-1) FLX=FRD/DTAUM*redif(id) A1=FLX/(ABSO1(ID)+ABSO1(ID-1)) VA(ID) =-W(IJ)*FAK1(ID-1)/DTAUM*redif(id) VB(ID) = VB(ID)+W(IJ)*FAK1(ID)/DTAUM*redif(id) WM(ID,ID-1)= WM(ID,ID-1)-A1*W(IJ)*DABT1(ID-1) WM(ID,ID) = WM(ID,ID)-A1*W(IJ)*DABT1(ID) WR(ID) = WR(ID)-W(IJ)*FLX END IF end if c if(nretc.gt.0) then do id=1,nretc wr(id)=0. vb(id)=0. va(id)=0. wm(id,id)=1. if(id.gt.1) wm(id,id-1)=0. end do end if RETURN END C C C ************************************************************* C C SUBROUTINE RYBENE C ================= C C complementing partial matrices of complete linearization c corresponding to the contribution of ALI frequencies and the c convection to the radiative/convective equilibrium equation in c the Rybicki formalism c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' COMMON/CUBCON/ACNV,BCNV,DEL,GRDADB,DELMDE,RHO,FLXTOT,GRAVD COMMON/RYBMTX/RA(MDEPTH),RB(MDEPTH),RC(MDEPTH),VR(MDEPTH), * UA(MDEPTH),UB(MDEPTH),UC(MDEPTH), * VA(MDEPTH),VB(MDEPTH),VC(MDEPTH),WR(MDEPTH), * WM(MDEPTH,MDEPTH) common/deridt/dert C C contribution from the radiative equilibrium part of the energy eq. c flxto0=sig4p*teff**4 DO ID=1,ND WR(ID)=WR(ID)+FCOOL(ID) IF(IDISK.EQ.1) WR(ID)=WR(ID)-reint(id)*TVISC(ID) if(reint(id).gt.0.) then IF(ID.GT.1) WM(ID,ID-1) * =WM(ID,ID-1)+AREIT(ID)*dens(id)*reint(id) WM(ID,ID) =WM(ID,ID) + REIT(ID)*dens(id)*reint(id) IF(IDISK.EQ.1) WM(ID,ID)=WM(ID,ID)+ * DTVIST(ID)*reint(id) IF(ID.LT.ND) WM(ID,ID+1) * =WM(ID,ID+1)+CREIT(ID)*dens(id)*reint(id) end if c if(idisk.eq.0) then flxtot=flxto0 gravd=grav else flxtot=flxto0*(1.d0-thetav(id)) gravd=qgrav*zd(id) end if c if(redif(id).gt.0) then WR(ID)=WR(ID)+flxtot*redif(id) IF(ID.GT.1) WM(ID,ID-1)=WM(ID,ID-1)+REDTM(ID)*REDIF(ID) WM(ID,ID)= WM(ID,ID)+ REDT (ID)*REDIF(ID) IF(ID.LT.ND) WM(ID,ID+1)=WM(ID,ID+1)+REDTP(ID)*REDIF(ID) end if END DO c C contribution from convection C IF(HMIX0.LE.0.OR.ICONV.LE.0) RETURN if(dert.eq.0.) dert=0.01 DO 10 ID=idconz,ND T=TEMP(ID) P=PTOTAL(ID) TM=TEMP(ID-1) PM=PTOTAL(ID-1) pr0=0. if(icentr.eq.0.or.id.eq.nd) then T0=SQRT(T*TM) P0=SQRT(P*PM) AB0=SQRT(ABROSD(ID)*ABROSD(ID-1)) pr0=sqrt(pradt(id)*pradt(id-1))*pck DLP=UN/LOG(P/PM) DLT=LOG(T/TM)*DLP DELTA(ID)=DLT DDT0= DLP/T DDTM=-DLP/TM CALL CONVEC(ID,T0,P0,P0-pr0,pr0,AB0,DLT,FLXCNV,VCON) FLXC(ID)=FLXCNV DHCDD=0. IF(DELMDE.GT.0.) THEN bb=bcnv*half cord=un-bb/sqrt(bb*bb+(dlt-grdadb)) DHCDD=1.5D0/DELMDE*FLXCNV*cord END IF if(id.lt.icbegp-2) then flxc(id)=0. go to 10 end if T1=(un+dert)*T0 CALL CONVEC(ID,T1,P0,p0-pr0,pr0,AB0,DLT,FLXC1,VCON) DHCDT0=(FLXC1-FLXCNV)*HALF/dert DHCDT =DHCDT0/T+DHCDD*DDT0 DHCDTM=DHCDT0/TM+DHCDD*DDTM else dlm=log(p/pm) dlp=log(ptotal(id+1)/p) dl0=dlm+dlp palf=dlp/dlm/dl0 pgam=dlm/dlp/dl0 dlt=palf*log(t/tm)+pgam*log(temp(id+1)/t) delta(id)=dlt ddtm=-palf/tm ddtp=pgam/temp(id+1) ddt0=(palf-pgam)/t pr0=sqrt(pradt(id)*pradt(id-1))*pck call convec(id,t,p,p-pr0,pr0,abrosd(id),dlt,flxcnv,vcon) flxc(id)=flxcnv dhcdd=0. IF(DELMDE.GT.0.) then bb=bcnv*half cord=un-bb/sqrt(bb*bb+(dlt-grdadb)) DHCDD=1.5D0/DELMDE*FLXCNV*cord end if if(id.lt.icbegp-2) then flxc(id)=0. go to 10 end if T1=(un+dert)*T CALL CONVEC(ID,T1,P,p-pr0,pr0,abrosd(id),DLT,FLXC1,VCON) DHCDT0=(FLXC1-FLXCNV)*HALF/dert DHCDT =DHCDT0/T+DHCDD*DDT0 DHCDTM=DHCDD*DDTM DHCDTP=DHCDD*DDTP end if C C additional terms in matrix WM C C ** 1. differential equation form C if(redif(id).gt.0) then WM(ID,ID-1)=WM(ID,ID-1)+DHCDTM*redif(id) WM(ID,ID)= WM(ID,ID)+DHCDT*redif(id) WR(ID)=WR(ID)-FLXC(ID)*redif(id) if(icentr.ne.0.and.id.lt.nd) then WM(ID,ID+1)=WM(ID,ID+1)+DHCDTP*redif(id) end if END IF C C ** 2. integral equation form C if(reint(id).gt.0.) then if(id.lt.nd) then TP=TEMP(ID+1) PTP=PTOTAL(ID+1) T0=SQRT(T*TP) P0=SQRT(P*PTP) pr0=sqrt(pradt(id)*pradt(id-1))*pck AB0=SQRT(ABROSD(ID)*ABROSD(ID+1)) DLP=UN/LOG(PTP/P) DLT=LOG(TP/T)*DLP DDTP0= DLP/TP DDTPM=-DLP/T CALL CONVEC(ID,T0,P0,p0-pr0,pr0,AB0,DLT,FLXCNV,VCON) DHCDDP=0. IF(DELMDE.GT.0.) DHCDDP=1.5D0/DELMDE*FLXCNV T1=1.001D0*T0 CALL CONVEC(ID,T1,P0,p0-pr0,pr0,AB0,DLT,FLXC1,VCON) DHCDT0=(FLXC1-FLXCNV)*500. DHCDTP=DHCDT0/TP+DHCDDP*DDTP0 DHCDTU=DHCDT0/T+DHCDDP*DDTPM C C additional terms in matrices A and B (the row corresponding to C energy balance, i.e. T) due to convection C DELM=(DM(ID+1)-DM(ID-1))*HALF RDELM=DENS(ID)/DELM*reint(id) IF(ICONV.GT.0) THEN WM(ID,ID-1)=WM(ID,ID-1)-RDELM*DHCDTM WM(ID,ID)=WM(ID,ID)+RDELM*(DHCDTP-DHCDTU) WM(ID,ID+1)=WM(ID,ID+1)+RDELM*DHCDTP END IF WR(ID)=WR(ID)-RDELM*(FLXCNV-FLXC(ID)) ELSE TP=TEMP(ID-2) PTP=PTOTAL(ID-2) T0=SQRT(T*TP) P0=SQRT(P*PTP) pr0=sqrt(pradt(id)*pradt(id-1))*pck AB0=SQRT(ABROSD(ID)*ABROSD(ID-2)) DLP=UN/LOG(PTP/P) DLT=LOG(TP/T)*DLP DDTP0= DLP/TP DDTPM=-DLP/T CALL CONVEC(ID,T0,P0,p0-pr0,pr0,AB0,DLT,FLXCNV,VCON) if(flxcnv.le.0.) go to 10 DHCDDP=0. IF(DELMDE.GT.0.) DHCDDP=1.5D0/DELMDE*FLXCNV T1=1.001D0*T0 CALL CONVEC(ID,T1,P0,p0-pr0,pr0,AB0,DLT,FLXC1,VCON) DHCDTP=(FLXC1-FLXCNV)*1.D3/T0*HALF+DHCDDP*DDTP0 C C additional terms in matrices A and B (the row corresponding to C energy balance, i.e. T) due to convection C DELM=(DM(ID)-DM(ID-2))*HALF RDELM=DENS(ID)/DELM*reint(id) DELHC=WMM(ID)/DELM*(FLXCNV-FLXC(ID)) WM(ID,ID-1)=WM(ID,ID-1)+RDELM*(DHCDT-DHCDTP) WM(ID,ID)=WM(ID,ID)+RDELM*DHCDT WR(ID)=WR(ID)-RDELM*(FLXC(ID)-FLXCNV) END IF END IF 10 CONTINUE c RETURN END C C C ************************************************************* C C SUBROUTINE RYBCHN(CHANGT) C ========================= C C handling relative changes in the Rybicki formalism c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ARRAY1.FOR' common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) common/rybpgs/CS(MDEPTH),PRAD2D(MDEPTH),F1HE DIMENSION CHANGT(MDEPTH),TMPOLD(MDEPTH) C CHMX=0. CHN=0. JJR=0 DPLP=DPSILT-UN DPLM=UN/DPSILT-UN NRE=NFREQE+1 IF(ITER.EQ.1) WRITE(9,800) DO ID=ND,1,-1 CHT=CHANGT(ID)/TEMP(ID) CHAN=CHT IF(CHAN.LE.DPLM) CHAN=DPLM IF(CHAN.GT.DPLP) CHAN=DPLP TMPOLD(ID)=TEMP(ID) TEMP(ID)=TEMP(ID)*(CHAN+UN) PSI0(NRE)=TEMP(ID) PSY0(NRE,ID)=PSI0(NRE) WRITE(9,801) ITER,ID,CHT,chn,chN,CHN,chT,jjr,jjr IF(ABS(CHT).GT.CHMX) CHMX=ABS(CHT) END DO c if(ioptab.le.-2) go to 10 if(nretc.lt.0) then do id=-nretc,1,-1 temp(id)=temp(id+1) PSY0(NRE,ID)=PSY0(NRE,ID+1) end do end if c if(idisk.eq.0) then if(ifprad.gt.0) then DO ID=1,ND T=TEMP(ID) dtod=temp(id)/tmpold(id)-un if(dtod.gt.0.2) dtod=0.2 if(dtod.lt.-0.2) dtod=-0.2 gfac=un+4.*dtod if(idisk.eq.0) then if(id.eq.1) then pgs(id)=dm(id)*(grav-grd(id)*gfac) else pgs(id)=pgs(id-1)+grav*(dm(id)-dm(id-1))- * pck*grd(id)*gfac end if end if c if(iprybc.gt.0) c write(6,603) iter,id,grd(id),gfac,pgs(id),dtod,temp(id) c 603 format(2i5,1p6e13.5) c AN=PGS(ID)/BOLK/T CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE END DO else DO ID=1,ND T=TEMP(ID) PGS(ID)=DM(ID)*GRAV AN=PGS(ID)/BOLK/T CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE END DO end if else pgpre=pgs(1) id=1 do id=2,nd pgpre=pgs(id) dtod=temp(id)/tmpold(id)-un if(dtod.gt.0.2) dtod=0.2 if(dtod.lt.-0.2) dtod=-0.2 gfac=un+4.*dtod grv=(dm(id)-dm(id-1))*qgrav*(zd(id)+zd(id-1))*half pgs(id)=pgs(id-1)-pck*grd(id)*gfac+grv pgs0(id)=pgs(id) end do pgs0(1)=pgs(1) c itpg=0 5 continue z1=zd(1) itpg=itpg+1 call pgset(1) c DO ID=1,ND T=TEMP(ID) AN=ANTP(ID) CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE PGS(ID)=BOLK*T*AN pgs0(id)=pgs(id) END DO c c recomputing the z-distance c do id=nd-1,1,-1 ddp=(dm(id+1)-dm(id))*half zd(id)=zd(id+1)+ddp/dens(id+1)+ddp/dens(id) end do c if(abs((zd(1)-z1)/z1).lt.1.e-3.or.itpg.gt.5) go to 8 c do id=1,nd cs(id)=pgs(id)/dens(id)/temp(id) end do hr1=grd(1)/qgrav hg1=sqrt(two*cs(1)*temp(1)/qgrav) x=(zd(1)-hr1)/hg1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1HE=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1HE=HALF*(UN-HALF/X/X)/X END IF if(abs((zd(1)-z1)/z1).lt.1.e-4.or.itpg.gt.5) go to 8 go to 5 8 continue end if 10 continue C C STOP if changes become too large C IF(ITER.NE.1 .AND. ABS(CHMX).GT.1.D16) THEN WRITE(6,610) ITER,CHMX WRITE(10,610) ITER,CHMX STOP END IF C C Finally, set up quantity LFIN that indicates whether or not C this iteration of complete linearization is the last one C LFIN=ABS(CHMX).LE.CHMAX.OR.ITER.GE.NITER c 610 FORMAT(' **** STOP in RYBSOL after ITER',I4,/, * ' Max change:',1PE12.2) 800 FORMAT(' RELATIVE CHANGES OF VECTOR PSI'/ * ' ITER ID TEMP NE POP RAD MAXIMUM', * ' ilev ifr',/) 801 FORMAT(2I5,1P5D10.2,2I5) RETURN END C C C ************************************************************* C C SUBROUTINE TRIDAG(A,B,C,R,U,N) C ============================== C C solution of the tridiagonal system c c from Numerical recipes, Sect 2.4 c INCLUDE 'IMPLIC.FOR' DIMENSION A(N),B(N),C(N),R(N),U(N),GAM(N) C BET=B(1) U(1)=R(1)/BET DO J=2,N GAM(J)=C(J-1)/BET BET=B(J)-A(J)*GAM(J) U(J)=(R(J)-A(J)*U(J-1))/BET END DO DO J=N-1,1,-1 U(J)=U(J)-GAM(J+1)*U(J+1) END DO RETURN END C C C ****************************************************************** C C SUBROUTINE OPACTR(IJ) C ===================== C C Absorption and emission coefficients and their derivatives C for the use by Rybicki variant (RYBSOL) C C This procedure is very similar to OPACT1, the only difference is C the evaluation of derivatives C C Input: C IJ - depth index C Output: C ABSO1 - array of absorption coefficient C EMIS1 - array of emission coefficient C SCAT1 - array of scattering coefficient C Dxxy - array of derivatives of xx (=AB for absorption, =EM for C emission, =SC for scattering) coefficient wrt T C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ALIPAR.FOR' INCLUDE 'ATOMIC.FOR' PARAMETER (DELT=1.D-2) common/dsctva/dsct1(mdepth),dscn1(mdepth) common/hmolab/anh2(mdepth),anhm(mdepth) common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) DIMENSION ABSOPP(MFREQ,MDEPTH),SCATPP(MFREQ,MDEPTH), * EMISPP(MFREQ,MDEPTH),AES(MLEVEL,MLEVEL),BES(MLEVEL), * ELEC0(MDEPTH),DENS0(MDEPTH),AN0(MDEPTH), * BFABS(MLEVEL,MDEPTH),ELERAT(MDEPTH), * POPUL0(MLEVEL,MDEPTH),POPLTE(MLEVEL) c C compute opacities at T+DELTA(T) - for derivatives C IF(IJ.EQ.1) THEN C C first, sab\ve absolute b-factors (for evaluating C derivatives w.r.t. T) C IF(.NOT.LTE) THEN LTE0=LTE DO ID=1,ND CALL WNSTOR(ID) CALL SABOLF(ID) CALL RATMAL(ID,AES,BES) CALL LEVSOL(AES,BES,POPLTE,IIFOR,NLEVEL,0) ELERAT(ID)=ELEC(ID)/(DENS(ID)/WMM(ID)+ELEC(ID)) DO I=1,NLEVEL POPUL0(I,ID)=POPUL(I,ID) BFABS(I,ID)=1. IF(POPLTE(I).GT.0.) BFABS(I,ID)=POPUL(I,ID)/POPLTE(I) END DO END DO LTE=LTE0 END IF C C opacities at T+DELTA(T) - for derivatives C for that, one needs also to estimate ELEC and DENS for T+DELTA(T) C DO ID=1,ND TEMP(ID)=TEMP(ID)*(UN+DELT) ELEC0(ID)=ELEC(ID) DENS0(ID)=DENS(ID) an0(id)=dens(id)/wmm(id)+elec(id) END DO CALL TDPINI DO ID=1,ND T=TEMP(ID) if(ifprad.gt.0) then if(idisk.eq.0) then if(id.eq.1) then pgs(id)=dm(id)*(grav-grd(id)*(un+4.*delt)) else pgs(id)=pgs(id-1)+grav*(dm(id)-dm(id-1)) * -pck*grd(id)*(un+4.*delt) end if end if end if end do do id=1,nd t=temp(id) an=pgs(id)/bolk/t if(idisk.gt.0) an=antp(id) c IF(LTE) THEN CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) c ELSE c ANE=AN*ELERAT(ID) c END IF RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE CALL WNSTOR(ID) IF(LTE.OR.IFMOL.GT.0) THEN CALL STEQEQ(ID,POP,1) ELSE CALL SABOLF(ID) CALL RATMAL(ID,AES,BES) CALL LEVSOL(AES,BES,POPLTE,IIFOR,NLEVEL,0) DO I=1,NLEVEL POPUL(I,ID)=POPLTE(I)*BFABS(I,ID) END DO END IF END DO CALL OPAINI(1) IOPLY0=IOPLYM IOPLYM=0 DO IJP=1,NFREQ CALL OPACF1(IJP) DO ID=1,ND ABSOPP(IJP,ID)=ABSO1(ID)/DENS(ID) EMISPP(IJP,ID)=EMIS1(ID)/DENS(ID) SCATPP(IJP,ID)=SCAT1(ID)/DENS(ID) END DO END DO IOPLYM=IOPLY0 C C reset the original structural parameters C DO ID=1,ND TEMP(ID)=TEMP(ID)/(UN+DELT) END DO CALL TDPINI c IF(IDISK.EQ.0) THEN DO ID=1,ND ELEC(ID)=ELEC0(ID) DENS(ID)=DENS0(ID) T=TEMP(ID) AN=DENS0(ID)/WMM(ID)+ELEC0(ID) PGS(ID)=AN*BOLK*T END DO ELSE call pgset(1) DO ID=1,ND T=TEMP(ID) AN=ANTP(ID) CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE PGS(ID)=AN*BOLK*T END DO END IF DO ID=1,ND CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) c DO I=1,NLEVEL c POPUL(I,ID)=POPUL0(I,ID) c END DO END DO CALL OPAINI(1) END IF C C opacity at the original T, and derivatives C CALL OPACF1(IJ) DO ID=1,ND ABSO1(ID)=ABSO1(ID)/DENS(ID) SCAT1(ID)=SCAT1(ID)/DENS(ID) EMIS1(ID)=EMIS1(ID)/DENS(ID) DABT1(ID)=(ABSOPP(IJ,ID)-ABSO1(ID))/T/DELT DSCT1(ID)=(SCATPP(IJ,ID)-SCAT1(ID))/T/DELT XKF(ID)=EXP(-HKT1(ID)*FREQ(IJ)) XKF1(ID)=UN-XKF(ID) XKFB(ID)=XKF(ID)*BNUE(IJ) IF(LTE.OR.IFMOL.GT.0) THEN PLAN=XKFB(ID)/XKF1(ID) DPLAN=PLAN/XKF1(ID)*HKT1(ID)*FREQ(IJ)/TEMP(ID) DEMT1(ID)=(DABT1(ID)-DSCT1(ID))*PLAN+ * (ABSO1(ID)-SCAT1(ID))*DPLAN ELSE DEMT1(ID)=(EMISPP(IJ,ID)-EMIS1(ID))/T/DELT END IF END DO C RETURN END C C ****************************************************************** C C SUBROUTINE RYBHEQ C ================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) common/rybpgs/CS(MDEPTH),PRAD2D(MDEPTH),F1HE dimension pradfc(mdepth) c DO ID=1,ND GRD(ID)=0. pra(id)=0. pradt(id)=0. pradfc(id)=0. END DO PRD0=0. c if(ifprad.gt.0) then CALL OPAINI(1) DO IJ=1,NFREQ CALL OPACF1(IJ) CALL RTEFR1(IJ) if(.not.lskip(1,ij)) * GRD(1)=GRD(1)+W(IJ)*ABSO1(1)*FH(IJ)*RAD1(1) DO ID=2,ND if(.not.lskip(id,ij)) then GRD(ID)=GRD(ID)+(RAD1(ID)*FAK1(ID)- * RAD1(ID-1)*FAK1(ID-1))*W(IJ) pra(id)=pra(id)+RAD1(ID)*FAK1(ID)*W(IJ) end if END DO pra(1)=pra(1)+RAD1(1)*FAK1(1)*W(IJ)-ABSO1(1)*W(IJ)* * (RAD1(1)*FH(IJ)-HEXTRD(IJ)) END DO if(idisk.eq.0) then GRD(1)=PCK*GRD(1)/DENS(1) else grd(1)=pck*grd(2) end if PRD0=PRD0*DENS(1)*DM(1)*PCK c do id=1,nd pra(id)=pra(id)*pck pradt(id)=pra(id) pradfc(id)=pra(id)/(2.5213e-15*temp(id)**4) end do C do id=2,nd-1 dmm=un/(dm(id)-dm(id-1)) dmp=un/(dm(id+1)-dm(id)) dm0=two/(dm(id+1)-dm(id-1)) qq=((pra(id+1)-pra(id))*dmp-(pra(id)-pra(id-1))*dmm)*dm0 prad2d(id)=qq end do prad2d(1)=prad2d(2) prad2d(nd)=0. end if c if(idisk.eq.0) then PGS0(1)=DM(1)*(GRAV-GRD(1)) DO ID=2,ND PGS0(ID)=PGS0(ID-1)-PCK*GRD(ID)+GRAV*(DM(ID)-DM(ID-1)) END DO else pgs0(1)=pgs(1) do id=2,nd grv=(dm(id)-dm(id-1))*qgrav*(zd(id)+zd(id-1))*half pgs0(id)=pgs0(id-1)-pck*grd(id)+grv end do end if if(iprybh.gt.0) write(6,603) iter 603 format(/' rybheq in iter',i4, * ' dm,dens,pgs0,pra,pradfc,grd,grad,ggrav'/) c if(iprybh.gt.0) then do id=1,nd if(id.eq.1) then gra=grd(id) ggr=qgrav*zd(id) else gra=pck*grd(id)/(dm(id)-dm(id-1)) ggr=qgrav*(zd(id)+zd(id-1))*half end if if(idisk.eq.0) then write(6,604) id,dm(id),dens(id),pgs0(id),pra(id), * pradfc(id),grd(id),gra else write(6,604) id,dm(id),dens(id),pgs0(id),pra(id), * pradfc(id),grd(id),gra,ggr,zd(id) end if end do end if 604 format(i4,1p9e13.4) C if(idisk.eq.0) then DO ID=1,ND T=TEMP(ID) pgs(id)=pgs0(id) AN=PGS(ID)/BOLK/T CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1) RHO=WMM(ID)*(AN-ANE) DENS(ID)=RHO ELEC(ID)=ANE CALL WNSTOR(ID) CALL STEQEQ(ID,POP,1) c IF(.NOT.LCHC.and.iter.lt.ielcor) CALL ELCOR(ID) END DO else c c -------------------------- c the rest is only for disks c -------------------------- c cprad=2.5213e-15 do id=1,nd cs(id)=pgs0(id)/dens(id)/temp(id) c pi(id)=cprad*pradfc(id) end do c hr1=grd(1)/qgrav hg1=sqrt(two*cs(1)*temp(1)/qgrav) x=(zd(1)-hr1)/hg1 IF(X.LT.3.) THEN IF(X.LT.0.) X=0. F1HE=8.86226925D-1*EXP(X*X)*ERFCX(X) ELSE F1HE=HALF*(UN-HALF/X/X)/X END IF c ntemp=2 call pgset(ntemp) c do id=1,nd pgs(id)=pgs0(id) ptotal(id)=pgs0(id)+pra(id) end do c END IF C RETURN END c c c ***************************************************************** c c subroutine pgset(ntemp) c ======================= C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ITERAT.FOR' INCLUDE 'MODELQ.FOR' common/grdpra/GRD(MDEPTH),pra(mdepth),pgs0(mdepth),ANTP(MDEPTH) common/rybpgs/CS(MDEPTH),PRAD2D(MDEPTH),F1HE dimension a(mdepth),b(mdepth),c(mdepth),v(mdepth), * p(mdepth),pnew(mdepth),delp(mdepth) dimension temp0(mdepth),pg0(mdepth) C do id=1,nd p(id)=pgs0(id) temp0(id)=temp(id) end do c item=0 10 continue item=item+1 c itp=0 20 continue itp=itp+1 c id=1 b(id)=un v(id)=dm(1)*sqrt(cs(id)*temp(id)*qgrav*half)/f1he-p(id) do id=2,nd-1 dmm=un/(dm(id)-dm(id-1)) dmp=un/(dm(id+1)-dm(id)) dm0=two/(dm(id+1)-dm(id-1)) alp=dmm*dm0 gam=dmp*dm0 bet=alp+gam QQ=PRAD2D(ID) a(id)=p(id)*alp c(id)=p(id)*gam b(id)=p(id-1)*alp+p(id+1)*gam-two*p(id)*bet+qq v(id)=-p(id-1)*p(id)*alp-p(id+1)*p(id)*gam+p(id)**2*bet- * p(id)*qq-cs(id)*temp(id)*qgrav end do c id=nd alp=two/(dm(id)-dm(id-1))**2 a(id)=alp*p(id) b(id)=alp*(p(id-1)-two*p(id)) v(id)=alp*p(id)*(p(id)-p(id-1))-cs(id)*temp(id)*qgrav c call tridag(a,b,c,v,delp,nd) c pdmax=0. do id=1,nd pnew(id)=p(id)+delp(id) pd=(pnew(id)-p(id))/p(id) pnew(id)=max(pnew(id),0.5*p(id)) pdmax=max(pdmax,abs(pd)) c if(ippgst.ge.2) write(6,602) iter,item,itp,id,p(id),pnew(id),pd c 602 format('pgset',4i4,1p3e12.4) p(id)=pnew(id) end do c if(ippgst.ge.1) write(6,606) iter,item,itp,pdmax c 606 format('pgset iter,itp,pdmax:',3i4,1pe10.2) c if(itp.lt.30.and.pdmax.gt.1.e-4) go to 20 c if(item.lt.ntemp) then do id=1,nd temp0(id)=temp(id) pg0(id)=p(id) temp(id)=temp(id)*1.01 end do go to 10 end if c do id=1,nd antp(id)=p(id)/bolk/temp(id) ant0=pg0(id)/bolk/temp0(id) temp(id)=temp0(id) c if(ippgst.ge.2) c * write(6,605) iter,id,pg0(id),p(id),p(id)/pg0(id) c 605 format('new P',2i4,1p2e12.4,0p2f10.4) end do if(ntemp.eq.1) then do id=1,nd pgs0(id)=p(id) end do end if c return end c c c ***************************************************************** c c SUBROUTINE locate(xx,n,x,j,nxdim) c ================================= c INCLUDE 'IMPLIC.FOR' 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 go to 10 end if if(x.eq.xx(1)) then j=1 else if(x.eq.xx(n)) then j=n-1 else j=jl endif return END C C C ******************************************************************** C C SUBROUTINE XENINI C ================= C C Initializes necessary arrays for evaluating hydrogen line profiles C from the XENOMORPH tables C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' C DO I=1,4 DO J=1,22 ILXEN(I,J)=0 END DO END DO if(ihxenb.gt.0) then IHXENB=23 ihxenr=ihxenb+1 open(unit=ihxenb,file='xenomorph.blue.dat',status='old') open(unit=ihxenr,file='xenomorph.red.dat',status='old') write(6,641) ihxenb,ihxenr else return end if c 641 format(' -----------'/ * ' reading XENOMORPH tables; ihxen =',2i3,/ * ' -----------') C C --------------------------------- C read tables - blue wing C --------------------------------- C ILINE=0 READ(IHXENB,*) NTAB DO ITAB=1,NTAB ILINEB=ILINE READ(IHXENB,*) NLXEN DO ILI=1,NLXEN ILINE=ILINE+1 READ(IHXENB,*) I,J,ALMIN,ANEMIN,TMIN,DLA,DLE,DLT, * NWL,NE,NT XNEMIN=ANEMIN ILXEN(I,J)=ILINE NWLXEN(ILINE)=NWL NTHXEN(ILINE)=NT NEHXEN(ILINE)=NE DO IWL=1,NWL ALXEN(ILINE,IWL)=ALMIN+(IWL-1)*DLA END DO DO INE=1,NE XNEXEN(INE,ILINE)=ANEMIN+(INE-1)*DLE END DO DO IT=1,NT XTXEN(IT,ILINE)=TMIN+(IT-1)*DLT END DO END DO c DO ILI=1,NLXEN ILNE=ILINEB+ILI NWL=NWLXEN(ILNE) READ(IHXENB,500) DO INE=1,NEHXEN(ILNE) DO IT=1,NTHXEN(ILNE) READ(IHXENB,*) QLT,(PRFXB(ILNE,IWL,IT,INE),IWL=1,NWL) END DO END DO C END DO END DO CLOSE(IHXENB) 500 FORMAT(1X) C C --------------------------------- C read tables - red wing C --------------------------------- C ILINE=0 READ(IHXENR,*) NTAB DO ITAB=1,NTAB ILINEB=ILINE READ(IHXENR,*) NLXEN DO ILI=1,NLXEN ILINE=ILINE+1 READ(IHXENR,*) I,J,ALMIN,ANEMIN,TMIN,DLA,DLE,DLT, * NWL,NE,NT END DO c DO ILI=1,NLXEN ILNE=ILINEB+ILI NWL=NWLXEN(ILNE) READ(IHXENR,500) DO INE=1,NEHXEN(ILNE) DO IT=1,NTHXEN(ILNE) READ(IHXENR,*) QLT,(PRFXR(ILNE,IWL,IT,INE),IWL=1,NWL) END DO END DO C END DO END DO CLOSE(IHXENR) C RETURN END C C C ******************************************************************** C C SUBROUTINE INTXEN(W0B,W0R,X0,Z0,IWL,ILINE,id) 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 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' DIMENSION ZZ(3),XX(3),WXB(3),WZB(3),WXR(3),WZR(3) C id1=id NX=2 NZ=2 NT=NTHXEN(ILINE) NE=NEHXEN(ILINE) C DO IZZ=1,NE-1 IPZ=IZZ IF(Z0.LE.XNEXEN(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 IZZ=N0Z,N1Z I0Z=IZZ-N0Z+1 ZZ(I0Z)=XNEXEN(IZZ,ILINE) DO IX=1,NT-1 IPX=IX IF(X0.LE.XTXEN(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)=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 C C C ****************************************************************** C C 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 nu: array of frequencies c table: absorptive opacities in cm^2/gm c (NOTE: Quantities in absorption.tab are in log_e) C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' common/intcfg/yint(mfreq),jgint(mfreq) c dimension absort(mfhtab),frlt(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 frlt(k)=log10(frgtab(k)) do i = 1, nugtemp read(53,*) (hydcrs(i,j,k),j=1,nugele) end do end do 501 format(40x,f17.14) close(53) c FRGTB1 = log10(frgtab(1)) FRGTB2 = log10(frgtab(nugfreq)) c c interpolate HYDCRS from tabular to actual frequencies c c set up interpolation coefficients for frequency interpolation c by bisection c frg1=frgtab(1) frg2=frgtab(nugfreq) do ij=1,nfreq jgint(ij)=0 xint=freq(ij) if(xint.ge.frg1.and.xint.le.frg2) then jl=0 ju=nugfreq+1 40 continue if(ju-jl.gt.1) then jm=(ju+jl)/2 if((frg2.gt.frg1).eqv.(xint.gt.frgtab(jm))) then jl=jm else ju=jm end if go to 40 end if j=jl if(j.eq.nugfreq) j=j-1 if(j.eq.0) j=j+1 jgint(ij)=j yint(ij)=un/log10(frgtab(j+1)/frgtab(j)) end if end do c do it=1,nugtemp do ir=1,nugele do k=1,nugfreq absort(k)=log(hydcrs(it,ir,k)) end do do ij=1,nfreq j=jgint(ij) hydcrs(it,ir,ij)=0. if(j.gt.0) then rc=(absort(j+1)-absort(j))*yint(ij) hcs=rc*log10(freq(ij)/frgtab(j))+absort(j) hydcrs(it,ir,ij)=hcs end if end do end do end do c RETURN END C C C ******************************************************************** C C SUBROUTINE GHYDOP(IJ) C ===================== c c hydrogen opacity -lines + pseudocontinuum from Gomez tables c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' common/intcfg/yint(mfreq),jgint(mfreq) c if(ihgom.eq.0.or.jgint(ij).eq.0) return jf=ij 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) JT = 1 + IDINT(DELTAT) IF(JT.LT.1) JT = 1 IF(JT.GT.nugtemp-1) JT = nugtemp-1 t1i=temvec(jt) t2i=temvec(jt+1) dti=(TL-T1i)/(T2i-T1i) if(JT .eq. 1) dti = 0.d0 C opr1=hydcrs(jt,jr,jf)+dti* * (hydcrs(jt+1,jr,jf)-hydcrs(jt,jr,jf)) opr2=hydcrs(jt,jr+1,jf)+dti* * (hydcrs(jt+1,jr+1,jf)-hydcrs(jt,jr+1,jf)) opac=opr1+dri*(opr2-opr1) ab = exp(opac)*0.0265*4.1347e-15 c if(freq(ij).gt.8.22013e14) then ii=nfirst(ielh) else ii=nfirst(ielh)+1 end if c oph=ab*popul(ii,id)*g(ii) abso1(id)=abso1(id)+oph emis1(id)=emis1(id)+oph*xkfb(id)/xkf1(id) 10 continue c return end C C C ******************************************************************** C C FUNCTION SBFCH(FR,T) C ==================== C C cross-section times partition function for CH C C from Kurucz ATLAS9 C INCLUDE 'IMPLIC.FOR' parameter (fihu=500.,fihui=1./fihu, * twhu=200.,twhui=1./twhu, * tenl=2.30258509299405E0) c DIMENSION CROSSCH(15,105),PARTCH(41),CROSSCHT(15) DIMENSION C1(150),C2(150),C3(150),C4(150),C5(150) DIMENSION C6(150),C7(150),C8(150),C9(150),C10(150) DIMENSION C11(75) C EQUIVALENCE (CROSSCH(1, 1),C1(1)),(CROSSCH(1,11),C2(1)) EQUIVALENCE (CROSSCH(1,21),C3(1)),(CROSSCH(1,31),C4(1)) EQUIVALENCE (CROSSCH(1,41),C5(1)),(CROSSCH(1,51),C6(1)) EQUIVALENCE (CROSSCH(1,61),C7(1)),(CROSSCH(1,71),C8(1)) EQUIVALENCE (CROSSCH(1,81),C9(1)),(CROSSCH(1,91),C10(1)) EQUIVALENCE (CROSSCH(1,101),C11(1)) C DATA C1/-38.000,-38.000,-38.000,-38.000,-38.000,-38.000,-38.000, 1-38.000,-38.000,-38.000,-38.000,-38.000,-38.000,-38.000,-38.000, 2 -32.727,-31.151,-30.133,-29.432,-28.925,-28.547,-28.257, 2-28.030,-27.848,-27.701,-27.580,-27.479,-27.395,-27.322,-27.261, 3 -31.588,-30.011,-28.993,-28.290,-27.784,-27.405,-27.115, 3-26.887,-26.705,-26.558,-26.437,-26.336,-26.251,-26.179,-26.117, 4 -30.407,-28.830,-27.811,-27.108,-26.601,-26.223,-25.932, 4-25.705,-25.523,-25.376,-25.255,-25.154,-25.069,-24.997,-24.935, 5 -29.513,-27.937,-26.920,-26.218,-25.712,-25.334,-25.043, 5-24.816,-24.635,-24.487,-24.366,-24.266,-24.181,-24.109,-24.047, 6 -28.910,-27.341,-26.327,-25.628,-25.123,-24.746,-24.457, 6-24.230,-24.049,-23.902,-23.782,-23.681,-23.597,-23.525,-23.464, 7 -28.517,-26.961,-25.955,-25.261,-24.760,-24.385,-24.098, 7-23.873,-23.694,-23.548,-23.429,-23.329,-23.245,-23.174,-23.113, 8 -28.213,-26.675,-25.680,-24.993,-24.497,-24.127,-23.843, 8-23.620,-23.443,-23.299,-23.181,-23.082,-22.999,-22.929,-22.869, 9 -27.942,-26.427,-25.446,-24.769,-24.280,-23.915,-23.635, 9-23.416,-23.241,-23.100,-22.983,-22.887,-22.805,-22.736,-22.677, A -27.706,-26.210,-25.241,-24.572,-24.088,-23.728,-23.451, A-23.235,-23.063,-22.923,-22.808,-22.713,-22.633,-22.565,-22.507/ DATA C2/-27.475,-26.000,-25.043,-24.382,-23.905,-23.548,-23.275, 1-23.062,-22.891,-22.753,-22.640,-22.546,-22.467,-22.400,-22.343, 2 -27.221,-25.783,-24.844,-24.193,-23.723,-23.372,-23.102, 2-22.892,-22.724,-22.588,-22.476,-22.384,-22.306,-22.240,-22.184, 3 -26.863,-25.506,-24.607,-23.979,-23.523,-23.182,-22.919, 3-22.714,-22.550,-22.417,-22.309,-22.218,-22.142,-22.078,-22.023, 4 -26.685,-25.347,-24.457,-23.835,-23.382,-23.044,-22.784, 4-22.580,-22.418,-22.286,-22.178,-22.089,-22.014,-21.950,-21.896, 5 -26.085,-24.903,-24.105,-23.538,-23.120,-22.805,-22.561, 5-22.370,-22.217,-22.093,-21.991,-21.906,-21.835,-21.775,-21.723, 6 -25.902,-24.727,-23.936,-23.376,-22.964,-22.654,-22.415, 6-22.227,-22.076,-21.955,-21.855,-21.772,-21.702,-21.644,-21.593, 7 -25.215,-24.196,-23.510,-23.019,-22.655,-22.378,-22.163, 7-21.992,-21.855,-21.744,-21.653,-21.577,-21.513,-21.459,-21.412, 8 -24.914,-23.937,-23.284,-22.820,-22.475,-22.212,-22.007, 8-21.845,-21.715,-21.609,-21.522,-21.449,-21.388,-21.336,-21.292, 9 -24.519,-23.637,-23.039,-22.606,-22.281,-22.030,-21.834, 9-21.678,-21.552,-21.450,-21.365,-21.295,-21.236,-21.185,-21.142, A -24.086,-23.222,-22.650,-22.246,-21.948,-21.722,-21.546, A-21.407,-21.296,-21.205,-21.131,-21.070,-21.018,-20.974,-20.937/ DATA C3/-23.850,-23.018,-22.472,-22.088,-21.805,-21.590,-21.422, 1-21.289,-21.182,-21.095,-21.024,-20.964,-20.914,-20.872,-20.835, 2 -23.136,-22.445,-21.994,-21.676,-21.440,-21.259,-21.117, 2-21.004,-20.912,-20.837,-20.775,-20.723,-20.679,-20.642,-20.611, 3 -23.199,-22.433,-21.927,-21.573,-21.314,-21.119,-20.969, 3-20.851,-20.758,-20.682,-20.621,-20.571,-20.529,-20.493,-20.463, 4 -22.696,-22.020,-21.585,-21.286,-21.071,-20.912,-20.791, 4-20.697,-20.622,-20.563,-20.514,-20.475,-20.442,-20.414,-20.391, 5 -22.119,-21.557,-21.194,-20.943,-20.761,-20.624,-20.518, 5-20.434,-20.367,-20.313,-20.268,-20.231,-20.201,-20.175,-20.153, 6 -21.855,-21.300,-20.931,-20.673,-20.485,-20.344,-20.235, 6-20.151,-20.084,-20.031,-19.988,-19.953,-19.924,-19.900,-19.880, 7 -21.126,-20.673,-20.382,-20.184,-20.044,-19.943,-19.868, 7-19.811,-19.769,-19.736,-19.710,-19.690,-19.674,-19.662,-19.652, 8 -20.502,-20.150,-19.922,-19.766,-19.657,-19.578,-19.520, 8-19.478,-19.446,-19.422,-19.404,-19.390,-19.379,-19.371,-19.365, 9 -20.030,-19.724,-19.530,-19.399,-19.309,-19.245,-19.199, 9-19.166,-19.142,-19.125,-19.112,-19.103,-19.096,-19.091,-19.088, A -19.640,-19.364,-19.189,-19.074,-18.996,-18.943,-18.906, A-18.881,-18.863,-18.852,-18.844,-18.839,-18.837,-18.836,-18.836/ DATA C4/-19.333,-19.092,-18.939,-18.838,-18.770,-18.725,-18.695, 1-18.675,-18.662,-18.655,-18.651,-18.649,-18.649,-18.651,-18.653, 2 -19.070,-18.880,-18.756,-18.674,-18.621,-18.585,-18.562, 2-18.548,-18.540,-18.536,-18.536,-18.537,-18.539,-18.542,-18.546, 3 -18.851,-18.708,-18.617,-18.558,-18.521,-18.498,-18.484, 3-18.477,-18.475,-18.476,-18.478,-18.482,-18.487,-18.493,-18.498, 4 -18.709,-18.599,-18.533,-18.494,-18.471,-18.459,-18.454, 4-18.454,-18.457,-18.462,-18.469,-18.476,-18.483,-18.490,-18.498, 5 -18.656,-18.572,-18.524,-18.497,-18.485,-18.480,-18.482, 5-18.486,-18.493,-18.501,-18.510,-18.519,-18.527,-18.536,-18.544, 6 -18.670,-18.613,-18.582,-18.566,-18.561,-18.562,-18.568, 6-18.575,-18.583,-18.592,-18.601,-18.610,-18.619,-18.627,-18.635, 7 -18.728,-18.700,-18.687,-18.683,-18.685,-18.691,-18.698, 7-18.706,-18.715,-18.723,-18.731,-18.739,-18.745,-18.752,-18.758, 8 -18.839,-18.835,-18.836,-18.842,-18.849,-18.857,-18.865, 8-18.872,-18.878,-18.883,-18.888,-18.892,-18.895,-18.898,-18.900, 9 -19.034,-19.041,-19.049,-19.057,-19.064,-19.069,-19.071, 9-19.071,-19.070,-19.068,-19.065,-19.061,-19.058,-19.054,-19.051, A -19.372,-19.378,-19.382,-19.380,-19.372,-19.359,-19.341, A-19.321,-19.300,-19.280,-19.261,-19.243,-19.227,-19.212,-19.199/ DATA C5/-19.780,-19.777,-19.763,-19.732,-19.686,-19.631,-19.573, 1-19.517,-19.465,-19.419,-19.379,-19.344,-19.314,-19.288,-19.265, 2 -20.151,-20.133,-20.087,-20.009,-19.911,-19.810,-19.715, 2-19.631,-19.559,-19.497,-19.446,-19.402,-19.365,-19.333,-19.306, 3 -20.525,-20.454,-20.312,-20.138,-19.970,-19.825,-19.705, 3-19.607,-19.528,-19.464,-19.411,-19.367,-19.330,-19.300,-19.274, 4 -20.869,-20.655,-20.366,-20.104,-19.894,-19.731,-19.604, 4-19.505,-19.426,-19.363,-19.312,-19.271,-19.236,-19.208,-19.184, 5 -21.179,-20.768,-20.380,-20.081,-19.856,-19.686,-19.556, 5-19.454,-19.375,-19.311,-19.260,-19.218,-19.184,-19.155,-19.131, 6 -21.167,-20.601,-20.206,-19.925,-19.719,-19.565,-19.447, 6-19.355,-19.283,-19.226,-19.180,-19.143,-19.112,-19.087,-19.066, 7 -20.918,-20.348,-19.976,-19.720,-19.536,-19.401,-19.299, 7-19.220,-19.159,-19.112,-19.073,-19.043,-19.018,-18.998,-18.981, 8 -20.753,-20.204,-19.847,-19.602,-19.427,-19.299,-19.203, 8-19.129,-19.072,-19.028,-18.993,-18.965,-18.942,-18.924,-18.909, 9 -20.456,-19.987,-19.677,-19.460,-19.302,-19.186,-19.098, 9-19.030,-18.978,-18.937,-18.904,-18.878,-18.857,-18.841,-18.827, A -20.154,-19.734,-19.461,-19.272,-19.136,-19.035,-18.960, A-18.902,-18.858,-18.824,-18.797,-18.775,-18.759,-18.745,-18.735/ DATA C6/-19.941,-19.544,-19.288,-19.114,-18.992,-18.903,-18.837, 1-18.788,-18.751,-18.723,-18.701,-18.684,-18.671,-18.661,-18.654, 2 -19.657,-19.321,-19.104,-18.956,-18.853,-18.779,-18.724, 2-18.684,-18.655,-18.632,-18.615,-18.602,-18.592,-18.585,-18.579, 3 -19.388,-19.109,-18.930,-18.810,-18.725,-18.664,-18.620, 3-18.586,-18.562,-18.543,-18.529,-18.518,-18.510,-18.503,-18.498, 4 -19.201,-18.953,-18.794,-18.686,-18.611,-18.556,-18.515, 4-18.485,-18.462,-18.446,-18.433,-18.423,-18.416,-18.410,-18.406, 5 -18.923,-18.719,-18.588,-18.500,-18.439,-18.396,-18.365, 5-18.344,-18.328,-18.318,-18.311,-18.307,-18.304,-18.303,-18.302, 6 -18.614,-18.458,-18.361,-18.298,-18.258,-18.232,-18.216, 6-18.206,-18.202,-18.201,-18.202,-18.205,-18.208,-18.213,-18.218, 7 -18.419,-18.295,-18.222,-18.178,-18.153,-18.139,-18.132, 7-18.131,-18.133,-18.138,-18.143,-18.150,-18.157,-18.164,-18.172, 8 -18.296,-18.201,-18.148,-18.118,-18.101,-18.094,-18.091, 8-18.093,-18.096,-18.101,-18.107,-18.113,-18.120,-18.126,-18.132, 9 -18.021,-17.992,-17.977,-17.970,-17.967,-17.968,-17.970, 9-17.974,-17.978,-17.983,-17.989,-17.994,-18.000,-18.005,-18.011, A -17.694,-17.686,-17.686,-17.691,-17.698,-17.708,-17.718, A-17.729,-17.740,-17.750,-17.761,-17.771,-17.781,-17.790,-17.798/ DATA C7/-17.374,-17.384,-17.400,-17.420,-17.440,-17.462,-17.483, 1-17.503,-17.523,-17.541,-17.558,-17.575,-17.590,-17.603,-17.616, 2 -17.169,-17.199,-17.230,-17.262,-17.293,-17.323,-17.351, 2-17.378,-17.404,-17.427,-17.449,-17.469,-17.488,-17.505,-17.520, 3 -17.151,-17.184,-17.217,-17.250,-17.282,-17.313,-17.342, 3-17.369,-17.395,-17.418,-17.440,-17.461,-17.480,-17.497,-17.513, 4 -17.230,-17.260,-17.290,-17.320,-17.348,-17.375,-17.401, 4-17.425,-17.448,-17.469,-17.489,-17.508,-17.525,-17.541,-17.556, 5 -17.379,-17.403,-17.425,-17.446,-17.467,-17.486,-17.505, 5-17.524,-17.541,-17.558,-17.574,-17.588,-17.602,-17.615,-17.627, 6 -17.596,-17.604,-17.609,-17.612,-17.616,-17.622,-17.628, 6-17.636,-17.644,-17.652,-17.661,-17.670,-17.679,-17.687,-17.695, 7 -17.846,-17.823,-17.795,-17.770,-17.750,-17.735,-17.725, 7-17.719,-17.716,-17.715,-17.716,-17.719,-17.722,-17.726,-17.730, 8 -18.089,-18.015,-17.942,-17.882,-17.836,-17.802,-17.777, 8-17.760,-17.748,-17.740,-17.736,-17.734,-17.733,-17.734,-17.736, 9 -18.299,-18.156,-18.038,-17.947,-17.881,-17.833,-17.798, 9-17.774,-17.757,-17.745,-17.738,-17.733,-17.730,-17.729,-17.729, A -18.441,-18.243,-18.096,-17.991,-17.915,-17.860,-17.821, A-17.792,-17.772,-17.757,-17.746,-17.738,-17.733,-17.730,-17.728/ DATA C8/-18.474,-18.262,-18.111,-18.004,-17.926,-17.869,-17.826, 1-17.795,-17.771,-17.753,-17.740,-17.730,-17.722,-17.717,-17.713, 2 -18.387,-18.191,-18.053,-17.952,-17.878,-17.823,-17.782, 2-17.752,-17.729,-17.711,-17.698,-17.689,-17.681,-17.676,-17.672, 3 -18.161,-17.990,-17.874,-17.793,-17.736,-17.696,-17.668, 3-17.648,-17.634,-17.625,-17.619,-17.616,-17.614,-17.614,-17.615, 4 -17.908,-17.774,-17.690,-17.637,-17.604,-17.583,-17.572, 4-17.567,-17.566,-17.568,-17.571,-17.576,-17.581,-17.587,-17.593, 5 -17.681,-17.589,-17.540,-17.515,-17.506,-17.505,-17.511, 5-17.520,-17.530,-17.542,-17.554,-17.566,-17.578,-17.589,-17.600, 6 -17.647,-17.606,-17.584,-17.575,-17.573,-17.576,-17.582, 6-17.589,-17.597,-17.605,-17.614,-17.623,-17.631,-17.639,-17.646, 7 -17.300,-17.291,-17.291,-17.297,-17.307,-17.319,-17.333, 7-17.347,-17.361,-17.375,-17.389,-17.402,-17.415,-17.427,-17.438, 8 -16.786,-16.802,-16.825,-16.853,-16.883,-16.914,-16.944, 8-16.974,-17.003,-17.030,-17.055,-17.079,-17.101,-17.122,-17.141, 9 -16.489,-16.533,-16.579,-16.625,-16.670,-16.713,-16.754, 9-16.793,-16.830,-16.864,-16.896,-16.925,-16.952,-16.977,-17.000, A -16.694,-16.724,-16.756,-16.789,-16.823,-16.856,-16.888, A-16.919,-16.949,-16.976,-17.002,-17.026,-17.048,-17.069,-17.088/ DATA C9/-16.935,-16.951,-16.971,-16.993,-17.016,-17.040,-17.064, 1-17.088,-17.111,-17.132,-17.153,-17.172,-17.190,-17.206,-17.222, 2 -17.200,-17.208,-17.220,-17.235,-17.251,-17.269,-17.286, 2-17.304,-17.322,-17.338,-17.354,-17.369,-17.384,-17.397,-17.409, 3 -17.597,-17.591,-17.589,-17.590,-17.594,-17.600,-17.608, 3-17.617,-17.626,-17.635,-17.645,-17.654,-17.662,-17.671,-17.679, 4 -18.166,-18.134,-18.107,-18.085,-18.068,-18.056,-18.047, 4-18.041,-18.038,-18.036,-18.035,-18.035,-18.036,-18.038,-18.039, 5 -19.000,-18.917,-18.838,-18.770,-18.714,-18.669,-18.632, 5-18.603,-18.579,-18.560,-18.545,-18.532,-18.522,-18.514,-18.507, 6 -20.313,-19.982,-19.754,-19.592,-19.472,-19.380,-19.309, 6-19.253,-19.208,-19.172,-19.143,-19.119,-19.099,-19.083,-19.069, 7 -19.751,-19.611,-19.520,-19.461,-19.423,-19.398,-19.382, 7-19.372,-19.366,-19.364,-19.363,-19.364,-19.366,-19.368,-19.371, 8 -19.581,-19.431,-19.337,-19.277,-19.240,-19.218,-19.207, 8-19.202,-19.203,-19.207,-19.212,-19.220,-19.228,-19.236,-19.245, 9 -19.685,-19.506,-19.389,-19.311,-19.258,-19.222,-19.199, 9-19.184,-19.175,-19.170,-19.168,-19.169,-19.171,-19.174,-19.177, A -19.977,-19.756,-19.606,-19.501,-19.425,-19.370,-19.330, A-19.300,-19.278,-19.262,-19.250,-19.241,-19.235,-19.230,-19.227/ DATAC10/-20.445,-20.158,-19.958,-19.815,-19.711,-19.633,-19.574, 1-19.528,-19.493,-19.465,-19.442,-19.425,-19.410,-19.398,-19.389, 2 -20.980,-20.625,-20.391,-20.229,-20.110,-20.020,-19.949, 2-19.892,-19.846,-19.807,-19.775,-19.748,-19.724,-19.704,-19.687, 3 -21.404,-21.023,-20.771,-20.594,-20.461,-20.358,-20.274, 3-20.205,-20.148,-20.099,-20.058,-20.022,-19.991,-19.965,-19.942, 4 -21.309,-20.970,-20.753,-20.603,-20.495,-20.412,-20.348, 4-20.295,-20.252,-20.215,-20.185,-20.158,-20.135,-20.115,-20.098, 5 -21.221,-20.906,-20.707,-20.574,-20.480,-20.412,-20.361, 5-20.322,-20.292,-20.268,-20.249,-20.233,-20.221,-20.210,-20.201, 6 -21.441,-21.097,-20.878,-20.728,-20.623,-20.546,-20.489, 6-20.446,-20.413,-20.387,-20.368,-20.352,-20.340,-20.330,-20.322, 7 -21.668,-21.305,-21.071,-20.911,-20.797,-20.713,-20.650, 7-20.602,-20.565,-20.536,-20.514,-20.496,-20.481,-20.470,-20.460, 8 -21.926,-21.556,-21.316,-21.150,-21.031,-20.942,-20.874, 8-20.822,-20.782,-20.750,-20.724,-20.704,-20.687,-20.674,-20.663, 9 -22.319,-21.937,-21.686,-21.510,-21.380,-21.282,-21.206, 9-21.147,-21.099,-21.061,-21.031,-21.006,-20.985,-20.968,-20.954, A -22.969,-22.561,-22.288,-22.092,-21.945,-21.832,-21.743, A-21.672,-21.616,-21.570,-21.533,-21.503,-21.477,-21.457,-21.439/ DATAC11/-24.001,-23.527,-23.199,-22.957,-22.772,-22.629,-22.516, 1-22.427,-22.355,-22.297,-22.250,-22.212,-22.180,-22.153,-22.131, 2 -24.233,-23.774,-23.477,-23.273,-23.128,-23.022,-22.943, 2-22.883,-22.837,-22.802,-22.774,-22.752,-22.735,-22.721,-22.710, 3 -24.550,-23.913,-23.521,-23.266,-23.094,-22.976,-22.893, 3-22.836,-22.796,-22.768,-22.750,-22.737,-22.730,-22.726,-22.725, 4 -24.301,-23.665,-23.274,-23.019,-22.848,-22.730,-22.648, 4-22.591,-22.552,-22.525,-22.507,-22.495,-22.489,-22.485,-22.485, 5 -24.519,-23.883,-23.491,-23.237,-23.065,-22.948,-22.866, 5-22.809,-22.770,-22.743,-22.724,-22.713,-22.706,-22.703,-22.702/ DATA PARTCH/ 1 203.741, 249.643, 299.341, 353.477, 412.607, 477.237, 2 547.817, 624.786, 708.543, 799.463, 897.912, 1004.227, 3 1118.738, 1241.761, 1373.588, 1514.481, 1664.677, 1824.394, 4 1993.801, 2173.050, 2362.234, 2561.424, 2770.674, 2989.930, 5 3219.204, 3458.378, 3707.355, 3966.005, 4234.155, 4511.604, 6 4798.135, 5093.554, 5397.593, 5709.948, 6030.401, 6358.646, 7 6694.379, 7037.313, 7387.147, 7743.579, 8106.313/ DATA FREQ1/0./ C SBFCH=0. IF(FR.EQ.FREQ1) GO TO 30 FREQ1=FR WAVENO=FR/2.99792458E10 EVOLT=WAVENO/8065.479 N=int(EVOLT*10.) EN=FLOAT(N)*.1 IF(N.LT.20) RETURN IF(N.GE.105) RETURN c DO IT=1,15 CROSSCHT(IT)=(CROSSCH(IT,N)+(CROSSCH(IT,N+1)-CROSSCH(IT,N))* * (EVOLT-EN)*10.) END DO c c interpolate to obtain partition function c 30 IF(T.GE.9000.) RETURN IF(N.LT.20) RETURN IF(N.GE.105) RETURN IT=int((T-1000.)*twhui+1.) IF(IT.LT.1) IT=1 TN=FLOAT(IT)*twhu+800. PART=PARTCH(IT)+(PARTCH(IT+1)-PARTCH(IT))*(T-TN)*twhui c c interpolate to obtain cross-section c IT=int((T-2000.)*fihui+1.) IF(IT.LT.1) IT=1 TN=FLOAT(IT)*fihu+1500. CHOP=EXP((CROSSCHT(IT)+(CROSSCHT(IT+1)-CROSSCHT(IT))* * (T-TN)*fihui)*tenl)*PART RETURN END C C C *********************************************************************** C C FUNCTION SBFOH(FR,T) C ==================== C C cross-section times partition function for OH C C from Kurucz ATLAS9 C INCLUDE 'IMPLIC.FOR' parameter (fihu=500.,fihui=1./fihu, * twhu=200.,twhui=1./twhu, * tenl=2.30258509299405E0) DIMENSION CROSSOH(15,130),PARTOH(41),CROSSOHT(15) DIMENSION C1(150),C2(150),C3(150),C4(150),C5(150) DIMENSION C6(150),C7(150),C8(150),C9(150),C10(150) DIMENSION C11(150),C12(150),C13(150) EQUIVALENCE (CROSSOH(1, 1),C1(1)),(CROSSOH(1,11),C2(1)) EQUIVALENCE (CROSSOH(1,21),C3(1)),(CROSSOH(1,31),C4(1)) EQUIVALENCE (CROSSOH(1,41),C5(1)),(CROSSOH(1,51),C6(1)) EQUIVALENCE (CROSSOH(1,61),C7(1)),(CROSSOH(1,71),C8(1)) EQUIVALENCE (CROSSOH(1,81),C9(1)),(CROSSOH(1,91),C10(1)) EQUIVALENCE (CROSSOH(1,101),C11(1)) EQUIVALENCE (CROSSOH(1,111),C12(1)) EQUIVALENCE (CROSSOH(1,121),C13(1)) C DATA C1/-30.855,-29.121,-27.976,-27.166,-26.566,-26.106,-25.742, 1-25.448,-25.207,-25.006,-24.836,-24.691,-24.566,-24.457,-24.363, 2 -30.494,-28.760,-27.615,-26.806,-26.206,-25.745,-25.381, 2-25.088,-24.846,-24.645,-24.475,-24.330,-24.205,-24.097,-24.002, 3 -30.157,-28.425,-27.280,-26.472,-25.872,-25.411,-25.048, 3-24.754,-24.513,-24.312,-24.142,-23.997,-23.872,-23.764,-23.669, 4 -29.848,-28.117,-26.974,-26.165,-25.566,-25.105,-24.742, 4-24.448,-24.207,-24.006,-23.836,-23.692,-23.567,-23.458,-23.364, 5 -29.567,-27.837,-26.693,-25.885,-25.286,-24.826,-24.462, 5-24.169,-23.928,-23.727,-23.557,-23.412,-23.287,-23.179,-23.084, 6 -29.307,-27.578,-26.436,-25.628,-25.029,-24.569,-24.205, 6-23.912,-23.671,-23.470,-23.300,-23.155,-23.031,-22.922,-22.828, 7 -29.068,-27.341,-26.199,-25.391,-24.792,-24.332,-23.969, 7-23.676,-23.435,-23.234,-23.064,-22.920,-22.795,-22.687,-22.592, 8 -28.820,-27.115,-25.978,-25.172,-24.574,-24.115,-23.752, 8-23.459,-23.218,-23.017,-22.848,-22.703,-22.579,-22.470,-22.376, 9 -28.540,-26.891,-25.768,-24.968,-24.372,-23.914,-23.552, 9-23.259,-23.019,-22.818,-22.649,-22.504,-22.380,-22.272,-22.177, A -28.275,-26.681,-25.574,-24.779,-24.186,-23.729,-23.368, A-23.076,-22.836,-22.636,-22.467,-22.322,-22.198,-22.090,-21.996/ DATA C2/-27.993,-26.470,-25.388,-24.602,-24.014,-23.560,-23.200, 1-22.909,-22.669,-22.470,-22.301,-22.157,-22.033,-21.925,-21.831, 2 -27.698,-26.252,-25.204,-24.433,-23.851,-23.401,-23.043, 2-22.754,-22.515,-22.316,-22.148,-22.005,-21.881,-21.773,-21.679, 3 -27.398,-26.026,-25.019,-24.267,-23.696,-23.251,-22.896, 3-22.609,-22.372,-22.174,-22.007,-21.864,-21.741,-21.634,-21.540, 4 -27.100,-25.791,-24.828,-24.102,-23.543,-23.106,-22.756, 4-22.472,-22.238,-22.041,-21.875,-21.733,-21.611,-21.504,-21.411, 5 -26.807,-25.549,-24.631,-23.933,-23.391,-22.964,-22.621, 5-22.341,-22.109,-21.915,-21.751,-21.610,-21.488,-21.383,-21.290, 6 -26.531,-25.310,-24.431,-23.761,-23.238,-22.823,-22.488, 6-22.214,-21.986,-21.795,-21.633,-21.494,-21.374,-21.269,-21.178, 7 -26.239,-25.066,-24.225,-23.585,-23.082,-22.681,-22.356, 7-22.089,-21.866,-21.679,-21.520,-21.383,-21.265,-21.162,-21.072, 8 -25.945,-24.824,-24.017,-23.405,-22.923,-22.538,-22.223, 8-21.964,-21.748,-21.565,-21.410,-21.276,-21.160,-21.059,-20.970, 9 -25.663,-24.587,-23.810,-23.222,-22.761,-22.391,-22.088, 9-21.838,-21.629,-21.452,-21.300,-21.170,-21.057,-20.958,-20.872, A -25.372,-24.350,-23.603,-23.038,-22.596,-22.241,-21.950, A-21.710,-21.508,-21.337,-21.190,-21.064,-20.954,-20.858,-20.774/ DATA C3/-25.076,-24.111,-23.396,-22.853,-22.429,-22.088,-21.809, 1-21.578,-21.384,-21.220,-21.078,-20.957,-20.851,-20.758,-20.676, 2 -24.779,-23.870,-23.189,-22.669,-22.261,-21.934,-21.667, 2-21.445,-21.259,-21.101,-20.965,-20.848,-20.746,-20.656,-20.578, 3 -24.486,-23.629,-22.983,-22.486,-22.095,-21.781,-21.524, 3-21.311,-21.132,-20.980,-20.850,-20.737,-20.639,-20.553,-20.478, 4 -24.183,-23.382,-22.774,-22.302,-21.928,-21.627,-21.381, 4-21.177,-21.005,-20.859,-20.734,-20.625,-20.531,-20.449,-20.376, 5 -23.867,-23.127,-22.561,-22.116,-21.761,-21.474,-21.238, 5-21.043,-20.878,-20.738,-20.617,-20.513,-20.423,-20.344,-20.274, 6 -23.538,-22.862,-22.340,-21.926,-21.592,-21.320,-21.096, 6-20.909,-20.751,-20.617,-20.502,-20.402,-20.315,-20.239,-20.172, 7 -23.234,-22.604,-22.120,-21.734,-21.422,-21.166,-20.953, 7-20.776,-20.625,-20.497,-20.387,-20.291,-20.208,-20.135,-20.071, 8 -22.934,-22.347,-21.898,-21.541,-21.250,-21.010,-20.811, 8-20.643,-20.500,-20.378,-20.273,-20.182,-20.102,-20.033,-19.971, 9 -22.637,-22.092,-21.676,-21.345,-21.075,-20.853,-20.666, 9-20.508,-20.374,-20.259,-20.159,-20.073,-19.997,-19.931,-19.872, A -22.337,-21.835,-21.452,-21.147,-20.899,-20.693,-20.520, A-20.373,-20.247,-20.139,-20.046,-19.964,-19.892,-19.830,-19.774/ DATA C4/-22.049,-21.584,-21.230,-20.950,-20.721,-20.531,-20.372, 1-20.236,-20.119,-20.019,-19.931,-19.855,-19.788,-19.729,-19.676, 2 -21.768,-21.337,-21.011,-20.754,-20.544,-20.370,-20.223, 2-20.098,-19.991,-19.898,-19.817,-19.746,-19.683,-19.628,-19.579, 3 -21.494,-21.096,-20.796,-20.559,-20.367,-20.208,-20.074, 3-19.960,-19.861,-19.776,-19.701,-19.636,-19.578,-19.527,-19.482, 4 -21.233,-20.861,-20.585,-20.368,-20.193,-20.048,-19.926, 4-19.821,-19.732,-19.654,-19.586,-19.526,-19.473,-19.426,-19.384, 5 -20.983,-20.635,-20.380,-20.181,-20.021,-19.889,-19.778, 5-19.683,-19.602,-19.531,-19.469,-19.415,-19.367,-19.324,-19.286, 6 -20.743,-20.418,-20.182,-19.999,-19.853,-19.733,-19.633, 6-19.547,-19.474,-19.410,-19.354,-19.305,-19.261,-19.223,-19.189, 7 -20.515,-20.210,-19.991,-19.824,-19.690,-19.581,-19.490, 7-19.413,-19.347,-19.290,-19.240,-19.196,-19.157,-19.122,-19.092, 8 -20.297,-20.011,-19.808,-19.654,-19.532,-19.434,-19.352, 8-19.282,-19.223,-19.172,-19.127,-19.088,-19.054,-19.023,-18.996, 9 -20.090,-19.822,-19.633,-19.491,-19.381,-19.291,-19.218, 9-19.156,-19.103,-19.057,-19.018,-18.983,-18.952,-18.925,-18.901, A -19.893,-19.642,-19.467,-19.337,-19.236,-19.155,-19.089, A-19.034,-18.987,-18.946,-18.912,-18.881,-18.854,-18.831,-18.810/ DATA C5/-19.705,-19.472,-19.309,-19.190,-19.098,-19.025,-18.966, 1-18.917,-18.876,-18.840,-18.810,-18.783,-18.760,-18.739,-18.721, 2 -19.527,-19.310,-19.161,-19.051,-18.968,-18.903,-18.851, 2-18.807,-18.771,-18.740,-18.713,-18.690,-18.670,-18.653,-18.637, 3 -19.357,-19.159,-19.022,-18.922,-18.847,-18.789,-18.743, 3-18.704,-18.673,-18.646,-18.623,-18.603,-18.586,-18.571,-18.558, 4 -19.195,-19.016,-18.892,-18.803,-18.736,-18.684,-18.643, 4-18.610,-18.583,-18.560,-18.540,-18.523,-18.509,-18.496,-18.485, 5 -19.042,-18.883,-18.772,-18.693,-18.634,-18.589,-18.553, 5-18.525,-18.501,-18.481,-18.465,-18.451,-18.438,-18.428,-18.419, 6 -18.894,-18.758,-18.662,-18.593,-18.542,-18.503,-18.473, 6-18.448,-18.428,-18.412,-18.398,-18.386,-18.376,-18.367,-18.359, 7 -18.752,-18.639,-18.559,-18.501,-18.458,-18.426,-18.400, 7-18.380,-18.363,-18.350,-18.338,-18.328,-18.320,-18.313,-18.306, 8 -18.611,-18.523,-18.460,-18.415,-18.381,-18.355,-18.334, 8-18.318,-18.304,-18.293,-18.284,-18.276,-18.269,-18.263,-18.258, 9 -18.471,-18.408,-18.362,-18.329,-18.304,-18.285,-18.269, 9-18.257,-18.247,-18.238,-18.231,-18.224,-18.219,-18.214,-18.210, A -18.330,-18.290,-18.261,-18.239,-18.223,-18.211,-18.201, A-18.192,-18.185,-18.179,-18.174,-18.169,-18.165,-18.162,-18.159/ DATA C6/-18.190,-18.168,-18.154,-18.143,-18.135,-18.129,-18.124, 1-18.120,-18.116,-18.112,-18.109,-18.106,-18.104,-18.102,-18.100, 2 -18.055,-18.047,-18.043,-18.042,-18.040,-18.039,-18.039, 2-18.038,-18.037,-18.036,-18.035,-18.034,-18.033,-18.033,-18.032, 3 -17.929,-17.931,-17.935,-17.939,-17.943,-17.946,-17.948, 3-17.950,-17.952,-17.953,-17.955,-17.956,-17.957,-17.958,-17.959, 4 -17.818,-17.826,-17.834,-17.842,-17.849,-17.855,-17.860, 4-17.865,-17.869,-17.872,-17.875,-17.878,-17.881,-17.883,-17.886, 5 -17.724,-17.736,-17.747,-17.758,-17.767,-17.775,-17.782, 5-17.788,-17.793,-17.798,-17.803,-17.807,-17.811,-17.815,-17.819, 6 -17.651,-17.665,-17.678,-17.690,-17.701,-17.710,-17.718, 6-17.725,-17.732,-17.738,-17.744,-17.749,-17.755,-17.760,-17.765, 7 -17.601,-17.615,-17.629,-17.642,-17.653,-17.663,-17.672, 7-17.680,-17.688,-17.695,-17.701,-17.708,-17.714,-17.720,-17.726, 8 -17.572,-17.587,-17.602,-17.614,-17.626,-17.636,-17.645, 8-17.654,-17.662,-17.670,-17.677,-17.684,-17.691,-17.698,-17.704, 9 -17.565,-17.581,-17.595,-17.607,-17.619,-17.629,-17.638, 9-17.647,-17.656,-17.664,-17.671,-17.679,-17.686,-17.693,-17.700, A -17.580,-17.594,-17.608,-17.620,-17.630,-17.640,-17.650, A-17.658,-17.667,-17.675,-17.682,-17.690,-17.697,-17.704,-17.711/ DATA C7/-17.613,-17.626,-17.639,-17.649,-17.659,-17.669,-17.677, 1-17.686,-17.694,-17.701,-17.709,-17.716,-17.723,-17.730,-17.737, 2 -17.663,-17.675,-17.685,-17.695,-17.703,-17.711,-17.719, 2-17.727,-17.734,-17.741,-17.748,-17.755,-17.761,-17.768,-17.774, 3 -17.728,-17.737,-17.745,-17.752,-17.759,-17.766,-17.772, 3-17.778,-17.785,-17.791,-17.797,-17.803,-17.808,-17.814,-17.820, 4 -17.803,-17.809,-17.814,-17.818,-17.823,-17.828,-17.832, 4-17.837,-17.842,-17.847,-17.852,-17.856,-17.861,-17.866,-17.871, 5 -17.884,-17.886,-17.888,-17.889,-17.891,-17.893,-17.896, 5-17.899,-17.902,-17.905,-17.908,-17.912,-17.915,-17.919,-17.922, 6 -17.966,-17.964,-17.961,-17.959,-17.958,-17.958,-17.958, 6-17.959,-17.960,-17.961,-17.963,-17.964,-17.966,-17.968,-17.970, 7 -18.040,-18.034,-18.028,-18.023,-18.019,-18.016,-18.013, 7-18.012,-18.010,-18.010,-18.009,-18.009,-18.009,-18.009,-18.010, 8 -18.096,-18.087,-18.078,-18.071,-18.065,-18.059,-18.055, 8-18.051,-18.047,-18.045,-18.042,-18.040,-18.039,-18.037,-18.036, 9 -18.125,-18.115,-18.105,-18.097,-18.089,-18.082,-18.076, 9-18.070,-18.065,-18.061,-18.057,-18.053,-18.051,-18.048,-18.046, A -18.120,-18.112,-18.103,-18.095,-18.087,-18.079,-18.072, A-18.066,-18.060,-18.055,-18.050,-18.046,-18.042,-18.039,-18.036/ DATA C8/-18.083,-18.078,-18.071,-18.064,-18.057,-18.050,-18.044, 1-18.037,-18.032,-18.026,-18.022,-18.017,-18.014,-18.010,-18.007, 2 -18.025,-18.022,-18.017,-18.012,-18.006,-18.000,-17.994, 2-17.989,-17.984,-17.979,-17.975,-17.971,-17.968,-17.965,-17.963, 3 -17.957,-17.955,-17.952,-17.948,-17.943,-17.938,-17.934, 3-17.929,-17.925,-17.922,-17.918,-17.916,-17.913,-17.911,-17.910, 4 -17.890,-17.889,-17.886,-17.882,-17.879,-17.875,-17.871, 4-17.867,-17.864,-17.862,-17.860,-17.858,-17.857,-17.856,-17.855, 5 -17.831,-17.829,-17.826,-17.822,-17.819,-17.815,-17.812, 5-17.810,-17.807,-17.806,-17.804,-17.803,-17.803,-17.803,-17.803, 6 -17.786,-17.782,-17.777,-17.773,-17.769,-17.766,-17.763, 6-17.761,-17.759,-17.758,-17.757,-17.757,-17.757,-17.758,-17.759, 7 -17.753,-17.747,-17.741,-17.735,-17.731,-17.727,-17.724, 7-17.722,-17.721,-17.720,-17.720,-17.720,-17.721,-17.722,-17.724, 8 -17.733,-17.724,-17.716,-17.709,-17.703,-17.699,-17.696, 8-17.694,-17.693,-17.692,-17.692,-17.693,-17.694,-17.695,-17.697, 9 -17.723,-17.711,-17.700,-17.691,-17.685,-17.680,-17.676, 9-17.674,-17.673,-17.672,-17.673,-17.673,-17.675,-17.676,-17.678, A -17.718,-17.702,-17.689,-17.679,-17.672,-17.667,-17.663, A-17.660,-17.659,-17.659,-17.659,-17.660,-17.661,-17.663,-17.665/ DATA C9/-17.713,-17.695,-17.681,-17.670,-17.662,-17.656,-17.653, 1-17.650,-17.649,-17.649,-17.649,-17.650,-17.651,-17.653,-17.655, 2 -17.705,-17.686,-17.671,-17.660,-17.652,-17.647,-17.643, 2-17.641,-17.640,-17.640,-17.640,-17.641,-17.643,-17.645,-17.647, 3 -17.690,-17.671,-17.657,-17.647,-17.640,-17.635,-17.632, 3-17.630,-17.630,-17.630,-17.631,-17.632,-17.634,-17.636,-17.639, 4 -17.667,-17.649,-17.637,-17.629,-17.623,-17.619,-17.618, 4-17.617,-17.617,-17.618,-17.619,-17.621,-17.623,-17.626,-17.628, 5 -17.635,-17.621,-17.611,-17.605,-17.601,-17.600,-17.599, 5-17.599,-17.601,-17.602,-17.604,-17.607,-17.609,-17.612,-17.615, 6 -17.596,-17.585,-17.579,-17.576,-17.575,-17.575,-17.576, 6-17.578,-17.580,-17.582,-17.585,-17.588,-17.591,-17.595,-17.598, 7 -17.550,-17.544,-17.542,-17.542,-17.544,-17.546,-17.548, 7-17.552,-17.555,-17.558,-17.562,-17.566,-17.570,-17.573,-17.577, 8 -17.501,-17.500,-17.501,-17.504,-17.508,-17.513,-17.517, 8-17.521,-17.526,-17.530,-17.535,-17.539,-17.544,-17.548,-17.553, 9 -17.449,-17.452,-17.457,-17.463,-17.470,-17.476,-17.482, 9-17.488,-17.493,-17.499,-17.504,-17.509,-17.514,-17.519,-17.524, A -17.396,-17.403,-17.412,-17.420,-17.429,-17.437,-17.444, A-17.451,-17.458,-17.464,-17.470,-17.476,-17.481,-17.487,-17.492/ DATAC10/-17.344,-17.355,-17.366,-17.377,-17.387,-17.396,-17.405, 1-17.413,-17.420,-17.427,-17.434,-17.440,-17.446,-17.452,-17.458, 2 -17.295,-17.307,-17.321,-17.333,-17.345,-17.355,-17.365, 2-17.373,-17.382,-17.389,-17.397,-17.404,-17.410,-17.417,-17.423, 3 -17.249,-17.264,-17.278,-17.292,-17.304,-17.316,-17.326, 3-17.335,-17.344,-17.352,-17.360,-17.368,-17.375,-17.382,-17.389, 4 -17.209,-17.225,-17.241,-17.255,-17.268,-17.280,-17.291, 4-17.301,-17.310,-17.319,-17.327,-17.335,-17.343,-17.350,-17.357, 5 -17.177,-17.194,-17.210,-17.225,-17.239,-17.251,-17.262, 5-17.272,-17.282,-17.291,-17.300,-17.308,-17.316,-17.324,-17.331, 6 -17.154,-17.172,-17.189,-17.204,-17.218,-17.230,-17.242, 6-17.252,-17.262,-17.272,-17.280,-17.289,-17.298,-17.306,-17.314, 7 -17.144,-17.162,-17.179,-17.194,-17.208,-17.220,-17.232, 7-17.242,-17.253,-17.262,-17.271,-17.280,-17.289,-17.297,-17.306, 8 -17.146,-17.164,-17.181,-17.196,-17.210,-17.222,-17.234, 8-17.245,-17.255,-17.265,-17.274,-17.283,-17.292,-17.301,-17.309, 9 -17.163,-17.180,-17.197,-17.212,-17.225,-17.237,-17.249, 9-17.260,-17.270,-17.280,-17.289,-17.298,-17.307,-17.316,-17.325, A -17.193,-17.211,-17.227,-17.241,-17.254,-17.266,-17.277, A-17.288,-17.298,-17.308,-17.317,-17.327,-17.336,-17.345,-17.353/ DATAC11/-17.239,-17.256,-17.271,-17.284,-17.297,-17.309,-17.320, 1-17.330,-17.340,-17.350,-17.359,-17.369,-17.378,-17.387,-17.395, 2 -17.299,-17.315,-17.329,-17.342,-17.354,-17.365,-17.376, 2-17.386,-17.396,-17.405,-17.415,-17.424,-17.433,-17.442,-17.451, 3 -17.373,-17.388,-17.402,-17.414,-17.425,-17.436,-17.446, 3-17.456,-17.466,-17.475,-17.484,-17.493,-17.502,-17.511,-17.520, 4 -17.462,-17.476,-17.489,-17.500,-17.511,-17.521,-17.531, 4-17.541,-17.550,-17.559,-17.569,-17.578,-17.587,-17.595,-17.604, 5 -17.567,-17.581,-17.592,-17.603,-17.613,-17.623,-17.632, 5-17.641,-17.651,-17.660,-17.669,-17.678,-17.686,-17.695,-17.704, 6 -17.689,-17.701,-17.712,-17.722,-17.732,-17.741,-17.750, 6-17.759,-17.768,-17.777,-17.786,-17.795,-17.803,-17.812,-17.821, 7 -17.829,-17.840,-17.851,-17.860,-17.869,-17.878,-17.887, 7-17.896,-17.904,-17.913,-17.922,-17.930,-17.939,-17.948,-17.956, 8 -17.988,-18.000,-18.010,-18.019,-18.028,-18.036,-18.045, 8-18.053,-18.062,-18.070,-18.079,-18.087,-18.096,-18.104,-18.112, 9 -18.171,-18.183,-18.192,-18.201,-18.210,-18.218,-18.227, 9-18.235,-18.243,-18.252,-18.260,-18.268,-18.277,-18.285,-18.293, A -18.381,-18.393,-18.403,-18.413,-18.422,-18.430,-18.438, A-18.447,-18.455,-18.463,-18.471,-18.479,-18.487,-18.495,-18.503/ DATAC12/-18.625,-18.638,-18.650,-18.660,-18.669,-18.678,-18.687, 1-18.695,-18.703,-18.711,-18.719,-18.726,-18.734,-18.742,-18.750, 2 -18.912,-18.929,-18.943,-18.955,-18.966,-18.975,-18.984, 2-18.993,-19.001,-19.008,-19.016,-19.023,-19.031,-19.038,-19.045, 3 -19.260,-19.283,-19.303,-19.320,-19.333,-19.345,-19.355, 3-19.364,-19.372,-19.380,-19.387,-19.394,-19.400,-19.407,-19.413, 4 -19.704,-19.740,-19.771,-19.796,-19.816,-19.832,-19.845, 4-19.855,-19.863,-19.870,-19.876,-19.882,-19.887,-19.892,-19.897, 5 -20.339,-20.386,-20.424,-20.454,-20.476,-20.492,-20.502, 5-20.509,-20.513,-20.516,-20.518,-20.520,-20.521,-20.523,-20.524, 6 -21.052,-21.075,-21.093,-21.105,-21.114,-21.120,-21.123, 6-21.125,-21.126,-21.127,-21.128,-21.130,-21.131,-21.133,-21.135, 7 -21.174,-21.203,-21.230,-21.255,-21.278,-21.299,-21.320, 7-21.339,-21.357,-21.375,-21.392,-21.408,-21.424,-21.439,-21.454, 8 -21.285,-21.317,-21.346,-21.372,-21.395,-21.416,-21.435, 8-21.452,-21.468,-21.483,-21.497,-21.511,-21.524,-21.536,-21.548, 9 -21.396,-21.429,-21.459,-21.486,-21.511,-21.532,-21.551, 9-21.569,-21.585,-21.600,-21.614,-21.627,-21.640,-21.652,-21.663, A -21.516,-21.549,-21.580,-21.609,-21.635,-21.658,-21.678, A-21.696,-21.713,-21.728,-21.742,-21.755,-21.767,-21.779,-21.790/ DATAC13/-21.651,-21.681,-21.711,-21.738,-21.763,-21.785,-21.804, 1-21.821,-21.837,-21.851,-21.864,-21.876,-21.887,-21.898,-21.908, 2 -21.810,-21.831,-21.853,-21.874,-21.893,-21.910,-21.925, 2-21.938,-21.950,-21.961,-21.971,-21.980,-21.989,-21.998,-22.006, 3 -22.009,-22.016,-22.026,-22.037,-22.048,-22.058,-22.066, 3-22.074,-22.081,-22.088,-22.094,-22.099,-22.105,-22.111,-22.117, 4 -22.353,-22.317,-22.296,-22.284,-22.276,-22.270,-22.266, 4-22.262,-22.260,-22.258,-22.257,-22.257,-22.257,-22.258,-22.259, 5 -22.705,-22.609,-22.552,-22.515,-22.488,-22.468,-22.451, 5-22.438,-22.427,-22.418,-22.410,-22.405,-22.400,-22.397,-22.395, 6 -22.889,-22.791,-22.731,-22.690,-22.659,-22.634,-22.612, 6-22.594,-22.579,-22.566,-22.555,-22.546,-22.539,-22.533,-22.528, 7 -23.211,-23.109,-23.041,-22.989,-22.945,-22.906,-22.872, 7-22.842,-22.816,-22.793,-22.774,-22.757,-22.743,-22.732,-22.722, 8 -25.312,-24.669,-24.250,-23.959,-23.746,-23.587,-23.463, 8-23.366,-23.288,-23.225,-23.173,-23.131,-23.095,-23.066,-23.041, 9 -25.394,-24.752,-24.333,-24.041,-23.829,-23.669,-23.546, 9-23.449,-23.371,-23.308,-23.256,-23.214,-23.178,-23.149,-23.124, A -25.430,-24.787,-24.369,-24.077,-23.865,-23.705,-23.582, A-23.484,-23.407,-23.344,-23.292,-23.249,-23.214,-23.185,-23.160/ DATA PARTOH/ 1 145.979, 178.033, 211.618, 247.053, 284.584, 324.398, 2 366.639, 411.425, 458.854, 509.012, 561.976, 617.823, 3 676.626, 738.448, 803.363, 871.437, 942.735, 1017.330, 4 1095.284, 1176.654, 1261.510, 1349.898, 1441.875, 1537.483, 5 1636.753, 1739.733, 1846.434, 1956.883, 2071.080, 2189.029, 6 2310.724, 2436.155, 2565.283, 2698.103, 2834.571, 2974.627, 7 3118.242, 3265.366, 3415.912, 3569.837, 3727.077/ DATA FREQ1/0./ C SBFOH=0. IF(FR.EQ.FREQ1) GO TO 30 FREQ1=FR WAVENO=FR/2.99792458E10 EVOLT=WAVENO/8065.479 N=int(EVOLT*10.-20.) EN=FLOAT(N)*.1+2. IF(N.LE.0) RETURN IF(N.GE.130) RETURN DO IT=1,15 CROSSOHT(IT)=(CROSSOH(IT,N)+(CROSSOH(IT,N+1)-CROSSOH(IT,N))* * (EVOLT-EN)*10.) END DO c c interpolate to obtain partition function c 30 IF(T.GE.9000.) RETURN IF(N.LE.0) RETURN IF(N.GE.130) RETURN IT=int((T-1000.)*twhui+1.) IF(IT.LT.1) IT=1 TN=FLOAT(IT)*twhu+800. PART=PARTOH(IT)+(PARTOH(IT+1)-PARTOH(IT))*(T-TN)*twhui c c interpolate to obtain cross-section c IT=int((T-2000.)*fihui+1.) IF(IT.LT.1) IT=1 TN=FLOAT(IT)*fihu+1500. SBFOH=EXP((CROSSOHT(IT)+(CROSSOHT(IT+1)-CROSSOHT(IT))* * (T-TN)*fihui)*tenl)*PART RETURN END C C C ******************************************************************** C C subroutine eldenc C ================= C C compare the actual electon density to that which follows C from the values used in the opacity table, interpolated to C the actual temperature and mass density C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ATOMIC.FOR' common/eletab/elecgr(mtabt,mtabr) common/eospar/anmol(600,mdepth), * anato(100,mdepth), * anion(100,mdepth) common/hmolab/anh2(mdepth),anhm(mdepth) dimension elcon(31,mdepth) c if(ipelch.gt.0) then write(6,600) 600 format(/' -------------------------'/ * ' CHECK OF ELECTRON DENSITY'/ * ' -------------------------'/ * ' ID TEMP ACTUAL LTE EOS interpol.op.tab.'/) c do id=1,nd t=temp(id) rho=dens(id) if(numtemp.eq.nd) then opac=elecgr(id,1) go to 10 end if c TTAB1=TEMPVEC(1) TTAB2=TEMPVEC(NUMTEMP) TL=LOG(T) DELTAT=(TL-TTAB1)/(TTAB2-TTAB1)*FLOAT(numtemp-1) JT = 1 + IDINT(DELTAT) IF(JT.LT.1) JT = 1 IF(JT.GT.numtemp-1) JT = numtemp-1 ju = jt+1 t1i=tempvec(jt) t2i=tempvec(jt+1) dti=(TL-T1i)/(T2i-T1i) if(deltat.lt.0.) dti = 0.d0 C if(numrh(1).ne.1) then c c lower temperature c numrho=numrh(jt) rtab1=rhomat(jt,1) rtab2=rhomat(jt,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(jt,jr) r2i=rhomat(jt,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr1=elecgr(jt,jr)+ * dri*(elecgr(jt,jr+1)-elecgr(jt,jr)) c c higher temperature c ju=jt+1 numrho=numrh(ju) rtab1=rhomat(ju,1) rtab2=rhomat(ju,numrho) RL = LOG(RHO) DELTAR=(RL-RTAB1)/(RTAB2-RTAB1)*FLOAT(numrho-1) JR = 1 + IDINT(DELTAR) IF(JR.LT.1) JR = 1 IF(JR.GT.(numrho-1)) JR = numrho-1 r1i=rhomat(ju,jr) r2i=rhomat(ju,jr+1) dri=(RL-R1i)/(R2i-R1i) if(deltar.lt.0.) dri = 0.d0 opr2=elecgr(ju,jr)+ * dri*(elecgr(ju,jr+1)-elecgr(ju,jr)) opac=opr1+(opr2-opr1)*dti else jr=1 opac=elecgr(jt,jr)+(elecgr(ju,jr)-elecgr(jt,jr))*dti end if 10 continue elecg=exp(opac) call rhonen(id,t,rho,an,ane) write(6,601) id,t,elec(id),ane,elecg 601 format(i4,f10.1,1p3e12.4) end do end if c c electron donors c if(idisk.eq.0.or.ipeldo.eq.0) return do id=1,nd t=temp(id) if(ifmol.gt.0.and.t.lt.tmolim) then rho=dens(id) call rhonen(id,t,rho,an,ane) aein=ane call moleq(id,t,an,aein,ane,enrg,entt,wm,1) do ia=1,30 elcon(ia,id)=anion(ia,id)/elec(id) end do elcon(31,id)=-anhm(id)/elec(id) else call state(2,id,t,elec(id)) do ia=1,30 iat=iatex(ia) if(iat.gt.0) then qs=0. n1=n0a(iat) if(ia.eq.1) n1=nfirst(ielh) do i=n1,nka(iat) ch=iz(iel(i))-1 if(ilk(i).gt.0) ch=iz(ilk(i)) qs=qs+ch*popul(i,id) end do elcon(ia,id)=qs/elec(id) else elcon(ia,id)=rr(ia,99)/elec(id) end if end do if(ielhm.gt.0) then elcon(31,id)=-popul(nfirst(ielhm),id)/elec(id) else aref=dens(id)/wmm(id)/ytot(id) elcon(31,id)=-qm*rr(1,1)*aref end if end if end do c write(6,611) do id=1,nd write(6,612) id,temp(id),elcon(31,id),elcon(1,id),elcon(2,id), * elcon(6,id),elcon(7,id),elcon(8,id), * (elcon(i,id),i=11,15),elcon(20,id),elcon(26,id) end do 611 format(/' RELATIVE CONTRIBUTIONS OF INDIVIDUAL ELECTRON DONORS'// * ' ID TEMP H- H He C N O', * ' Na Mg Al', * ' Si S Ca Fe') 612 format(i3,f9.1,1pe10.2,0p12f7.3) c return end C C C ******************************************************************** C C FUNCTION SFFHMI_add(POPI,FR,T) C ============================== C C Free-free cross-section for H- (negative hydrogen ion) C Taken from Kurucz ATLAS9 C C From Bell and Berrington J.Phys.B,vol. 20, 801-806,1987. C INCLUDE 'IMPLIC.FOR' PARAMETER (CONFF=5040.*1.380658E-16, CONTH=5040.) PARAMETER (HK = 4.79928144D-11) DIMENSION FFLOG(22,11),FFCS(11,22),FFLOG2(22) DIMENSION FFBEG(11,11),FFEND(11,11),FFTT(11),WFFLOG(22) DIMENSION THETAFF(11),WAVEK(22) EQUIVALENCE (FFCS(1,1),FFBEG(1,1)),(FFCS(1,12),FFEND(1,1)) C DATA WAVEK/.50,.40,.35,.30,.25,.20,.18,.16,.14,.12,.10,.09,.08, 1 .07,.06,.05,.04,.03,.02,.01,.008,.006/ DATA THETAFF/ 1 0.5, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.8, 3.6/ DATA FFBEG/ 1.0178,.0222,.0308,.0402,.0498,.0596,.0695,.0795,.0896, .131, .172, 2.0228,.0280,.0388,.0499,.0614,.0732,.0851,.0972, .110, .160, .211, 3.0277,.0342,.0476,.0615,.0760,.0908, .105, .121, .136, .199, .262, 4.0364,.0447,.0616,.0789,.0966, .114, .132, .150, .169, .243, .318, 5.0520,.0633,.0859, .108, .131, .154, .178, .201, .225, .321, .418, 6.0791,.0959, .129, .161, .194, .227, .260, .293, .327, .463, .602, 7.0965, .117, .157, .195, .234, .272, .311, .351, .390, .549, .711, 8 .121, .146, .195, .241, .288, .334, .381, .428, .475, .667, .861, 9 .154, .188, .249, .309, .367, .424, .482, .539, .597, .830, 1.07, A .208, .250, .332, .409, .484, .557, .630, .702, .774, 1.06, 1.36, B .293, .354, .468, .576, .677, .777, .874, .969, 1.06, 1.45, 1.83/ DATA FFEND/ 1 .358, .432, .572, .702, .825, .943, 1.06, 1.17, 1.28, 1.73, 2.17, 2 .448, .539, .711, .871, 1.02, 1.16, 1.29, 1.43, 1.57, 2.09, 2.60, 3 .579, .699, .924, 1.13, 1.33, 1.51, 1.69, 1.86, 2.02, 2.67, 3.31, 4 .781, .940, 1.24, 1.52, 1.78, 2.02, 2.26, 2.48, 2.69, 3.52, 4.31, 5 1.11, 1.34, 1.77, 2.17, 2.53, 2.87, 3.20, 3.51, 3.80, 4.92, 5.97, 6 1.73, 2.08, 2.74, 3.37, 3.90, 4.50, 5.01, 5.50, 5.95, 7.59, 9.06, 7 3.04, 3.65, 4.80, 5.86, 6.86, 7.79, 8.67, 9.50, 10.3, 13.2, 15.6, 8 6.79, 8.16, 10.7, 13.1, 15.3, 17.4, 19.4, 21.2, 23.0, 29.5, 35.0, 9 27.0, 32.4, 42.6, 51.9, 60.7, 68.9, 76.8, 84.2, 91.4, 117., 140., A 42.3, 50.6, 66.4, 80.8, 94.5, 107., 120., 131., 142., 183., 219., B 75.1, 90.0, 118., 144., 168., 191., 212., 234., 253., 325., 388./ DATA ISTART/0/ C IF(ISTART.EQ.0) THEN ISTART=1 DO IWAVE=1,22 WFFLOG(IWAVE)=LOG(91.134D0/WAVEK(IWAVE)) DO ITHETA=1,11 FFLOG(IWAVE,ITHETA)=LOG(FFCS(ITHETA,IWAVE)*1.E-26) END DO END DO END IF C WAVE=2.99792458E17/FR WAVELOG=LOG(WAVE) C DO ITHETA=1,11 DO IWAVE=1,22 FFLOG2(IWAVE)=FFLOG(IWAVE,ITHETA) END DO FFTLOG=YLINTP(WAVELOG,WFFLOG,FFLOG2,22,22) FFTT(ITHETA)=EXP(FFTLOG)/THETAFF(ITHETA)*CONFF END DO c THETA=CONTH/T FFTH=YLINTP(THETA,THETAFF,FFTT,11,11) SFFHMI_add=FFTH*POPI/(1.-exp(-hk*fr/t)) RETURN END C C C ****************************************************************** C C subroutine cia_h2h2(t,ah2,ff,opac) c ===================--============= c c CIA H2-H2 opacity c data from Borysow A., Jorgensen U.G., Fu Y. 2001, JQSRT 68, 235 c IMPLICIT REAL*8(A-H,O-Z) parameter (nlines=1000) dimension freq(nlines),temp(7),alpha(nlines,7) parameter (amagat=2.6867774d+19,fac=1./amagat**2) data temp / 1000. , 2000. , 3000. , 4000. , 5000. , 6000. , * 7000. / data ntemp /7/ data ifirst /0/ PARAMETER (CAS=2.997925D10) c input frequency in Hz but needed wave numbers in cm^-1 f=ff/cas c read in CIA tables if this is the first call if (ifirst.eq.0) then write(*,'(a)') 'Reading in H2-H2 CIA opacity tables...' open(10,file="./data/CIA_H2H2.dat",status='old') do i=1,3 read (10,*) end do do i=1,nlines read (10,*) freq(i),(alpha(i,j),j=1,ntemp) end do close(10) c take logarithm of tables prior to doing linear interpolations do i=1,nlines do j=1,ntemp alpha(i,j)=log(alpha(i,j)) end do end do ifirst=1 end if c locate position in temperature array call locate(temp,ntemp,t,j,ntemp) if (j.eq.0) then write(*,*) write(*,'(a,f6.0,a)') * 'Warning: requested temperature is below',temp(1),' K' write(*,'(a)') 'CIA H2-H2 opacity set to 0' write(*,*) opac=0. return end if c locate position in frequency array call locate(freq,nlines,f,i,nlines) c linearly interpolate in frequency and temperature if (j.eq.ntemp) then c hold values constant if off high temperature end of table y1=alpha(i,j) y2=alpha(i+1,j) tt=(f-freq(i))/(freq(i+1)-freq(i)) alp=(1.-tt)*y1 + tt*y2 else if (i.eq.0 .or. i.eq.nlines) then c set values to a very small number if off frequency table alp=-50. else c interpolate linearly within table y1=alpha(i,j) y2=alpha(i+1,j) y3=alpha(i+1,j+1) y4=alpha(i,j+1) tt=(f-freq(i))/(freq(i+1)-freq(i)) uu=(t-temp(j))/(temp(j+1)-temp(j)) alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 + * (1.-tt)*uu*y4 end if alp=exp(alp) c final opacity opac=fac*ah2*ah2*alp c return end C C C C ******************************************************************** C C subroutine cia_h2he(t,ah2,ahe,ff,opac) c ====================================== c c CIA H2-He opacity c data from Jorgensen U.G., Hammer D., Borysow A., Falkesgaard J., 2000, c Astronomy & Astrophysics 361, 283 c IMPLICIT REAL*8(A-H,O-Z) parameter (nlines=242) dimension freq(nlines),temp(7),alpha(nlines,7) parameter (amagat=2.6867774d+19,fac=1./amagat**2) data temp / 1000. , 2000. , 3000. , 4000. , 5000. , 6000. , * 7000. / data ntemp /7/ data ifirst /0/ PARAMETER (CAS=2.997925D10) c input frequency in Hz but needed wave numbers in cm^-1 f=ff/cas c read in CIA tables if this is the first call if (ifirst.eq.0) then write(*,'(a)') 'Reading in H2-He CIA opacity tables...' open(10,file="./data/CIA_H2He.dat",status='old') do i=1,3 read (10,*) end do do i=1,nlines read (10,*) freq(i),(alpha(i,j),j=1,ntemp) end do close(10) c take logarithm of tables prior to doing linear interpolations do i=1,nlines do j=1,ntemp alpha(i,j)=log(alpha(i,j)) end do end do ifirst=1 end if c locate position in temperature array call locate(temp,ntemp,t,j,ntemp) if (j.eq.0) then write(*,*) write(*,'(a,f6.0,a)') * 'Warning: requested temperature is below',temp(1),' K' write(*,'(a)') 'CIA H2-He opacity set to 0' write(*,*) opac=0. return end if c locate position in frequency array call locate(freq,nlines,f,i,nlines) c linearly interpolate in frequency and temperature if (j.eq.ntemp) then c hold values constant if off high temperature end of table y1=alpha(i,j) y2=alpha(i+1,j) tt=(f-freq(i))/(freq(i+1)-freq(i)) alp=(1.-tt)*y1 + tt*y2 else if (i.eq.0 .or. i.eq.nlines) then c set values to a very small number if off frequency table alp=-50. else c interpolate linearly within table y1=alpha(i,j) y2=alpha(i+1,j) y3=alpha(i+1,j+1) y4=alpha(i,j+1) tt=(f-freq(i))/(freq(i+1)-freq(i)) uu=(t-temp(j))/(temp(j+1)-temp(j)) alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 + * (1.-tt)*uu*y4 end if alp=exp(alp) c final opacity opac=fac*ah2*ahe*alp c return end C C C ******************************************************************** C C subroutine cia_h2h(t,ah2,ah,ff,opac) c ==================================== c c CIA H2-H opacity - data taken from TURBOSPEC c IMPLICIT REAL*8(A-H,O-Z) parameter (nlines=67) dimension freq(nlines),temp(4),alpha(nlines,4) parameter (amagat=2.6867774d+19,fac=1./amagat**2) data temp / 1000. , 1500., 2000. , 2500. / data ntemp /4/ data ifirst /0/ PARAMETER (CAS=2.997925D10) c input frequency in Hz but needed wave numbers in cm^-1 f=ff/cas c read in CIA tables if this is the first call if (ifirst.eq.0) then write(*,'(a)') 'Reading in H2-H CIA opacity tables...' open(10,file="./data/CIA_H2H.dat",status='old') do i=1,3 read (10,*) end do do i=1,nlines read (10,*) freq(i),(alpha(i,j),j=1,ntemp) end do close(10) c take logarithm of tables prior to doing linear interpolations do i=1,nlines do j=1,ntemp alpha(i,j)=log(alpha(i,j)) end do end do ifirst=1 end if c locate position in temperature array if(t.gt.2500.) return call locate(temp,ntemp,t,j,ntemp) if (j.eq.0) then write(*,*) write(*,'(a,f6.0,a)') * 'Warning: requested temperature is below',temp(1),' K' write(*,'(a)') 'CIA H2-H CIA opacity set to zero' write(*,*) opac=0. return end if c locate position in frequency array call locate(freq,nlines,f,i,nlines) c linearly interpolate in frequency and temperature if (j.eq.ntemp) then c hold values constant if off high temperature end of table y1=alpha(i,j) y2=alpha(i+1,j) tt=(f-freq(i))/(freq(i+1)-freq(i)) alp=(1.-tt)*y1 + tt*y2 else if (i.eq.0 .or. i.eq.nlines) then c set values to a very small number if off frequency table alp=-50. else c interpolate linearly within table y1=alpha(i,j) y2=alpha(i+1,j) y3=alpha(i+1,j+1) y4=alpha(i,j+1) tt=(f-freq(i))/(freq(i+1)-freq(i)) uu=(t-temp(j))/(temp(j+1)-temp(j)) alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 + * (1.-tt)*uu*y4 end if alp=exp(alp) c final opacity opac=fac*ah2*ah*alp c return end C C C ******************************************************************* C C subroutine cia_hhe(t,ah,ahe,ff,opac) c ==================================== c c CIA H-He opacity c data from Gustafsson M., Frommhold, L. 2001, ApJ 546, 1168 c IMPLICIT REAL*8(A-H,O-Z) parameter (nlines=43) dimension freq(nlines),temp(11),alpha(nlines,11) parameter (amagat=2.6867774d+19,fac=1./amagat**2) data temp / 1000., 1500., 2250., 3000., 4000., 5000., * 6000., 7000., 8000., 9000., 10000./ data ntemp /11/ data ifirst /0/ PARAMETER (CAS=2.997925D10) c input frequency in Hz but needed wave numbers in cm^-1 f=ff/cas c read in CIA tables if this is the first call if (ifirst.eq.0) then write(*,'(a)') 'Reading in H-He CIA opacity tables...' open(10,file="./data/CIA_HHe.dat",status='old') do i=1,3 read (10,*) end do do i=1,nlines read (10,*) freq(i),(alpha(i,j),j=1,ntemp) end do close(10) c take logarithm of tables prior to doing linear interpolations do i=1,nlines do j=1,ntemp alpha(i,j)=log(alpha(i,j)) end do end do ifirst=1 end if c locate position in temperature array call locate(temp,ntemp,t,j,ntemp) if (j.eq.0) then write(*,*) write(*,'(a,f6.0,a)') * 'Warning: requested temperature is below',temp(1),' K' write(*,'(a)') 'CIA H-He opacity set to 0' write(*,*) opac=0. return end if c locate position in frequency array call locate(freq,nlines,f,i,nlines) c linearly interpolate in frequency and temperature if (j.eq.ntemp) then c hold values constant if off high temperature end of table y1=alpha(i,j) y2=alpha(i+1,j) tt=(f-freq(i))/(freq(i+1)-freq(i)) alp=(1.-tt)*y1 + tt*y2 else if (i.eq.0 .or. i.eq.nlines) then c set values to a very small number if off frequency table alp=-50. else c interpolate linearly within table y1=alpha(i,j) y2=alpha(i+1,j) y3=alpha(i+1,j+1) y4=alpha(i,j+1) tt=(f-freq(i))/(freq(i+1)-freq(i)) uu=(t-temp(j))/(temp(j+1)-temp(j)) alp=(1.-tt)*(1.-uu)*y1 + tt*(1.-uu)*y2 + tt*uu*y3 + * (1.-tt)*uu*y4 end if alp=exp(alp) c final opacity opac=fac*ah*ahe*alp c return end C C C ******************************************************************* C C subroutine h2minus(t,anh2,ane,fr,oph2m) C ======================================= C C H- free-free opacity C C 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 'IMPLIC.FOR' INCLUDE 'BASICS.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 end if flamb=2.997925e18/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 end if pe=ane*BOLK*t oph2m= anh2 * 1.0E-26 *pe * Fkappa return end c c c ********************************************************************** c c subroutine prnt c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' dimension ipop(4) c data ipop /98,99,100,115/ c do id=1,nd,69 hkt=hk/temp(id) ane=elec(id) call sabolf(id) c do k=1,4 do k=3,3 ii=ipop(k)-3 iat=iatm(ii) ie=iel(ii) psum=0. psuu=0. do j=n0a(iat),nka(iat) psum=psum+popul(j,id) if(ilk(j).gt.0) * psuu=psuu+usum(ilk(j))*elec(id)*popul(j,id) end do BB=DENS(ID)/WMM(ID)/YTOT(ID)*ABUND(IAT,ID) rin=0. rou=0. c write(63,601) id,ii,psum,bb,popul(ii,id) do jj=nfirst(ie),ii-1 itr=itra(jj,ii) ru=rru(itr,id)*wop(ii,id) cu=colrat(itr,id)*wop(ii,id) if(ii.le.nlast(ie)) then rd=rrd(itr,id)*g(jj)/g(ii)*exp(hkt*fr0(itr))*wop(jj,id) else rd=rrd(itr,id)*sbf(jj)*ane*wop(jj,id) end if cd=coltar(itr,id)*wop(jj,id) c write(63,602) jj,itr,popul(jj,id),ru,cu,rd,cd rin=rin+(ru+cu)*popul(jj,id) rou=rou+(rd+cd)*popul(ii,id) end do c do jj=ii+1,nnext(ie) itr=itra(ii,jj) ru=rru(itr,id)*wop(jj,id) cu=colrat(itr,id)*wop(jj,id) if(jj.le.nlast(ie)) then rd=rrd(itr,id)*g(ii)/g(jj)*exp(hkt*fr0(itr))*wop(ii,id) else rd=rrd(itr,id)*sbf(ii)*ane*wop(ii,id) end if cd=coltar(itr,id)*wop(ii,id) c write(63,602) jj,itr,popul(jj,id),rd,cd,ru,cu rou=rou+(ru+cu)*popul(ii,id) rin=rin+(rd+cd)*popul(jj,id) end do c c write(63,603) id,ii,rou,rin,(rou-rin)/rin end do c write(63,*) end do c write(63,*) '==============================' c write(63,*) c c 601 format('id,ii',2i4,1p4e12.4) c 602 format(' jj ',i4,i5,1p5e12.4) c 603 format('iitot',2i4,1p3e12.4/) c return end c c ********************************************************************** c c subroutine rechck c ================= c c check of radiative equilibrium - integral version c INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' dimension abt(mdepth),emt(mdepth) c do id=1,nd abt(id)=0. emt(id)=0. end do c do ij=1,nfreq call opacf1(ij) call rtefr1(ij) do id=1,nd abt(id)=abt(id)+(abso1(id)-scat1(id))*rad1(id)*w(ij) emt(id)=emt(id)+emis1(id)*w(ij) end do end do c write(17,600) 600 format(/' id dm T int(kappa*J) int(emis) rel'/) do id=1,nd re=(abt(id)-emt(id))/emt(id) write(17,601) id,dm(id),temp(id),abt(id),emt(id),re end do 601 format(i4,1pe11.3,0pf10.1,2x,1p3e13.5) c return end c c ********************************************************************** c c SUBROUTINE LYMLIN(IJ) C ===================== C C opacity and emissibvity in first 30 Lyman lines C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' C PARAMETER (SIXTH=1./6.,TTW=2./3., * OS0=0.02654,CPP=4.1412E-16,CPJ=157803., * C00=1.25E-9,C18=2.997925E18) PARAMETER (MLEVL=30) C DIMENSION ABLYM(MDEPTH),EMLYM(MDEPTH), * XKIJL(MLEVL),FIJL(MLEVL),WL0L(MLEVL),FR0L(MLEVL), * F00(MDEPTH),DOP0(MDEPTH),PJ(MLEVL,MDEPTH), * ABTR(MLEVL,MDEPTH),EMTR(MLEVL,MDEPTH),FID(MLEVL,MDEPTH), * AD0(MLEVL,MDEPTH),DIV0(MLEVL,MDEPTH), * DBET0(MLEVL,MDEPTH),BETAD0(MLEVL,MDEPTH) C DATA INIP/1/ C IF(IELH.EQ.0) RETURN C FR=FREQ(IJ) IF(FR.GT.3.28805E15.OR.FR.LT.1.5E15) RETURN C IF(INIP.EQ.1) THEN N0H=NFIRST(IELH) N1H=NLAST(IELH) NKH=NNEXT(IELH) NLH=N1H-N0H XII=1. DO J=2,30 CALL STARK0(1,J,1,XKIJ0,WL00,FIJ0) XKIJL(J)=XKIJ0 FIJL(J)=FIJ0 WL0L(J)=WL00 FR0L(J)=C18/WL0L(J) END DO DO ID=1,ND T=TEMP(ID) T1=1./T SQT=SQRT(T) ANE=ELEC(ID) ANP=POPUL(NKH,ID) F00(ID)=C00*ANE**TTW DOP0(ID)=1.E8*SQRT(1.65E8*T+VTURB(ID)) C P0=CPP*ANE*ANP*T1/SQT P1=POPUL(N0H,ID) DO J=2,30 X=J*J JJ=N0H+J-1 XJJ=1./JJ IF(J.LE.NLH) THEN PJ(J,ID)=POPUL(JJ,ID) ELSE PJ(J,ID)=P0*EXP(CPJ/(X*T))*X*WNHINT(J,ID) END IF ABTR(J,ID)=P1*WNHINT(J,ID) EMTR(J,ID)=PJ(J,ID)*XJJ*EXP(CPJ*(XII-XJJ)*T1) C FXK=F00(ID)*XKIJL(J) DBETA=WL0L(J)*WL0L(J)/(C18*FXK) FID(J,ID)=OS0*FIJL(J)*DBETA DOP=DOP0(ID)/WL0L(J) BETAD=DOP*DBETA CALL DIVSTR(1) AD0(J,ID)=ADH DIV0(J,ID)=DIVH DBET0(J,ID)=DBETA BETAD0(J,ID)=BETAD END DO END DO INIP=0 END IF C FR=FREQ(IJ) WL=C18/FR F15=FR*1.E-15 DO ID=1,ND ABLYM(ID)=0. EMLYM(ID)=0. DO J=2,30 BETA=DBET0(J,ID)*ABS(FR-FR0L(J)) BETAD=BETAD0(J,ID) ADH=AD0(J,ID) DIVH=DIV0(J,ID) SG=STARKA(BETA,TWO)*FID(J,ID) ABLYM(ID)=ABLYM(ID)+SG*ABTR(J,ID) EMLYM(ID)=EMLYM(ID)+SG*EMTR(J,ID) c if(wl.gt.1120.0.and.wl.lt.1120.3.and.id.eq.50) c * write(6,600) j,fr,fr0l(j),abs(fr-fr0l(j)), c * dbet0(j,id),beta,fid(j,id),sg,abtr(j,id), c * emtr(j,id),sg*abtr(j,id),ablym(id) c if(wl.gt.1120.0.and.wl.lt.1120.3.and.id.eq.50) c * write(6,600) j,fid(j,id),dbet0(j,id),wl0l(j),xkijl(j), c * dop0(id),fijl(j) c 600 format('lymsig',i4,1p11e11.3) END DO XKT=EXP(-4.79928e-11*FR/TEMP(ID)) XKB=XKT*1.4743E-2*F15*F15*F15 ABLYM(ID)=ABLYM(ID)-XKT*EMLYM(ID) EMLYM(ID)=XKB*EMLYM(ID) ABSO1(ID)=ABSO1(ID)+ABLYM(ID) EMIS1(ID)=EMIS1(ID)+EMLYM(ID) c if(wl.gt.1120.0.and.wl.lt.1120.3) c * write(6,601) ij,wl,ablym(50),emlym(50),xkt,xkb c 601 format('lymlin',i6,f10.3,1p4e11.3) END DO RETURN END