Initial commit

1 files changed, 438 insertions, 0 deletions

diff --git a/synthe/spectrv.for b/synthe/spectrv.for
new file mode 100644
index 0000000..d59837e
--- /dev/null
+++ b/synthe/spectrv.for
@@ -0,0 +1,438 @@
+      PROGRAM SPECTRV
+c     revised 4nov14   constants given D exponents
+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
+      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)
+C      IF(IFSURF.EQ.0)THEN
+C      WRITE(6,*)' SURFACE FLUX OR SURFACE INTENSITY?'
+C      CALL ABORT
+C      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.99792458D17/WAVE
+      FREQ15=FREQ/1.D15
+      FREQLG= LOG(FREQ)
+      DO 20 J=1,NRHOX
+      EHVKT(J)=EXP(-FREQ*HKT(J))
+      STIM(J)=1.-EHVKT(J)
+      BNU(J)=1.47439D-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
+      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.99792458D17/WAVE
+      FREQ15=FREQ/1.D15
+      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.47439D-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.99792458D17/WAVE
+      FREQ15=FREQ/1.D15
+      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.47439D-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
+c     29oct07 replaced missing comma after OTHER2  
+      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')
+  111 CALL EXIT
+      END
+      SUBROUTINE LINCEN
+      RETURN
+      END
+      SUBROUTINE CORINT
+      RETURN
+      END
+      SUBROUTINE ATLAS7
+      END
+      SUBROUTINE PRDJNU
+      RETURN
+      END