PROGRAM SPECTRV c revised 16dec97 IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (kw=99) COMMON /ABROSS/ABROSS(kw),TAUROS(kw) COMMON /ABTOT/ABTOT(kw),ALPHA(kw) COMMON /BAL/BAL1(kw,9),AAL1(kw),SAL1(kw),XNFPAL(kw,2),BAL2(kw,1) COMMON /BB/BB1(kw,7),XNFPB(kw,1) COMMON /BC/BC1(kw,14),AC1(kw),SC1(kw),XNFPC(kw,2),BC2(kw,6) COMMON /BCA/BCA1(kw,8),BCA2(kw,5),XNFPCA(kw,2) COMMON /BFE/BFE1(kw,15),AFE1(kw),SFE1(kw),XNFPFE(kw,1) COMMON /BHE/BHE1(kw,29),AHE1(kw),SHE1(kw),BHE2(kw,6),AHE2(kw), 1 SHE2(kw),AHEMIN(kw),SIGHE(kw),XNFPHE(kw,3),XNFHE(kw,2) COMMON /BHYD/BHYD(kw,8),AHYD(kw),SHYD(kw),AH2P(kw),BMIN(kw), 1 AHMIN(kw),SHMIN(kw),SIGH(kw),SIGH2(kw),AHLINE(kw), 2 SHLINE(kw),XNFPH(kw,2),XNFH(kw) COMMON /BK/BK1(kw,8),XNFPK(kw,1) COMMON /BMG/BMG1(kw,11),AMG1(kw),SMG1(kw),XNFPMG(kw,2),BMG2(kw,6) COMMON /BNA/BNA1(kw,8),XNFPNA(kw,1) COMMON /BO/BO1(kw,13),XNFPO(kw,1),BO2(kw,4) COMMON /BSI/BSI1(kw,11),ASI1(kw),SSI1(kw),XNFPSI(kw,2),BSI2(kw,10) COMMON /CONV/DLTDLP(kw),HEATCP(kw),DLRDLT(kw),VELSND(kw), 1 GRDADB(kw),HSCALE(kw),FLXCNV(kw),VCONV(kw),MIXLTH, 2 IFCONV REAL*8 MIXLTH COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99),XABUND(99),WTMOLE COMMON /FLUX/FLUX,FLXERR(kw),FLXDRV(kw),FLXRAD(kw) COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw),WAVENO COMMON /FRESET/FRESET(500),RCOSET(500),NULO,NUHI,NUMNU,IFWAVE, 1 WBEGIN,DELTAW COMMON /HEIGHT/HEIGHT(kw) COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,IFMOL,NLTEON,IFOP(20) COMMON /ITER/ITER,IFPRNT(15),IFPNCH(15),NUMITS COMMON /JUNK/TITLE(74),FREQID(6),WLTE,XSCALE COMMON /MUS/ANGLE(20),SURFI(20),NMU COMMON /OPS/ACOOL(kw),ALUKE(kw),AHOT(kw),SIGEL(kw),ALINES(kw), 1 SIGLIN(kw),AXLINE(kw),SIGXL(kw),AXCONT(kw),SIGX(kw), 2 SXLINE(kw),SXCONT(kw) COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw), 1 SIGMAL(kw) COMMON /PUT/PUT,IPUT COMMON /PZERO/PZERO,PCON,PRADK0,PTURB0,KNU(kw),PRADK(kw),EDENS(kw) REAL*8 KNU COMMON /RAD/ACCRAD(kw),PRAD(kw) COMMON /RHOX/RHOX(kw),NRHOX COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw),PTOTAL(kw) COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw) REAL*8 JNU,JMINS COMMON /TEFF/TEFF,GRAV,GLOG COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),HCKT(kw),ITEMP COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND, 1 IFTURB C COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 4,ALINEC(kw) REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RESOLU,RATIO,RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 REAL*4 GFLOG,XJ,XJP,CODE,GAMMAR,GAMMAS,GAMMAW REAL*4 REF,X1,X2,ELO,GF,GS,GR,GW REAL*4 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*4 ALINEC COMMON /TRASH/WLBEG,WLEND,VT,AIR,N10,IFVAC,NMU2 COMMON /CORONO/RHOXCO(42),TCO(42),XNECO(42),SCO(42),TCOLOG(42), 1 VCO(42),ACORON(42),SCORON(42),IFCORO,NCORO COMMON /BONE/BONE(kw) COMMON /PRD/PRDDOP,PRDPOW,ITPRD,NITPRD,SIGPRD(kw),NUPRD,LINPRD REAL*4 TURBV C DIMENSION FSCAT(kw),ASYNTH(kw) DIMENSION FSCAT(kw) REAL*4 ASYNTH(kw) DIMENSION FRQEDG(377),WLEDGE(377),CMEDGE(377),CONFRQ(377) DIMENSION DELEDGE(377),HALFEDGE(377) REAL*8 CONTABS(3,377,kw),CONTSCAT(3,377,kw) REAL*8 QCONTABS(1131),QCONTSCAT(1131) DIMENSION BFUDGE(kw) C 41=2*20+1 SO NOT EQUAL 40 DIMENSION Q(41) DIMENSION SURF(20) DIMENSION APLOT(101) DATA APLOT/101*1H / C RHOXJ IS THE DEPTH ABOVE WHICH THE LINE SOURCE FUNCTION IS J C R1 IS THE RESIDUAL INTENSITY AT THE BOTTOM OF THE PLOT C R2 IS THE RESIDUAL INTENSITY AT THE TOP C PRDPOW AND PRDDOP ARE PARTIAL REDISTRIBUTION PARAMETERS C CALL BEGTIME READ(25,1)RHOXJ,R1,R101,PH1,PC1,PSI1,PRDDOP,PRDPOW 1 FORMAT(8F10.5) WRITE(6,1)RHOXJ,R1,R101,PH1,PC1,PSI1,PRDDOP,PRDPOW SLOPE=100./(R101-R1) ORIGIN=1.5-R1*SLOPE OPEN(UNIT=5,SHARED,READONLY,TYPE='OLD') CALL READIN(20) IF(IFSURF.EQ.0)THEN WRITE(6,*)' SURFACE FLUX OR SURFACE INTENSITY?' CALL ABORT ENDIF C OPEN(UNIT=10,TYPE='OLD',FORM='UNFORMATTED',READONLY,SHARED) READ(10) READ(10)NEDGE,(FRQEDG(IEDGE),WLEDGE(IEDGE),CMEDGE(IEDGE), 1IEDGE=1,NEDGE) READ(10)NCON,(CONFRQ(NU),NU=1,NCON) WLEDGE(1)=ABS(WLEDGE(1)) DO 2001 IEDGE=2,NEDGE WLEDGE(IEDGE)=ABS(WLEDGE(IEDGE)) HALFEDGE(IEDGE-1)=(WLEDGE(IEDGE-1)+WLEDGE(IEDGE))*.5 2001 DELEDGE(IEDGE-1)=(WLEDGE(IEDGE)-WLEDGE(IEDGE-1))**2*.5 READ(10) IREC=0 DO 2003 J=1,NRHOX READ(10) READ(10)QCONTABS READ(10)QCONTSCAT READ(10) NU=0 DO 2002 IEDGE=1,NEDGE-1 NU=NU+1 CONTABS(1,IEDGE,J)=QCONTABS(NU) CONTSCAT(1,IEDGE,J)=QCONTSCAT(NU) NU=NU+1 CONTABS(2,IEDGE,J)=QCONTABS(NU) CONTSCAT(2,IEDGE,J)=QCONTSCAT(NU) NU=NU+1 CONTABS(3,IEDGE,J)=QCONTABS(NU) 2002 CONTSCAT(3,IEDGE,J)=QCONTSCAT(NU) 2003 CONTINUE CLOSE(UNIT=10) C IFPRES=0 ITEMP=1 C CALL POPS(1.00D0,12,XNFH) C CALL POPS(2.01D0,12,XNFHE) C CALL POPS(1.01D0,11,XNFPH) C CALL POPS(2.02D0,11,XNFPHE) C CALL POPS(5.00D0,11,XNFPB) C CALL POPS(6.01D0,11,XNFPC) C CALL POPS(8.00D0,11,XNFPO) C CALL POPS(11.00D0,11,XNFPNA) C CALL POPS(12.01D0,11,XNFPMG) C CALL POPS(13.01D0,11,XNFPAL) C CALL POPS(14.01D0,11,XNFPSI) C CALL POPS(20.01D0,11,XNFPCA) C CALL POPS(26.00D0,11,XNFPFE) CLOSE(UNIT=5) C IF(IFMOL.EQ.0.)GO TO 445 CC PATCH TO GET NUMBER DENSITIES BY MULTIPLYING BY PARTITION FUNCTION C DO 444 J=1,NRHOX C CALL PFSAHA(J,1,1,3,XNFH) C XNFH(J)=XNFPH(J,1)*XNFH(J) C CALL PFSAHA(J,2,2,13,XNFHE) C XNFHE(J,1)=XNFPHE(J,1)*XNFHE(J,1) C XNFHE(J,2)=XNFPHE(J,2)*XNFHE(J,2) C 444 CONTINUE C 445 CONTINUE CC CALL W(6HXNFPH ,XNFPH ,80) CC CALL W(6HXNFPHE,XNFPHE,120) CC CALL W(6HXNFPC ,XNFPC ,80) CC CALL W(6HXNFPMG,XNFPMG,80) CC CALL W(6HXNFPAL,XNFPAL,80) CC CALL W(6HXNFPSI,XNFPSI,80) DO 4 J=1,NRHOX BONE(J)=1. BFUDGE(J)=BHYD(J,1)**PH1*(BC1(J,1)/BC2(J,1))**PC1* 1(BSI1(J,1)/BSI2(J,1))**PSI1 IF(RHOXJ.EQ.0.)GO TO 4 FSCAT(J)=0. IF(RHOX(J)/RHOXJ.LT.100.)FSCAT(J)=EXP(-RHOX(J)/RHOXJ) 4 CONTINUE CALL W(6HFSCAT ,FSCAT,NRHOX) CALL W(6HBFUDGE,BFUDGE,NRHOX) 5 CONTINUE IFPRES=0 ITEMP=1 REWIND 7 REWIND 9 READ(9)WLBEG,RESOLU,WLEND,LENGTH,N,LINOUT,TURBV,IFVAC READ (9)NEDGE,(FRQEDG(IEDGE),WLEDGE(IEDGE),CMEDGE(IEDGE), 1IEDGE=1,NEDGE) C PATCH TO PASS IFVAC TO PLOTSY TITLE(74)=1HA IF(IFVAC.EQ.1)TITLE(74)=1HV N30=N+30 WRITE(6,11)WLBEG,RESOLU,WLEND,LENGTH,N 11 FORMAT(7H WLBEG=,F10.4,10H RESOLU=,F10.1,9H WLEND=,F10.4, 110H LENGTH=,I7,9H NRHOX=,I2) N10=0 DO 6 J=1,NRHOX 6 VTURB(J)=VTURB(J)+TURBV*1.E5 RATIO=1.+1./RESOLU RATIOLG=DLOG(RATIO) IXWL=DLOG(WLBEG)/RATIOLG WBEGIN=DEXP(IXWL*RATIOLG) IF(WBEGIN.LT.WLBEG)THEN IXWL=IXWL+1 WBEGIN=DEXP(IXWL*RATIOLG) ENDIF DELTAW=RESOLU NULO=1 NUHI=LENGTH NUMNU=LENGTH WLBEG=WBEGIN WLEND=WBEGIN*RATIO**(NUHI-1) WRITE(6,31)NUMNU,DELTAW,WLBEG,WLEND 31 FORMAT(I10,3F13.4) IF(IFSURF.EQ.1)WRITE(6,41) 41 FORMAT(13H SURFACE FLUX) IF(IFSURF.EQ.2)WRITE(6,42)NMU,(ANGLE(MU),MU=1,NMU) 42 FORMAT(18H SURFACE INTENSITY,I3/20F6.3) NMU2=NMU*2 C IF(PRDDOP.GT.0.)CALL PRDJNU(RHOXJ) IEDGE=1 DO 25 NU=NULO,NUHI C NUPRD=NU WAVE=WBEGIN*RATIO**(NU-1) 2004 IF(WAVE.LT.WLEDGE(IEDGE+1))GO TO 2005 IEDGE=IEDGE+1 GO TO 2004 C C1=(WAVE-WAVE2)*(WAVE-WAVE3)/(WAVE1-WAVE2)/(WAVE1-WAVE3) C C2=(WAVE-WAVE1)*(WAVE-WAVE3)/(WAVE2-WAVE1)/(WAVE2-WAVE3) C C3=(WAVE-WAVE1)*(WAVE-WAVE2)/(WAVE3-WAVE1)/(WAVE3-WAVE2) 2005 C1=(WAVE-HALFEDGE(IEDGE))*(WAVE-WLEDGE(IEDGE+1))/DELEDGE(IEDGE) C2=(WLEDGE(IEDGE)-WAVE)*(WAVE-WLEDGE(IEDGE+1))*2./DELEDGE(IEDGE) C3=(WAVE-WLEDGE(IEDGE))*(WAVE-HALFEDGE(IEDGE))/DELEDGE(IEDGE) DO 2006 J=1,NRHOX ACONT(J)=10.**(C1*CONTABS(1,IEDGE,J)+C2*CONTABS(2,IEDGE,J)+ 1 C3*CONTABS(3,IEDGE,J)) 2006 SIGMAC(J)=10.**(C1*CONTSCAT(1,IEDGE,J)+C2*CONTSCAT(2,IEDGE,J)+ 1 C3*CONTSCAT(3,IEDGE,J)) C FREQ=2.99792458E17/WAVE FREQ15=FREQ/1.E15 FREQLG= LOG(FREQ) DO 20 J=1,NRHOX EHVKT(J)=EXP(-FREQ*HKT(J)) STIM(J)=1.-EHVKT(J) BNU(J)=1.47439E-02*FREQ15**3*EHVKT(J)/STIM(J) ALINE(J)=0. SIGMAL(J)=0. SLINE(J)=BNU(J) 20 SCONT(J)=BNU(J) CALL JOSH(IFSCAT,IFSURF) DO 21 MU=1,NMU IF(IFSURF.EQ.1)SURF(MU)=HNU(1) IF(IFSURF.EQ.2)SURF(MU)=SURFI(MU) 21 CONTINUE C IF(IFOP(14).EQ.1)CALL HLINOP C IF(IFOP(17).EQ.1)CALL XLINOP IF(NU.EQ.1)WRITE(6,33) 33 FORMAT(1H1) READ(9)ASYNTH DO 241 J=1,NRHOX C ALINE(J)=AHLINE(J)+ASYNTH(J)*(1.-FSCAT(J))+AXLINE(J) ALINE(J)=ASYNTH(J)*(1.-FSCAT(J)) C SLINE(J)=BNU(J) C ASSUMES BUP=1 C SSYNTH=BNU(J)*STIM(J)/(BFUDGE(J)-EHVKT(J)) SLINE(J)=BNU(J)*STIM(J)/(BFUDGE(J)-EHVKT(J)) C IF(ALINE(J).GT.0.)SLINE(J)=(AHLINE(J)*SHLINE(J)+ASYNTH(J)*SSYNTH* C 1(1.-FSCAT(J))+AXLINE(J)*SXLINE(J))/ALINE(J) 241 SIGMAL(J)=ASYNTH(J)*FSCAT(J) CALL JOSH(1,IFSURF) 24 DO 250 MU=1,NMU IF(IFSURF.EQ.1)RESID=HNU(1)/SURF(MU) IF(IFCORO.EQ.1)CALL CORINT IF(IFSURF.EQ.2)RESID=SURFI(MU)/SURF(MU) IF(NU.GT.ABS(LINOUT))GO TO 230 IF(MU.GT.1)GO TO 230 IRESID=RESID*1000.+.5 IPLOT=RESID*SLOPE+ORIGIN IPLOT=MAX0(1,MIN0(101,IPLOT)) APLOT(IPLOT)=1HX WRITE(6,2300)NU,WAVE,IRESID,APLOT 2300 FORMAT(1H ,I5,F11.4,I7,101A1) APLOT(IPLOT)=(1H ) 230 CONTINUE Q(MU)=RESID*SURF(MU) Q(MU+NMU)=SURF(MU) 250 CONTINUE IF(NU.GT.1)GO TO 251 REWIND 7 WRITE(7)TEFF,GLOG,TITLE,WBEGIN,DELTAW,NUMNU,IFSURF,NMU,ANGLE, 1NEDGE,WLEDGE 251 CONTINUE WRITE(7)(Q(I),I=1,NMU2) 25 CONTINUE C CALL ENDTIME C CALL BEGTIME C IF(NMU.GT.10)IFSURF=1 NMU=1 MU=1 READ(9)NLINES N910=NLINES+N10 WRITE(7)N910 WRITE(6,80)NLINES,N10,N910 80 FORMAT(3I10) IF(NLINES.EQ.0)GO TO 100 WAVOLD=0. IEDGE=1 DO 90 ILINE=1,NLINES READ(9)LINDAT8,LINDAT,ALINEC WAVE=WLVAC IF(WAVE.LT.WAVOLD)IEDGE=1 WAVOLD=WAVE 3003 IF(WAVE.LT.WLEDGE(IEDGE+1))GO TO 3005 IEDGE=IEDGE+1 GO TO 3003 3005 C1=(WAVE-HALFEDGE(IEDGE))*(WAVE-WLEDGE(IEDGE+1))/DELEDGE(IEDGE) C2=(WLEDGE(IEDGE)-WAVE)*(WAVE-WLEDGE(IEDGE+1))*2./DELEDGE(IEDGE) C3=(WAVE-WLEDGE(IEDGE))*(WAVE-HALFEDGE(IEDGE))/DELEDGE(IEDGE) DO 3006 J=1,NRHOX ACONT(J)=10.**(C1*CONTABS(1,IEDGE,J)+C2*CONTABS(2,IEDGE,J)+ 1 C3*CONTABS(3,IEDGE,J)) 3006 SIGMAC(J)=10.**(C1*CONTSCAT(1,IEDGE,J)+C2*CONTSCAT(2,IEDGE,J)+ 1 C3*CONTSCAT(3,IEDGE,J)) C FREQ=2.99792458E17/WAVE FREQ15=FREQ/1.E15 FREQLG= LOG(FREQ) DO 81 J=1,NRHOX EHVKT(J)=EXP(-FREQ*HKT(J)) STIM(J)=1.-EHVKT(J) SIGPRD(J)=0. BNU(J)=1.47439E-02*FREQ15**3*EHVKT(J)/STIM(J) ALINE(J)=0. SIGMAL(J)=0. SLINE(J)=BNU(J) 81 SCONT(J)=BNU(J) CALL JOSH(1,IFSURF) IF(IFSURF.EQ.1)CONCEN=HNU(1) IF(IFSURF.EQ.2)CONCEN=SURFI(MU) DO 82 J=1,NRHOX ALINE(J)=AHLINE(J)+ALINEC(J)*(1.-FSCAT(J))+AXLINE(J) SLINE(J)=BNU(J) C ASSUMES BUP=1 SLINEC=BNU(J)*STIM(J)/(BFUDGE(J)-EHVKT(J)) IF(ALINE(J).GT.0.)SLINE(J)=(AHLINE(J)*SHLINE(J)+ALINEC(J)*SLINEC* 1(1.-FSCAT(J))+AXLINE(J)*SXLINE(J))/ALINE(J) 82 SIGMAL(J)=ALINEC(J)*FSCAT(J) CALL JOSH(1,IFSURF) IF(IFSURF.EQ.1)CENTER=HNU(1) IF(IFSURF.EQ.2)CENTER=SURFI(MU) RESID=CENTER/CONCEN C WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, C BCENTER,CONCEN, C 1WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, C 2DWL,DGFLOG,GAMMAR,GAMMAS,GAMMAW 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X,A8,A2,A8,A2, 1F12.4,F9.3,1P2E11.3/ 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3A8,A2,A8,A2,F7.4,F7.3,3F6.2) IF(WL.GT.0.)WRITE(17,98)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP, 1WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 2DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW IF(WL.LT.0.)WRITE(17,98)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP, 1WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 2DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,WL 98 FORMAT(F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,A8,A2,A8,A2/ 1 0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3, 2A8,A2,A8,A2,F7.4,F7.3,3F6.2,F10.4) WRITE(7)LINDAT8,LINDAT 90 CONTINUE 100 CONTINUE CLOSE(UNIT=9,DISPOSE='DELETE') IF(N10.EQ.0)GO TO 111 C N20=N10 REWIND 20 WAVOLD=0. IEDGE=1 DO 110 ILINE=1,N10 READ(20)LINDAT8,LINDAT WAVE=WLVAC IF(WAVE.LT.WAVOLD)IEDGE=1 WAVOLD=WAVE 4003 IF(WAVE.LT.WLEDGE(IEDGE+1))GO TO 4005 IEDGE=IEDGE+1 GO TO 4003 4005 C1=(WAVE-HALFEDGE(IEDGE))*(WAVE-WLEDGE(IEDGE+1))/DELEDGE(IEDGE) C2=(WLEDGE(IEDGE)-WAVE)*(WAVE-WLEDGE(IEDGE+1))*2./DELEDGE(IEDGE) C3=(WAVE-WLEDGE(IEDGE))*(WAVE-HALFEDGE(IEDGE))/DELEDGE(IEDGE) DO 4006 J=1,NRHOX ACONT(J)=10.**(C1*CONTABS(1,IEDGE,J)+C2*CONTABS(2,IEDGE,J)+ 1 C3*CONTABS(3,IEDGE,J)) 4006 SIGMAC(J)=10.**(C1*CONTSCAT(1,IEDGE,J)+C2*CONTSCAT(2,IEDGE,J)+ 1 C3*CONTSCAT(3,IEDGE,J)) C FREQ=2.99792458E17/WAVE FREQ15=FREQ/1.E15 FREQLG= LOG(FREQ) DO 101 J=1,NRHOX EHVKT(J)=EXP(-FREQ*HKT(J)) STIM(J)=1.-EHVKT(J) ALINE(J)=0. SIGMAL(J)=0. BNU(J)=1.47439E-02*FREQ15**3*EHVKT(J)/STIM(J) SLINE(J)=BNU(J) 101 SCONT(J)=BNU(J) CALL JOSH(1,IFSURF) IF(IFSURF.EQ.1)CONCEN=HNU(1) IF(IFSURF.EQ.2)CONCEN=SURFI(MU) CALL LINCEN IF(IFCORO.EQ.1)GO TO 102 CALL JOSH(1,IFSURF) IF(IFSURF.EQ.1)CENTER=HNU(1) IF(IFSURF.EQ.2)CENTER=SURFI(MU) GO TO 103 102 SURFI(MU)=SURF(MU) CALL CORINT CENTER=SURFI(MU) 103 CONCEN=SURF(MU) RESID=CENTER/CONCEN WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, BCENTER,CONCEN, 1WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2 2DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW WRITE(7)LINDAT8,LINDAT 110 CONTINUE CLOSE(UNIT=20,DISPOSE='DELETE') C 111 CALL ENDTIME 111 CALL EXIT END SUBROUTINE LINCEN RETURN END SUBROUTINE CORINT RETURN END SUBROUTINE ATLAS7 END SUBROUTINE PRDJNU RETURN END