SUBROUTINE LINOPW(ID,ABLIN,EMLIN) C ================================= C C TOTAL LINE OPACITY (ABLIN) AND EMISSIVITY (EMLIN) C (a variant for winds) C INCLUDE 'PARAMS.FOR' INCLUDE 'MODELP.FOR' INCLUDE 'SYNTHP.FOR' INCLUDE 'LINDAT.FOR' INCLUDE 'WINCOM.FOR' COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC PARAMETER (UN = 1., * EXT0 = 3.17, * TEN = 10., * C3 = 1.4387886, * XET = 8067.6, * XET3 = XET*C3) DIMENSION ABLIN(MFREQ),EMLIN(MFREQ),ABLINN(MFREQ) COMMON/PRFQUA/DOPA1(MATOM,MDEPTH),VDWC(MDEPTH) COMMON/NLTPOP/PNLT(MATOM,MION,MDEPTH) COMMON/IPOTLS/IPOTL(mlin0) common/lasers/lasdel common/linrej/ilne(mdepth),ilvi(mdepth) common/velaux/velmax,iemoff,nltoff,itrad C DO 10 IJ=1,NFREQ ABLIN(IJ)=0. ABLINN(IJ)=0. EMLIN(IJ)=0. 10 CONTINUE wdil(id)=1. plw=plan(id)*wdil(id) c plw=xjcon(id) C IF(NLIN.EQ.0) RETURN C C overall loop over contributing lines C TEM1=UN/TEMP(ID) HKT=HK*TEM1 xx=freq(nopac)-freq(1) DFRCON=NOPAC-1 DFRCON=-DFRCON/XX IFRCON=int(DFRCON) DO 100 I=1,NLIN IL=INDLIN(I) INNLT=INDNLT(IL) c c rejecting lines for v > velmax c if(ilvi(id).gt.0) then if(innlt.eq.0) then go to 100 else if(nltoff.ne.0) go to 100 end if end if c c c frequency indices of the line centers c if (id.eq.1) then fr0=freq0(il) XJC=3.+DFRCON*(FREQ(1)-FR0) IJC=int(XJC) IJCNTR(I)=IJC if(ijc.le.1.or.ijc.ge.nopac) go to 255 if(fr0.lt.freq(ijc)) then ijc0=ijc dfr0=freq(ijc0)-fr0 252 ijc0=ijc0+1 dfr=abs(freq(ijc0)-fr0) if(dfr.lt.dfr0) then ijc=ijc0 ijc0=ijc0+1 dfr0=dfr go to 252 end if else if(fr0.gt.freq(ijc)) then ijc0=ijc dfr0=fr0-freq(ijc0) 254 ijc0=ijc0-1 dfr=abs(freq(ijc0)-fr0) if(dfr.lt.dfr0) then ijc=ijc0 ijc0=ijc0-1 dfr0=dfr go to 254 end if end if IJCNTR(I)=IJC 255 continue c write(80,*) i,ijcntr(i),2.997925e18/freq0(il) endif c IAT=INDAT(IL)/100 ION=MOD(INDAT(IL),100) FR0=FREQ0(IL) LPR=.TRUE. ISP=ISPRF(IL) IF(ISP.GT.1.AND.ISP.LE.5) LPR=.FALSE. IF (ISP.GE.6) GO TO 100 CALL PROFIL(IL,IAT,ID,AGAM) DOP1=DOPA1(IAT,ID)/FR0 FR0=FREQ0(IL) IF(INNLT.EQ.0) THEN if(itrad.le.0) then AB0=EXP(GF0(IL)-EXCL0(IL)*TEM1)*RRR(ID,ION,IAT)* * DOP1*(1.-exp(-hkt*fr0)) else trl=trad(ipotl(il),id) xx=exp(-hkt*fr0) AB0=EXP(GF0(IL)-EXCL0(IL)/trl)*RRR(ID,ION,IAT)* * DOP1*(1.-xx) if(excl0(il).gt.2000.) ab0=ab0*wdil(id) pla=1.4743e-2*(fr0*1.e-15)**3*xx/(1.-xx) sl0=pla*wdil(id) end if ELSE IF(INNLT.GT.0) THEN AB0=ABCENT(INNLT,ID) SL0=SLIN(INNLT,ID) ELSE ILW=ILOWN(IL) IUN=IUPN(IL) COR=1. PP=PNLT(IAT,ION,ID) IF(ILW.GT.0) THEN PI=POPUL(ILW,ID)/G(ILW) ELSE PI=PP*EXP((ENEV(IAT,ION)*XET3-EXCL0(IL))*TEM1) END IF IF(IUN.GT.0) THEN PJ=POPUL(IUN,ID)/G(IUN) cor=(excu0(il)-excl0(il)+ * (enion(iun)-enion(ilw))/1.38054e-16)*tem1 cor=exp(cor) ELSE PJ=PP*EXP((ENEV(IAT,ION)*XET3-EXCU0(IL))*TEM1) END IF if(pj.gt.0.) then X=PI/PJ*cor else x=un end if IF(X.EQ.UN) X=EXP(4.79928E-11*FREQ0(IL)*TEM1) SL0=BNUL(IL)/(X-UN) ab0=0. if(pi.gt.0.) AB0=PI*(UN-UN/X)*EXP(GF0(IL))*DOP1 END IF if(ab0.le.0.and.lasdel) go to 100 C C set up limiting frequencies where the line I is supposed to C contribute to the opacity C c if(ifwin.le.0) then avabw=abstdw(ijcont(il),id)*relop EX0=AB0/AVABw*AGAM EXT=EXT0 IF(EX0.GT.TEN) EXT=SQRT(EX0) EXT=EXT/DOP1 IJEXT=int((DFRCON*EXT)+1.5) IJ1=MAX(IJCNTR(I)-IJEXT,1) IJ2=MIN(IJCNTR(I)+IJEXT,NFREQ) IF(IJ1.GE.NFREQ.OR.IJ2.LE.2) GO TO 100 c else c ij1=3 c ij2=nfreq c end if C IF(INNLT.EQ.0.and.itrad.le.0) THEN C C ********* C LTE lines C ********* C IF(LPR) THEN C DO 40 IJ=IJ1,IJ2 XF=ABS(FREQ(IJ)-FR0)*DOP1 ABLIN(IJ)=ABLIN(IJ)+AB0*VOIGTK(AGAM,XF) 40 CONTINUE C C special expressions for 4 selected He I lines C ELSE DO 60 IJ=1,NFREQ FR=FREQ(IJ) ABL=AB0*PHE1(ID,FR,ISP-1) ABLIN(IJ)=ABLIN(IJ)+ABL 60 CONTINUE END IF C C ********** C NLTE LINES C ********** C ELSE IF(LPR) THEN C DO 80 IJ=IJ1,IJ2 XF=ABS(FREQ(IJ)-FR0)*DOP1 ABL=AB0*VOIGTK(AGAM,XF) ABLINN(IJ)=ABLINN(IJ)+ABL if(ilne(id).gt.0) go to 80 EMLIN(IJ)=EMLIN(IJ)+ABL*SL0 80 CONTINUE C C again, special expressions for 4 selected He I lines C ELSE DO 90 IJ=1,NFREQ FR=FREQ(IJ) ABL=AB0*PHE1(ID,FR,ISP-1) ABLINN(IJ)=ABLINN(IJ)+ABL if(ilne(id).gt.0) go to 90 EMLIN(IJ)=EMLIN(IJ)+ABL*SL0 90 CONTINUE END IF END IF 100 CONTINUE C if(vel(id).le.velmax) then DO 110 IJ=1,NFREQ PLA=BNUE(IJ)/(EXP(HKT*FREQ(IJ))-1.) EMLIN(IJ)=EMLIN(IJ)+ABLIN(IJ)*pla*wdil(id) ABLIN(IJ)=ABLIN(IJ)+ABLINN(IJ) 110 CONTINUE end if C C special routine for selected He II lines C IF(NSP.EQ.0) RETURN DO 120 IS=1,NSP ISP=ISP0(IS) IF(ISP.GE.6.AND.ISP.LE.24) CALL PHE2(ISP,ID,ABLIN,EMLIN) 120 CONTINUE C RETURN END