PROGRAM SYNTHE c revised 3dec93 C THIS PROGRAM IS REAL*4 EXCEPT FOR WAVELENGTHS AND ENERGY LEVELS C REAL*8 INPUT ON TAPE10 IS CONVERTED TO REAL*4 C C TAPE5 INPUT C TAPE6 OUTPUT C TAPE7 temporary file for line identifications C TAPE8 file that passes the number of lines to SPECTRV C TAPE9 output opacity vectors and line data C TAPE10 input from XNFPELSYN C TAPE12 input line data needed for calculation C TAPE13 input line data, all data for each line C TAPE14 temporary file of opacity spectra C TAPE15 temporary file of opacity vectors for each line C TAPE19 input line data from RNLTE C TAPE93 parameters for this run from SYNBEG PARAMETER (kw=99) PARAMETER (LENREC=8000,MAXLEN=2000001,MAXPROF=10000, 1 MAXBUFF=MAXLEN+MAXPROF,MAXLIN=MAXBUFF+MAXPROF*2) C LENREC transposition is done in blocks of LENRECxkw C MAXLEN number of points in the spectrum C MAXPROF number of points in either wing of a line with a Voigt profile COMMON /BUFFER/BUFFER(MAXBUFF),PROFILE(MAXPROF) DIMENSION LINE(MAXLIN) DIMENSION TRANSP(kw,LENREC),RECORD(LENREC),INDEXR(5000) EQUIVALENCE (BUFFER(1),LINE(1),TRANSP(1)) C DIMENSION TRANSP(55000,kw) 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 /EXTAB/EXTAB(1001),EXTABF(1001),E1TAB(2000) COMMON /H1TAB/H0TAB(2001),H1TAB(2001),H2TAB(2001) 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 COMMON /NLINES/WLBEG,WLEND,RESOLU,RATIO,RATIOLG,WBEGIN, 1 LENGTH,MLINES,IXWLBEG COMMON /RHOX/RHOX(kw),NRHOX COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw),PTOTAL(kw) COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP,HCKT(kw) COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND, 1 IFTURB COMMON /TXNXN/TXNXN(kw),BSTIM(kw),EMERGE(kw) COMMON /XNFDOP/XNFPEL(594),DOPPLE(594),XNFDOP(594) DIMENSION ABLOG(kw,300),IFTP(kw),ABMIN(kw),MLINEJ(kw),XNFH2(kw) DIMENSION ASYNTH(kw),ALINEC(kw) DIMENSION DECKJ(7,kw) DIMENSION VELSHIFT(kw),HFIELD(kw) DIMENSION TITLE(74),IDMOL(60),MOMASS(60) DIMENSION FRQEDG(300),WLEDGE(300),CMEDGE(300),CONFRQ(300) DIMENSION KAPMINN(4011) EQUIVALENCE (RECORD(1),KAPMINN(1)) REAL KAPMINN,KAPPA0,KAPPA,KAPCEN,KAPMIN REAL*8 QT(kw),QTKEV(kw),QTK(kw),QHKT(kw),QTLOG(kw),QHCKT(kw) REAL*8 QP(kw),QXNE(kw),QXNATOM(kw),QRHO(kw),QRHOX(kw),QVTURB(kw) REAL*8 QXNFH(kw),QXNFHE(kw,2),QXNFH2(kw),QDOPPLE(594),QXNFPEL(594) REAL*8 QABLOG(kw) C REAL*8 ASYNTH,ALINEC,TITLE,TEFF,GLOG,IDMOL,MOMASS REAL*8 TITLE,TEFF,GLOG,IDMOL,MOMASS REAL*8 FRQEDG,WLEDGE,CMEDGE,CONFRQ,CONWAV,CONCM REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RESOLU,RATIO,RATIOLG,SIGMA2,WLBEG,WLEND,WBEGIN REAL*8 EMERGE REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 C FASTEX(X)=EXTAB(IFIX(X)+1)* 1EXTABF(IFIX((X-FLOAT(IFIX(X)))*1000.+1.5)) C CALL BEGTIME OPEN(UNIT=10,TYPE='OLD',FORM='UNFORMATTED',READONLY,SHARED) OPEN(UNIT=12,TYPE='OLD',FORM='UNFORMATTED',ACCESS='APPEND') OPEN(UNIT=13,TYPE='OLD',FORM='UNFORMATTED',ACCESS='APPEND') OPEN(UNIT=14,TYPE='NEW',FORM='UNFORMATTED',RECORDTYPE='FIXED', 1ACCESS='DIRECT',BLOCKSIZE=LENREC*4,RECORDSIZE=LENREC) READ(93)NLINES,LENGTH,IFVAC,IFNLTE,N19,TURBV,DECKJ,IFPRED, 1WLBEG,WLEND,RESOLU,RATIO,RATIOLG,CUTOFF,LINOUT IXWLBEG=DLOG(WLBEG)/RATIOLG WBEGIN=DEXP(IXWLBEG*RATIOLG) IF(WBEGIN.LT.WLBEG)THEN IXWLBEG=IXWLBEG+1 WBEGIN=DEXP(IXWLBEG*RATIOLG) ENDIF CLOSE(UNIT=93,DISP='DELETE') C DO 3456 I=1,1001 EXTAB(I)=EXP(-FLOAT(I-1)) 3456 EXTABF(I)=EXP(-FLOAT(I-1)*.001) DO 3457 I=1,2000 3457 E1TAB(I)=EXPI(1,FLOAT(I)*.01) C PRETABULATE VOIGT FUNCTION C 100 STEPS PER DOPPLER WIDTH VSTEPS=200. CALL TABVOIGT(VSTEPS,2001) C CALL TABVGT(VSTEPS,H0TAB,H1TAB,2001) C READ(10)NRHOX,TEFF,GLOG,TITLE WRITE(6,2000)TEFF,GLOG,TITLE 2000 FORMAT(6H TEFF=,F10.1,3X,5HGRAV=,F6.3,3X,74A1) READ(10)NEDGE,(FRQEDG(IEDGE),WLEDGE(IEDGE),CMEDGE(IEDGE), 1IEDGE=1,NEDGE),IDMOL,MOMASS READ(10)NCON,(CONFRQ(NU),NU=1,NCON) DO 2005 NU=1,NCON READ(10)QABLOG DO 2002 J=1,NRHOX 2002 ABLOG(J,NU)=QABLOG(J) CONWAV=2.997925E17/CONFRQ(NU) CONCM=1.E7/CONWAV C WRITE(6,2006)NU,CONFRQ(NU),CONWAV,CONCM 2006 FORMAT(I5,1PE25.15,0PF20.7,F20.7) C WRITE(6,105)(ABLOG(J,NU),J=1,NRHOX) 105 FORMAT(1X,15F5.2) DO 2007 J=1,NRHOX 2007 ABLOG(J,NU)=EXP(2.30258509299405E0*ABLOG(J,NU)) 2005 CONTINUE ITEMP=1 C READ(10)T,TKEV,TK,HKT,TLOG,HCKT,P,XNE,XNATOM,RHO,RHOX,VTURB, C 1XNFH,XNFHE,XNFH2 C ON VAX VARIABLES ARE READ REAL*8 AND CONVERTED TO REAL*4 READ(10)QT,QTKEV,QTK,QHKT,QTLOG,QHCKT,QP,QXNE,QXNATOM,QRHO, 1QRHOX,QVTURB,QXNFH,QXNFHE,QXNFH2 DO 2010 J=1,NRHOX T(J)=QT(J) TKEV(J)=QTKEV(J) TK(J)=QTK(J) HKT(J)=QHKT(J) TLOG(J)=QTLOG(J) HCKT(J)=QHCKT(J) P(J)=QP(J) XNE(J)=QXNE(J) XNATOM(J)=QXNATOM(J) RHO(J)=QRHO(J) RHOX(J)=QRHOX(J) VTURB(J)=QVTURB(J) XNFH(J)=QXNFH(J) XNFHE(J,1)=QXNFHE(J,1) XNFHE(J,2)=QXNFHE(J,2) C ASSUMING GROUND STATE PARTITION FUNCTIONS C XNFPH(J,1)=XNFH(J)/2. C XNFPHE(J,1)=XNFHE(J,1)/1. C XNFPHE(J,2)=XNFHE(J,2)/2. 2010 XNFH2(J)=QXNFH2(J) C DO 2011 J=1,kw VELSHIFT(J)=DECKJ(1,J) HFIELD(J)=DECKJ(2,J) 2011 CONTINUE C WRITE(9)WLBEG,RESOLU,WLEND,LENGTH,NRHOX,LINOUT,TURBV,IFVAC WRITE(9)NEDGE,(FRQEDG(IEDGE),WLEDGE(IEDGE),CMEDGE(IEDGE), 1IEDGE=1,NEDGE),IDMOL,MOMASS CALL ENDTIME C CALL BEGTIME ILINES=0 N12=NLINES NLINES=NLINES+N19 IREC=0 DO 500 J=1,NRHOX REWIND 12 C INITIALIZE BUFFER DO 210 NBUFF=1,LENGTH 210 BUFFER(NBUFF)=0. READ(10)QXNFPEL,QDOPPLE C IF(IFTP(J).EQ.0)GO TO 400 XNFPH(J,1)=QXNFPEL(1) XNFPHE(J,1)=QXNFPEL(7) XNFPHE(J,2)=QXNFPEL(8) DO 203 NELION=1,594 DOPPLE(NELION)=QDOPPLE(NELION) XNFPEL(NELION)=0. C PATCH FOR NLTE HELIUM WHERE CAN GET OVERFLOW ON VAX C NLTE HELIUM IS NOT COMPUTED BY SYNTHE IN ANY CASE IF(QXNFPEL(NELION).LT.1.D25)XNFPEL(NELION)=QXNFPEL(NELION) 203 CONTINUE DO 205 NELION=1,594 DOPPLE(NELION)=SQRT(DOPPLE(NELION)**2+(TURBV/299792.5)**2) C 205 XNFDOP(NELION)=XNFPEL(NELION)/RHO(J)/DOPPLE(NELION) C PROBLEMS WITH OVERFLOW 205 XNFPEL(NELION)=XNFPEL(NELION)/RHO(J) TXNXN(J)=(XNFH(J)+.42*XNFHE(J,1)+.85*XNFH2(J))*(T(J)/10000.)**.3 C C TABULATE MINIMUM OPACITY CUTOFF N1=1 LEN100=LENGTH/100+1 DO 211 NU=1,NCON N=NCON+1-NU CONWAV=2.997925E17/CONFRQ(N) IXWL=DLOG(CONWAV)/RATIOLG NBUFF=IXWL-IXWLBEG+1 IF(NBUFF.LE.0)GO TO 211 NKAP=NBUFF/100+1 IF(J.EQ.1)WRITE(6,206)N,CONWAV,NBUFF,N1,NKAP 206 FORMAT(I10,F12.5,3I10) DO 212 IKAP=N1,NKAP IF(IKAP.GT.LEN100)GO TO 213 KAPMINN(IKAP)=ABLOG(J,N)*CUTOFF 212 CONTINUE N1=NKAP+1 211 CONTINUE 213 CONTINUE C C DOPPLER SHIFT IN POINT NUMBERS NVSHIFT=RESOLU*VELSHIFT(J)/299792.5+.5 WRITE(6,215)J,VELSHIFT(J),NVSHIFT 215 FORMAT(I5,14HVELOCITY SHIFT,F9.3,I7) C ADD LINES TO BUFFER MLINES=0 IF(N19.GT.0)CALL XLINOP(J,N19,KAPMINN,LEN100,VELSHIFT(J)) IF(N12.EQ.0)GO TO 400 N191=N19+1 DO 350 ILINE=N191,NLINES READ(12)NBUFF,CONGF,NELION,ELO,GAMRF,GAMSF,GAMWF C KAPPA0=CONGF*XNFDOP(NELION) C PROBLEMS WITH OVERFLOW ON VAX KAPPA0=CONGF/DOPPLE(NELION)*XNFPEL(NELION) KAPMIN=KAPMINN(MIN0(MAX0(NBUFF/100,1),LEN100)) IF(KAPPA0.LT.KAPMIN)GO TO 350 KAPPA0=KAPPA0*FASTEX(ELO*HCKT(J)) C KAPPA0=KAPPA0*EXP(-ELO*HCKT(J)) IF(KAPPA0.LT.KAPMIN)GO TO 350 C C C GAMWF=GAMWF*2. C C VOIGT APPROXIMATION ACCURATE ONLY TO ADAMP**2 ADAMP=(GAMRF+GAMSF*XNE(J)+GAMWF*TXNXN(J))/DOPPLE(NELION) C ADAMP=AMIN1((GAMRF+GAMSF*XNE(J)+GAMWF*TXNXN(J))/DOPPLE(NELION), C 1 .25) NBUFF=NBUFF+NVSHIFT IF(NBUFF.LT.1.OR.NBUFF.GT.LENGTH)GO TO 320 MLINES=MLINES+1 IF(ADAMP.LT..2)THEN KAPCEN=KAPPA0*(1.-1.128*ADAMP) ELSE KAPCEN=KAPPA0*VOIGT(0.,ADAMP) ENDIF WRITE(15)ILINE,KAPCEN BUFFER(NBUFF)=BUFFER(NBUFF)+KAPCEN C PROFILE INSIDE 10 DOPPLER WIDTHS 320 N10DOP=10.*(DOPPLE(NELION)*RESOLU) IF(ADAMP.LT..2)THEN TABSTEP=VSTEPS/(DOPPLE(NELION)*RESOLU) TABI=1.5 DO 321 NSTEP=1,N10DOP TABI=TABI+TABSTEP PROFILE(NSTEP)=KAPPA0*(H0TAB(IFIX(TABI))+ADAMP*H1TAB(IFIX(TABI))) IF(PROFILE(NSTEP).LT.KAPMIN)GO TO 323 321 CONTINUE ELSE DVOIGT=1./DOPPLE(NELION)/RESOLU DO 1321 NSTEP=1,N10DOP PROFILE(NSTEP)=KAPPA0*VOIGT(FLOAT(NSTEP)*DVOIGT,ADAMP) IF(PROFILE(NSTEP).LT.KAPMIN)GO TO 323 1321 CONTINUE ENDIF C FAR WINGS X=PROFILE(N10DOP)*FLOAT(N10DOP)**2 MAXSTEP=SQRT(X/KAPMIN)+1. MAXSTEP=MIN(MAXSTEP,MAXPROF) N1=N10DOP+1 DO 322 NSTEP=N1,MAXSTEP 322 PROFILE(NSTEP)=X/FLOAT(NSTEP)**2 NSTEP=MAXSTEP 323 IF(NBUFF+NSTEP.LT.1.OR.NBUFF-NSTEP.GT.LENGTH)GO TO 350 IF(NBUFF.GE.LENGTH)GO TO 325 C RED WING MAXRED=MIN0(LENGTH-NBUFF,NSTEP) MINRED=MAX0(1,1-NBUFF) DO 324 ISTEP=MINRED,MAXRED 324 BUFFER(NBUFF+ISTEP)=BUFFER(NBUFF+ISTEP)+PROFILE(ISTEP) IF(NBUFF.LE.1)GO TO 350 C BLUE WING 325 MAXBLUE=MIN0(NBUFF-1,NSTEP) MINBLUE=MAX0(1,NBUFF-LENGTH) DO 326 ISTEP=MINBLUE,MAXBLUE 326 BUFFER(NBUFF-ISTEP)=BUFFER(NBUFF-ISTEP)+PROFILE(ISTEP) 350 CONTINUE C 400 CONTINUE C MEMORY TRANSPOSITION C DO 26 I=1,LENGTH C 26 TRANSP(I,J)=BUFFER(I) C DIRECT IO TRANSPOSITION NUMREC=(LENGTH+LENREC-1)/LENREC DO 26 NBEG=1,LENGTH,LENREC IREC=IREC+1 NEND=NBEG+LENREC-1 WRITE(14,REC=IREC)(BUFFER(I),I=NBEG,NEND) 26 CONTINUE WRITE(6,499)J,MLINES 499 FORMAT(2I10,11H LINES USED) MLINEJ(J)=MLINES ILINES=ILINES+MLINES 500 CONTINUE WRITE(6,106)ILINES 106 FORMAT(I10) CALL ENDTIME CALL BEGTIME C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CC MEMORY TRANSPOSITION C FREQ=2.997925E17/WLBEG*RATIO C DO 95 I=1,LENGTH C FREQ=FREQ/RATIO C DO 94 J=1,NRHOX C 94 ASYNTH(J)=TRANSP(I,J)*(1.-EXP(-FREQ*HKT(J))) C 95 WRITE(9)ASYNTH C 99 CONTINUE C WRITE(6,96)LENGTH C 96 FORMAT(I10,27H OPACITY VECTORS ON TAPE 9 ) C CALL ENDTIME C CALL BEGTIME C N9=0 C IF(NLINES.EQ.0)GO TO 810 C DO 800 I=1,NLINES C 800 LINE(I)=0 C IF(ILINES.EQ.0)GO TO 810 C REWIND 15 C I=0 C 803 I=I+1 C READ(15)ILINE C LINE(ILINE)=1 C IF(I.LT.ILINES)GO TO 803 C REWIND 13 C REWIND 7 C DO 809 I=1,NLINES C READ(13)LINDAT8,LINDAT C IF(LINE(I).EQ.0)GO TO 809 C LINE(I)=0 C WRITE(7)LINDAT8,LINDAT C N9=N9+1 C LINE(I)=N9 C 809 CONTINUE C 810 WRITE(6,106)N9 C WRITE(8)N9 C CLOSE(UNIT=12,DISP='DELETE') C CLOSE(UNIT=13,DISP='DELETE') CC C IF(ILINES.EQ.0)CALL EXIT C REWIND 15 C DO 830 J=1,NRHOX C MAXLINE=MLINEJ(J) C WRITE(6,817)J,MAXLINE C 817 FORMAT(3I10) C K=0 C JOUT=0 C IF(MAXLINE.EQ.0)GO TO 820 C I9LAST=0 C DO 815 I=1,MAXLINE C READ(15)ILINE,KAPCEN C I9=LINE(ILINE) C IF(I9.EQ.0)GO TO 815 C NSKIP=I9-I9LAST-1 C IF(NSKIP.EQ.0)GO TO 811 C DO 812 ISKIP=1,NSKIP C K=K+1 C TRANSP(K,J)=0. C 812 JOUT=JOUT+1 C 811 I9LAST=I9 C K=K+1 C JOUT=JOUT+1 C TRANSP(K,J)=KAPCEN C 815 NSKIP=N9-I9LAST C IF(NSKIP.EQ.0)GO TO 830 C GO TO 821 C 820 NSKIP=N9 C 821 DO 822 ISKIP=1,NSKIP C K=K+1 C JOUT=JOUT+1 C 822 TRANSP(K,J)=0. C 830 WRITE(6,817)J,MAXLINE,JOUT CC IF(N9.GT.55000)STOP 'TOO MANY LINES TO TRANSPOSE' C REWIND 7 C DO 895 I=1,JOUT C READ(7)LINDAT8,LINDAT C FREQ=2.997925E17/WLVAC C DO 897 J=1,NRHOX C 897 ALINEC(J)=TRANSP(I,J)*(1.-EXP(-FREQ*HKT(J))) C 895 WRITE(9)LINDAT8,LINDAT,ALINEC C 899 CONTINUE C WRITE(6,96)JOUT C CLOSE(UNIT=7,DISP='DELETE') C CLOSE(UNIT=15,DISP='DELETE') C CALL ENDTIME C CALL EXIT CC END CC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DIRECT IO TRANSPOSITION C C TRANSPOSE N9=0 FREQ=2.99792458E17/WBEGIN*RATIO DO 99 N=1,NUMREC WRITE(6,106)N DO 93 J=1,NRHOX IREC=J*NUMREC-NUMREC+N READ(14,REC=IREC)(TRANSP(J,I),I=1,LENREC) 93 CONTINUE NOUT=LENREC LASTREC=LENGTH-NUMREC*LENREC+LENREC IF(N.EQ.NUMREC)NOUT=LASTREC DO 95 I=1,NOUT FREQ=FREQ/RATIO N9=N9+1 DO 94 J=1,NRHOX 94 ASYNTH(J)=TRANSP(J,I)*(1.-EXP(-FREQ*HKT(J))) 95 WRITE(9)ASYNTH 99 CONTINUE C N9=LENGTH IS A CHECK THAT THE TRANSPOSITION WORKED PROPERLY WRITE(6,96)N9 96 FORMAT(I10,27H OPACITY VECTORS ON TAPE 9 ) CALL ENDTIME CALL BEGTIME C C SAVE ALL LINES USED N9=0 IF(NLINES.EQ.0)GO TO 810 IF(LINOUT.LT.0)GO TO 810 DO 800 I=1,NLINES 800 LINE(I)=0 IF(ILINES.EQ.0)GO TO 810 REWIND 15 I=0 803 I=I+1 READ(15)ILINE LINE(ILINE)=1 IF(I.LT.ILINES)GO TO 803 REWIND 13 REWIND 7 DO 809 I=1,NLINES READ(13)LINDAT8,LINDAT IF(LINE(I).EQ.0)GO TO 809 LINE(I)=0 WRITE(7)LINDAT8,LINDAT N9=N9+1 LINE(I)=N9 809 CONTINUE 810 WRITE(6,106)N9 WRITE(8)N9 WRITE(9)N9 CLOSE(UNIT=12,DISP='DELETE') CLOSE(UNIT=13,DISP='DELETE') C C SET UP LINE CENTER OPACITY FOR EACH LINE IF(ILINES.EQ.0)CALL EXIT IF(LINOUT.LT.0)CALL EXIT REWIND 15 IREC=0 DO 830 J=1,NRHOX MAXLINE=MLINEJ(J) C WRITE(6,817)J,MAXLINE 817 FORMAT(3I10) K=0 JOUT=0 IF(MAXLINE.EQ.0)GO TO 820 I9LAST=0 DO 815 L=1,MAXLINE READ(15)ILINE,KAPCEN I9=LINE(ILINE) IF(I9.EQ.0)GO TO 815 NSKIP=I9-I9LAST-1 IF(NSKIP.EQ.0)GO TO 811 DO 812 ISKIP=1,NSKIP K=K+1 RECORD(K)=0. JOUT=JOUT+1 IF(K.LT.LENREC)GO TO 812 IREC=IREC+1 WRITE(14,REC=IREC)RECORD K=0 812 CONTINUE 811 I9LAST=I9 K=K+1 JOUT=JOUT+1 RECORD(K)=KAPCEN IF(K.LT.LENREC)GO TO 815 IREC=IREC+1 WRITE(14,REC=IREC)RECORD K=0 815 CONTINUE NSKIP=N9-I9LAST IF(NSKIP.EQ.0)GO TO 825 GO TO 821 820 NSKIP=N9 821 DO 822 ISKIP=1,NSKIP K=K+1 JOUT=JOUT+1 RECORD(K)=0. IF(K.LT.LENREC)GO TO 822 IREC=IREC+1 WRITE(14,REC=IREC)RECORD K=0 822 CONTINUE 825 IF(K.EQ.0)GO TO 830 IREC=IREC+1 WRITE(14,REC=IREC)RECORD K=0 830 WRITE(6,817)J,MAXLINE,JOUT C C TRANSPOSE IF(N9.LE.MAXLIN)GO TO 808 WRITE(6,877) 877 FORMAT(28H TOO MANY LINES TO TRANSPOSE) CALL ABORT 808 CONTINUE REWIND 7 NUMREC=(N9+LENREC-1)/LENREC NLAST=N9-NUMREC*LENREC+LENREC NCEN=0 DO 899 N=1,NUMREC WRITE(6,106)N DO 893 J=1,NRHOX IREC=J*NUMREC-NUMREC+N READ(14,REC=IREC)(TRANSP(J,I),I=1,LENREC) 893 CONTINUE NOUT=LENREC IF(N.EQ.NUMREC)NOUT=NLAST DO 895 I=1,NOUT NCEN=NCEN+1 READ(7)LINDAT8,LINDAT FREQ=2.99792458E17/WLVAC DO 897 J=1,NRHOX 897 ALINEC(J)=TRANSP(J,I)*(1.-EXP(-FREQ*HKT(J))) 895 WRITE(9)LINDAT8,LINDAT,ALINEC 899 CONTINUE CLOSE(UNIT=7,DISP='DELETE') CLOSE(UNIT=15,DISP='DELETE') CLOSE(UNIT=14,DISPOSE='DELETE') WRITE(6,96)NCEN CALL ENDTIME CALL EXIT END FUNCTION MAP1(XOLD,FOLD,NOLD,XNEW,FNEW,NNEW) DIMENSION XOLD(1),FOLD(1),XNEW(1),FNEW(1) L=2 LL=0 DO 50 K=1,NNEW 10 IF(XNEW(K).LT.XOLD(L))GO TO 20 L=L+1 IF(L.GT.NOLD)GO TO 30 GO TO 10 20 IF(L.EQ.LL)GO TO 50 IF(L.EQ.2)GO TO 30 L1=L-1 IF(L.GT.LL+1.OR.L.EQ.3)GO TO 21 CBAC=CFOR BBAC=BFOR ABAC=AFOR IF(L.EQ.NOLD)GO TO 22 GO TO 25 21 L2=L-2 D=(FOLD(L1)-FOLD(L2))/(XOLD(L1)-XOLD(L2)) CBAC=FOLD(L)/((XOLD(L)-XOLD(L1))*(XOLD(L)-XOLD(L2)))+ 1(FOLD(L2)/(XOLD(L)-XOLD(L2))-FOLD(L1)/(XOLD(L)-XOLD(L1)))/ 2(XOLD(L1)-XOLD(L2)) BBAC=D-(XOLD(L1)+XOLD(L2))*CBAC ABAC=FOLD(L2)-XOLD(L2)*D+XOLD(L1)*XOLD(L2)*CBAC IF(L.LT.NOLD)GO TO 25 22 C=CBAC B=BBAC A=ABAC LL=L GO TO 50 25 D=(FOLD(L)-FOLD(L1))/(XOLD(L)-XOLD(L1)) CFOR=FOLD(L+1)/((XOLD(L+1)-XOLD(L))*(XOLD(L+1)-XOLD(L1)))+ 1(FOLD(L1)/(XOLD(L+1)-XOLD(L1))-FOLD(L)/(XOLD(L+1)-XOLD(L)))/ 2(XOLD(L)-XOLD(L1)) BFOR=D-(XOLD(L)+XOLD(L1))*CFOR AFOR=FOLD(L1)-XOLD(L1)*D+XOLD(L)*XOLD(L1)*CFOR WT=0. IF(ABS(CFOR).NE.0.)WT=ABS(CFOR)/(ABS(CFOR)+ABS(CBAC)) A=AFOR+WT*(ABAC-AFOR) B=BFOR+WT*(BBAC-BFOR) C=CFOR+WT*(CBAC-CFOR) LL=L GO TO 50 30 IF(L.EQ.LL)GO TO 50 L=AMIN0(NOLD,L) C=0. B=(FOLD(L)-FOLD(L-1))/(XOLD(L)-XOLD(L-1)) A=FOLD(L)-XOLD(L)*B LL=L 50 FNEW(K)=A+(B+C*XNEW(K))*XNEW(K) MAP1=LL-1 RETURN END SUBROUTINE XLINOP(J,N19,KAPMINN,LEN100,VELSHIFT) PARAMETER (kw=99) PARAMETER (LENREC=16000,MAXLEN=2000001,MAXPROF=10000, 1 MAXBUFF=MAXLEN+MAXPROF,MAXLIN=MAXBUFF+MAXPROF*2) COMMON /BUFFER/BUFFER(MAXBUFF),PROFILE(MAXPROF) 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 /EXTAB/EXTAB(1001),EXTABF(1001),E1TAB(2000) COMMON /NLINES/WLBEG,WLEND,RESOLU,RATIO,RATIOLG,WBEGIN, 1 LENGTH,MLINES,IXWLBEG COMMON /RHOX/RHOX(kw),NRHOX COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw),PTOTAL(kw) COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP,HCKT(kw) COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND, 1 IFTURB COMMON /TXNXN/TXNXN(kw),BSTIM(kw),EMERGE(kw) COMMON /XNFDOP/XNFPEL(594),DOPPLE(594),XNFDOP(594) REAL NSTARK,NDOPP,NMERGE EQUIVALENCE (GAMMAS,ASHORE),(GAMMAW,BSHORE) EQUIVALENCE (GF,G,CGF),(TYPE,NLAST),(GAMMAR,XSECT,GAUNT) INTEGER TYPE DIMENSION KAPMINN(4011) REAL KAPPA,KAPMIN,KAPPA0,KAPMINN,KAPCEN REAL*8 WAVE,WCON,EMERGE,WMERGE,WSHIFT,CONTX REAL*8 RESOLU,RATIO,RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,DOPRATIO,VELSHIFT,WBEGIN,EMERGEH(kw) DIMENSION CONTX(10,16) DIMENSION DOPPH(kw) DATA CONTX/ 1 109678.764,27419.659,12186.462,6854.871,4387.113, 1.00 2 3046.604,2238.320,1713.711,1354.044,0., 3 198310.760,38454.691,32033.214,29223.753,27175.760, 2.00 4 15073.868,0.,0.,0.,0., 5 438908.850,109726.529,48766.491,27430.925,17555.715, 2.01 6 12191.437,0.,0.,0.,0., 7 90883.840,90867.420,90840.420,90820.420,90804.000, 6.00 8 90777.000,80691.180,80627.760,69235.820,69172.400, 9 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 6.01 A 61671.020,39820.615,39800.556,39759.842,0.,0.,0.,0.,0.,0., 12.00 1 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 12.01 2 48278.370,48166.309,0.,0.,0.,0.,0.,0.,0.,0., 13.00 3 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 13.01 4 66035.000,65957.885,65811.843,65747.550,65670.435, 14.00 5 65524.393,59736.150,59448.700,50640.630,50553.180, 6 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 14.01 7 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 20.00,01 8 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 0.,0.,0.,0.,0.,0.,0.,0.,0.,0., 8.,11. 9 0.,0.,0.,0.,0.,0.,0.,0.,0.,0./ 5.00 DATA ITEMP1/0/ C FASTEX(X)=EXTAB(IFIX(X)+1)* 1EXTABF(IFIX((X-FLOAT(IFIX(X)))*1000.+1.5)) C IF(ITEMP.EQ.ITEMP1)GO TO 95 WRITE(6,90) 90 FORMAT(43H NSTARK NDOPP NMERGE EMERGE) DO 91 K=1,NRHOX C FOR NEUTRALS FOR IONS NSTARK=NSTARK*Z**.25 NDOPP=NDOPP*Z**(2./3.) C EMERGE=EMERGE*Z**2 INGLIS=1194./XNE(K)**.125 NMERGE=INGLIS+.5 EMERGE(K)=109737.312/NMERGE**2 EMERGEH(K)=109677.576/NMERGE**2 91 WRITE(6,92)K,NMERGE,EMERGE(K),EMERGEH(K) 92 FORMAT(I3,4F10.3) ITEMP1=ITEMP C 95 BOLT=1. BOLTH=1. OLDELO=1.E30*FLOAT(J*ITEMP) OLDELOH=1.E30*FLOAT(J*ITEMP) DOPRATIO=1.D0+VELSHIFT/299792.458D0 REWIND 19 DO 900 ILINE=1,N19 READ(19)WL,ELO,GF,NBLO,NBUP,NELION,TYPE,NCON,NELIONX, 1GAMMAR,GAMMAS,GAMMAW,NBUFF WL=WL*DOPRATIO 97 IF(TYPE.EQ.2)GO TO 500 IF(TYPE.EQ.0)GO TO 200 IF(TYPE.EQ.-1)GO TO 600 IF(TYPE.EQ.1)GO TO 700 IF(TYPE.EQ.3)GO TO 300 C C MERGED CONTINUUM WSHIFT=1.E7/(1.E7/WL-109737.312/FLOAT(NLAST**2)) WMERGE=1.E7/(1.E7/WL-EMERGE(J)) IF(NELION.EQ.1)THEN WSHIFT=1.E7/(1.E7/WL-109677.576/FLOAT(NLAST**2)) WMERGE=1.E7/(1.E7/WL-EMERGEH(J)) ENDIF WMERGE= MAX (WMERGE,WSHIFT) IXWL= LOG(WL)/RATIOLG EDGEBLUE=EXP(IXWL*RATIOLG) IF(EDGEBLUE.GT.WL)IXWL=IXWL-1 NBUFF1=IXWL+1-IXWLBEG+1 IXWL= LOG(WMERGE)/RATIOLG+.5 NBUFF2=IXWL-IXWLBEG+1 IF(NBUFF1.GT.LENGTH)GO TO 900 IF(NBUFF2.LT.1)GO TO 900 NBUFF1=MAX0(NBUFF1,1) NBUFF2=MIN0(NBUFF2,LENGTH) XSECTG=GF C KAPPA=XSECTG*XNFPEL(NELION)*EXP(-ELO*HCKT(J)) KAPPA=XSECTG*XNFPEL(NELION)*FASTEX(ELO*HCKT(J)) DO 190 IBUFF=NBUFF1,NBUFF2 190 BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA GO TO 900 C C NORMAL LINE 200 KAPPA0=CGF*XNFPEL(NELION)/DOPPLE(NELION) KAPMIN=KAPMINN(MIN0(MAX0(NBUFF/100,1),LEN100)) IF(KAPPA0.LT.KAPMIN)GO TO 900 IF(ELO.EQ.OLDELO)GO TO 210 C BOLT=EXP(-ELO*HCKT(J)) BOLT=FASTEX(ELO*HCKT(J)) OLDELO=ELO 210 KAPPA0=KAPPA0*BOLT IF(KAPPA0.LT.KAPMIN)GO TO 900 MLINES=MLINES+1 WCON=0. IF(NCON.GT.0)WCON=1.E7/(CONTX(NCON,NELIONX)-EMERGE(J))*DOPRATIO ADAMP=(GAMMAR+GAMMAS*XNE(J)+GAMMAW*TXNXN(J))/DOPPLE(NELION) KAPCEN=KAPPA0*VOIGT(0.,ADAMP) WRITE(15)ILINE,KAPCEN DOPWL=DOPPLE(NELION)*WL IF(WL.GT.WLEND)GO TO 213 C RED WING MINRED=MAX0(1,NBUFF) WAVE=WBEGIN*RATIO**(MINRED-1) DO 211 IBUFF=MINRED,LENGTH IF(WAVE.LT.WCON)GO TO 211 VVOIGT=ABS(WAVE-WL)/DOPWL KAPPA=KAPPA0*VOIGT(VVOIGT,ADAMP) BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 212 211 WAVE=WAVE*RATIO 212 IF(NBUFF.EQ.1)GO TO 900 IF(WL.LT.WLBEG)GO TO 900 C BLUE WING 213 IBUFF=MIN0(LENGTH+1,NBUFF) MAXBLUE=IBUFF-1 WAVE=WBEGIN*RATIO**(IBUFF-1) DO 214 I=1,MAXBLUE IBUFF=IBUFF-1 WAVE=WAVE/RATIO IF(WAVE.LT.WCON)GO TO 214 VVOIGT=ABS(WAVE-WL)/DOPWL KAPPA=KAPPA0*VOIGT(VVOIGT,ADAMP) C KAPPA=KAPPA0*VOIGT(ABS(WAVE-WL)/DOPWL,ADAMP) BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 900 214 CONTINUE GO TO 900 C C PRD LINE 300 GO TO 200 C C CORONAL LINE 500 GO TO 900 C C HYDROGEN LINE 600 KAPPA0=CGF*XNFPEL(1)/DOPPLE(1) KAPMIN=KAPMINN(MIN0(MAX0(NBUFF/100,1),LEN100)) IF(KAPPA0.LT.KAPMIN)GO TO 900 IF(ELO.EQ.OLDELOH)GO TO 610 C BOLTH=EXP(-ELO*HCKT(J)) BOLTH=FASTEX(ELO*HCKT(J)) OLDELOH=ELO DOPPH(J)=DOPPLE(1) C XNFPH(J,1)=XNFH(J)/2. C XNFPHE(J,1)=XNFHE(J,1) 610 KAPPA0=KAPPA0*BOLTH IF(KAPPA0.LT.KAPMIN)GO TO 900 WRITE(15)ILINE,KAPPA0 MLINES=MLINES+1 WCON=1.E7/(CONTX(NCON,1)-EMERGEH(J))*DOPRATIO IF(WL.GT.WLEND)GO TO 613 C RED WING C TO BETWEEN THE THIRD AND FOURTH PREVIOUS LINES REDCUT=1.D7/(1.D7/WL+109677.576*(1./FLOAT(NBUP**2)- 1 1./MAX(FLOAT(NBLO)+.5,FLOAT(NBUP)-3.5)**2)) MINRED=MAX0(1,NBUFF) WAVE=WBEGIN*RATIO**(MINRED-1) DO 611 IBUFF=MINRED,LENGTH IF(WAVE.LT.WCON)GO TO 611 IF(WAVE.GT.REDCUT)GO TO 612 KAPPA=KAPPA0*HPROF4(NBLO,NBUP,J,WAVE-WL,DOPPH) BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 612 611 WAVE=WAVE*RATIO 612 IF(NBUFF.EQ.1)GO TO 900 IF(WL.LT.WLBEG)GO TO 900 C BLUE WING C TO BETWEEN THIRD AND FOURTH NEXT LINES 613 BLUECUT=1.D7/(1.D7/WL+109677.576*(1./NBUP**2-1./(NBUP+3.5)**2)) IBUFF=MIN0(LENGTH+1,NBUFF) MAXBLUE=IBUFF-1 WAVE=WBEGIN*RATIO**(IBUFF-1) DO 614 I=1,MAXBLUE IBUFF=IBUFF-1 WAVE=WAVE/RATIO IF(WAVE.LT.WCON)GO TO 900 IF(WAVE.LT.BLUECUT)GO TO 900 KAPPA=KAPPA0*HPROF4(NBLO,NBUP,J,WAVE-WL,DOPPH) BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 900 614 CONTINUE GO TO 900 C C AUTOIONIZING LINE 700 KAPPA0=BSHORE*G*XNFPEL(NELION) KAPMIN=KAPMINN(MIN0(MAX0(NBUFF/100,1),LEN100)) IF(KAPPA0.LT.KAPMIN)GO TO 900 KAPPA0=KAPPA0*FASTEX(ELO*HCKT(J)) C KAPPA0=KAPPA0*EXP(-ELO*HCKT(J)) IF(KAPPA0.LT.KAPMIN)GO TO 900 WRITE(15)ILINE,KAPPA0 MLINES=MLINES+1 FRELIN=2.997925E17/WL IF(WL.GT.WLEND)GO TO 713 C RED WING MINRED=MAX0(1,NBUFF) FREQ=2.997925E17/(WBEGIN*RATIO**(MINRED-1)) DO 711 IBUFF=MINRED,LENGTH EPSIL=2.*(FREQ-FRELIN)/GAMMAR KAPPA=KAPPA0*(ASHORE*EPSIL+BSHORE)/(EPSIL**2+1.)/BSHORE BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 712 711 FREQ=FREQ/RATIO 712 IF(NBUFF.EQ.1)GO TO 900 IF(WL.LT.WLBEG)GO TO 900 C BLUE WING 713 IBUFF=MIN0(LENGTH+1,NBUFF) MAXBLUE=IBUFF-1 FREQ=2.997925E17/(WBEGIN*RATIO**(IBUFF-1)) DO 714 I=1,MAXBLUE IBUFF=IBUFF-1 FREQ=FREQ*RATIO EPSIL=2.*(FREQ-FRELIN)/GAMMAR KAPPA=KAPPA0*(ASHORE*EPSIL+BSHORE)/(EPSIL**2+1.)/BSHORE BUFFER(IBUFF)=BUFFER(IBUFF)+KAPPA IF(KAPPA.LT.KAPMIN)GO TO 900 714 CONTINUE GO TO 900 C 900 CONTINUE RETURN END FUNCTION HFNM(N,M) C CALCULATES HYDROGEN OSCILLATOR STRENGTHS DATA NSTR/0/,MSTR/0/ HFNM=0. IF(M.LE.N)RETURN IF(N.EQ.NSTR)GO TO 10 XN=N GINF=.2027/XN**.71 GCA=.124/XN FKN=XN*1.9603 WTC=.45-2.4/XN**3*(XN-1.) NSTR=N GO TO 15 10 IF(M.EQ.MSTR)GO TO 20 15 XM=M XMN=M-N FK=FKN*(XM/(XMN*(XM+XN)))**3 XMN12=XMN**1.2 WT=(XMN12-1.)/(XMN12+WTC) FNM=FK*(1.-WT*GINF-(.222+GCA/XM)*(1.-WT)) MSTR=M 20 HFNM=FNM RETURN END FUNCTION VCSE1F(X) C ROUGH, BUT ARRANGED TO BE FAST. X.GE.0 COMMON /EXTAB/EXTAB(1001),EXTABF(1001),E1TAB(2000) FASTEX(X)=EXTAB(IFIX(X)+1)* 1EXTABF(IFIX((X-FLOAT(IFIX(X)))*1000.+1.5)) VCSE1F=0. IF(X.LE.0.)RETURN IF(X.GT..01)GO TO 10 VCSE1F=-ALOG(X)-.577215+X RETURN 10 IF(X.GT.1.)GO TO 20 VCSE1F=-ALOG(X)-.57721566+X*(.99999193+X*(-.24991055+X*(.05519968+ 1X*(-.00976004+X*.00107857)))) RETURN 20 IF(X.GT.30.)RETURN C VCSE1F=(X*(X+2.334733)+.25062)/(X*(X+3.330657)+1.681534)/X*EXP(-X) VCSE1F=(X*(X+2.334733)+.25062)/(X*(X+3.330657)+1.681534)/X* 1FASTEX(X) RETURN END FUNCTION SOFBET(B,P,N,M) C GENERATES S(BETA,P) FOR HYDROGEN LINES. THE ALPHA AND BETA LINES C OF THE FIRST THREE SERIES ARE EXGLICITLY INCLUDED AND THE H18 C PROFILE IS USED FOR THE REST. C C THESE PROFILES HAVE BEEN RENORMALIZED TO FULL OSCILLATOR STRENGTH C C STORAGE FOR CORRECTIONS (P,BETA,IND),(P,IND),(P,IND) DIMENSION PROPBM(5,15,7),C(5,7),D(5,7) DIMENSION PP(5),BETA(15) DIMENSION PROB1(75),PROB2(75),PROB3(75),PROB4(75),PROB5(75) DIMENSION PROB6(75),PROB7(75) DIMENSION C1(5),C2(5),C3(5),C4(5),C5(5),C6(5),C7(5) DIMENSION D1(5),D2(5),D3(5),D4(5),D5(5),D6(5),D7(5) EQUIVALENCE (PROPBM(1),PROB1(1)),(PROPBM(76),PROB2(1)) EQUIVALENCE (PROPBM(151),PROB3(1)),(PROPBM(226),PROB4(1)) EQUIVALENCE (PROPBM(301),PROB5(1)),(PROPBM(376),PROB6(1)) EQUIVALENCE (PROPBM(451),PROB7(1)) EQUIVALENCE (C(1),C1(1)),(C(6),C2(1)),(C(11),C3(1)),(C(16),C4(1)) EQUIVALENCE (C(21),C5(1)),(C(26),C6(1)),(C(31),C7(1)) EQUIVALENCE (D(1),D1(1)),(D(6),D2(1)),(D(11),D3(1)),(D(16),D4(1)) EQUIVALENCE (D(21),D5(1)),(D(26),D6(1)),(D(31),D7(1)) C LYMAN ALPHA DATA PROB1/ 1-.980,-.967,-.948,-.918,-.873,-.968,-.949,-.921,-.879,-.821, 2-.950,-.922,-.883,-.830,-.764,-.922,-.881,-.830,-.770,-.706, 3-.877,-.823,-.763,-.706,-.660,-.806,-.741,-.682,-.640,-.625, 4-.691,-.628,-.588,-.577,-.599,-.511,-.482,-.484,-.514,-.568, 5-.265,-.318,-.382,-.455,-.531,-.013,-.167,-.292,-.394,-.478, 6 .166,-.056,-.216,-.332,-.415, .251, .035,-.122,-.237,-.320, 7 .221, .059,-.068,-.168,-.247, .160, .055,-.037,-.118,-.189, 8 .110, .043,-.022,-.085,-.147/ DATA C1 /-18.396, 84.674,-96.273, 3.927, 55.191/ DATA D1 / 11.801, 9.079, -.651,-11.071,-26.545/ C LYMAN BETA DATA PROB2/ 1-.242, .060, .379, .671, .894, .022, .314, .569, .746, .818, 2 .273, .473, .605, .651, .607, .432, .484, .489, .442, .343, 3 .434, .366, .294, .204, .091, .304, .184, .079,-.025,-.135, 4 .167, .035,-.082,-.189,-.290, .085,-.061,-.183,-.287,-.374, 5 .032,-.127,-.249,-.344,-.418,-.024,-.167,-.275,-.357,-.420, 6-.061,-.170,-.257,-.327,-.384,-.047,-.124,-.192,-.252,-.306, 7-.043,-.092,-.142,-.190,-.238,-.038,-.070,-.107,-.146,-.187, 8-.030,-.049,-.075,-.106,-.140/ DATA C2 / 95.740, 18.489, 14.902, 24.466, 42.456/ DATA D2 / -6.665, -7.136,-10.605,-15.882,-23.632/ C BALMER ALPHA DATA PROB3/ 1-.484,-.336,-.206,-.111,-.058,-.364,-.264,-.192,-.154,-.144, 2-.299,-.268,-.250,-.244,-.246,-.319,-.333,-.337,-.336,-.337, 3-.397,-.414,-.415,-.413,-.420,-.456,-.455,-.451,-.456,-.478, 4-.446,-.441,-.446,-.469,-.512,-.358,-.381,-.415,-.463,-.522, 5-.214,-.288,-.360,-.432,-.503,-.063,-.196,-.304,-.394,-.468, 6 .063,-.108,-.237,-.334,-.409, .151,-.019,-.148,-.245,-.319, 7 .149, .016,-.091,-.177,-.246, .115, .023,-.056,-.126,-.189, 8 .078, .021,-.036,-.091,-.145/ DATA C3 /-25.088,145.882,-50.165, 7.902, 51.003/ DATA D3 / 7.872, 5.592, -2.716,-12.180,-25.661/ C BALMER BETA DATA PROB4/ 1-.082, .163, .417, .649, .829, .096, .316, .515, .660, .729, 2 .242, .393, .505, .556, .534, .320, .373, .394, .369, .290, 3 .308, .274, .226, .152, .048, .232, .141, .052,-.046,-.154, 4 .148, .020,-.094,-.200,-.299, .083,-.070,-.195,-.299,-.385, 5 .031,-.130,-.253,-.348,-.422,-.023,-.167,-.276,-.359,-.423, 6-.053,-.165,-.254,-.326,-.384,-.038,-.119,-.190,-.251,-.306, 7-.034,-.088,-.140,-.190,-.239,-.032,-.066,-.103,-.144,-.186, 8-.027,-.048,-.075,-.106,-.142/ DATA C4 / 93.783, 10.066, 9.224, 20.685, 40.136/ DATA D4 / -5.918, -6.501,-10.130,-15.588,-23.570/ C PASCHEN ALPHA DATA PROB5/ 1-.819,-.759,-.689,-.612,-.529,-.770,-.707,-.638,-.567,-.498, 2-.721,-.659,-.595,-.537,-.488,-.671,-.617,-.566,-.524,-.497, 3-.622,-.582,-.547,-.523,-.516,-.570,-.545,-.526,-.521,-.537, 4-.503,-.495,-.496,-.514,-.551,-.397,-.418,-.448,-.492,-.547, 5-.246,-.315,-.384,-.453,-.522,-.080,-.210,-.316,-.406,-.481, 6 .068,-.107,-.239,-.340,-.418, .177,-.006,-.143,-.246,-.324, 7 .184, .035,-.082,-.174,-.249, .146, .042,-.046,-.123,-.190, 8 .103, .036,-.027,-.088,-.146/ DATA C5 /-19.819, 94.981,-79.606, 3.159, 52.106/ DATA D5 / 10.938, 8.028, -1.267,-11.375,-26.047/ C PASCHEN BETA DATA PROB6/ 1-.073, .169, .415, .636, .809, .102, .311, .499, .639, .710, 2 .232, .372, .479, .531, .514, .294, .349, .374, .354, .279, 3 .278, .253, .212, .142, .040, .215, .130, .044,-.051,-.158, 4 .141, .015,-.097,-.202,-.300, .080,-.072,-.196,-.299,-.385, 5 .029,-.130,-.252,-.347,-.421,-.022,-.166,-.275,-.359,-.423, 6-.050,-.164,-.253,-.325,-.384,-.035,-.118,-.189,-.252,-.306, 7-.032,-.087,-.139,-.190,-.240,-.029,-.064,-.102,-.143,-.185, 8-.025,-.046,-.074,-.106,-.142/ DATA C6 /111.107, 11.910, 9.857, 21.371, 41.006/ DATA D6 / -5.899, -6.381,-10.044,-15.574,-23.644/ C BALMER 18 DATA PROB7/ 1 .005, .128, .260, .389, .504, .004, .109, .220, .318, .389, 2-.007, .079, .162, .222, .244,-.018, .041, .089, .106, .080, 3-.026,-.003, .003,-.023,-.086,-.025,-.048,-.087,-.148,-.234, 4-.008,-.085,-.165,-.251,-.343, .018,-.111,-.223,-.321,-.407, 5 .032,-.130,-.255,-.354,-.431, .014,-.148,-.269,-.359,-.427, 6-.005,-.140,-.243,-.323,-.386, .005,-.095,-.178,-.248,-.307, 7-.002,-.068,-.129,-.187,-.241,-.007,-.049,-.094,-.139,-.186, 8-.010,-.036,-.067,-.103,-.143/ DATA C7 /511.318, 1.532, 4.044, 19.266, 41.812/ DATA D7 / -6.070, -4.528, -8.759,-14.984,-23.956/ DATA PP/0.,.2,.4,.6,.8/ DATA BETA/1.,1.259,1.585,1.995,2.512,3.162,3.981,5.012,6.310,7.943 1,10.,12.59,15.85,19.95,25.12/ CORR=1. B2=B*B SB=SQRT(B) IF(B.GT.500.)GO TO 40 INDX=7 MMN=M-N IF(N.LE.3.AND.MMN.LE.2)INDX=2*(N-1)+MMN C DETERMINE RELEVANT DEBYE RANGE IM=MIN0(INT(5.*P)+1,4) IP=IM+1 WTPP=5.*(P-PP(IM)) WTPM=1.-WTPP IF(B.GT.25.12)GO TO 30 DO 10 J=2,15 IF(B.LE.BETA(J))GO TO 20 10 CONTINUE 20 JM=J-1 JP=J WTBP=(B-BETA(JM))/(BETA(JP)-BETA(JM)) WTBM=1.-WTBP CBP=PROPBM(IP,JP,INDX)*WTPP+PROPBM(IM,JP,INDX)*WTPM CBM=PROPBM(IP,JM,INDX)*WTPP+PROPBM(IM,JM,INDX)*WTPM CORR=1.+CBP*WTBP+CBM*WTBM C GET INNER APPROXIMATE PROFILE PR1=0. PR2=0. WT=AMAX1(AMIN1(.5*(10.-B),1.),0.) IF(B.LE.10.)PR1=8./(83.+(2.+.95*B2)*B) IF(B.GE.8.)PR2=(1.5/SB+27./B2)/B2 SOFBET=(PR1*WT+PR2*(1.-WT))*CORR RETURN C ASYMPTOTIC PARTS 30 CC=C(IP,INDX)*WTPP+C(IM,INDX)*WTPM DD=D(IP,INDX)*WTPP+D(IM,INDX)*WTPM CORR=1.+DD/(CC+B*SB) 40 SOFBET=(1.5/SB+27./B2)/B2*CORR RETURN END FUNCTION HPROF4(N,M,J,DELW,DOPPH) C FUNCTION HPROFL(N,M,J,DELW) C VERSION FINE STRUCTURE LIKE GENERAL BUT APPROXIMATELY INCLUDES FINE C STRUCTURE IN THE DOPPLER CORES. EXACT PATTERN C IS USED FOR ALPHA LINES, M INFINITE PATTERN C IS USED FOR ALL OTHER LINES. C FROM DEANE PETERSON C REQUIRES VCSE1F AND SOFBET VCSEIF REPLACED BY FASTE1 PARAMETER (kw=99) REAL*8 DELW DIMENSION DOPPH(kw) 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 /RHOX/RHOX(kw),NRHOX COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw),PTOTAL(kw) COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP,HCKT(kw) COMMON /EXTAB/EXTAB(1001),EXTABF(1001),E1TAB(2000) DIMENSION PP(kw),FO(kw),GCON1(kw),GCON2(kw),Y1B(kw),Y1S(kw), 1C1D(kw),C2D(kw),Y1WTM(2,2),XKNMTB(4,3) DIMENSION T3NHE(kw) DIMENSION STCOMP(5,4),STALPH(34),ISTAL(4),LNGHAL(4),STWTAL(34), 1STCPWT(5,4),LNCOMP(4),FINEST(14),FINSWT(14) DATA XKNMTB/.0001716,.009019,.1001,.5820,.0005235,.01772,.171,.866 1,.0008912,.02507,.223,1.02/ DATA Y1WTM/1.E18,1.E17,1.E16,1.E14/ DATA ITEMP1/0/,N1/0/,M1/0/,RYDH/3.2880515E15/ C FINE STRUCTURE COMPONENTS FOR ALPHA LINES IN FREQ*10**-7 DATA STALPH/-730.,370.,188.,515.,327.,619.,-772.,-473.,-369.,120., 1256.,162.,285.,-161.,-38.3,6.82,-174.,-147.,-101.,-77.5,55.,126., 275.,139.,-60.,3.7,27.,-69.,-42.,-18.,-5.5,-9.1,-33.,-24./ C ALPHA COMPONENT WEIGHTS DATA STWTAL/1.,2.,1.,2.,1.,2.,1.,2.,3.,1.,2.,1.,2.,1.,4.,6.,1.,2., 13.,4.,1.,2.,1.,2.,1.,4.,6.,1.,7.,6.,4.,4.,4.,5./ DATA ISTAL/1,3,10,21/, LNGHAL/2,7,11,14/ C FINE STRUCTURE FOR M.EQ.INFINITY IN FREQ*10**-7 DATA STCOMP/0.,0.,0.,0.,0.,468.,576.,-522.,0.,0.,260.,290.,-33., 1-140.,0.0,140.,150.,18.,-27.,-51./ C WEIGHTS DATA STCPWT/1.,0.,0.,0.,0.,1.,1.,2.,0.,0.,1.,1.,4.,3.,0.,1.,1., 14.,6.,4./ DATA LNCOMP/1,3,4,5/ FASTEX(X)=EXTAB(IFIX(X)+1)* 1EXTABF(IFIX((X-FLOAT(IFIX(X)))*1000.+1.5)) IF(ITEMP.EQ.ITEMP1)GO TO 20 C SET UP DEPTH VECTORS ITEMP1=ITEMP DO 10 K=1,NRHOX XNE16=XNE(K)**.1666667 PP(K)=XNE16*.08989/SQRT(T(K)) FO(K)=XNE16**4*1.25E-9 Y1B(K)=2./(1.+.012/T(K)*SQRT(XNE(K)/T(K))) T4=T(K)/10000. T43=T4**.3 Y1S(K)=T43/XNE16 C T3NHE(K)=T43*XNFPHE(K,1) T3NHE(K)=T43*XNFHE(K,1) C1D(K)=FO(K)*78940./T(K) C2D(K)=FO(K)**2/5.96E-23/XNE(K) GCON1(K)=.2+.09*SQRT(T4)/(1.+XNE(K)/1.E13) GCON2(K)=.2/(1.+XNE(K)/1.E15) 10 CONTINUE C SET UP FOR THIS LINE 20 IF(N.EQ.N1.AND.M.EQ.M1)GO TO 30 N1=N M1=M MMN=M-N XN=N XN2=XN*XN XM=M XM2=XM*XM XMN2=XM2*XN2 XM2MN2=XM2-XN2 GNM=XM2MN2/XMN2 IF(MMN.LE.3.AND.N.LE.4)XKNM=XKNMTB(N,MMN) IF(MMN.GT.3.OR.N.GT.4)XKNM=5.5E-5/GNM*XMN2/(1.+.13/FLOAT(MMN)) Y1NUM=320. IF(M.EQ.2)Y1NUM=550. IF(M.EQ.3)Y1NUM=380. Y1WHT=1.E13 IF(MMN.LE.3)Y1WHT=1.E14 IF(MMN.LE.2.AND.N.LE.2)Y1WHT=Y1WTM(N,MMN) FREQNM=RYDH*GNM DBETA=2.997925E18/FREQNM**2/XKNM WAVE=2.997925E18/FREQNM C1CON=XKNM/WAVE*GNM*XM2MN2 C2CON=(XKNM/WAVE)**2 RADAMP=1.389E9/XM**4.53/(1.+5./XM2/XM) IF(N.NE.1)RADAMP=RADAMP+1.389E9/XN**4.53/(1.+5./XN2/XN) RADAMP=RADAMP/FREQNM RESONT=HFNM(1,M)/XM/(1.-1./XM2) IF(N.NE.1)RESONT=RESONT+HFNM(1,N)/XN/(1.-1./XN2) C FUDGE TO BASCHEK*2 C RESONT=HFNM(1,M)/XM/(1.-1./XM2)*XM/3.*.791*2. C IF(N.NE.1)RESONT=RESONT+HFNM(1,N)/XN/(1.-1./XN2)*XN/3.*.791*2. C 2 IS FOR CONVERTING XNFPH TO XNFH C RESONT=RESONT*5.593E-24/GNM*2. RESONT=RESONT*5.593E-24/GNM VDW=4.45E-26/GNM*(XM2*(7.*XM2+5.))**.4 STARK=1.6678E-18*FREQNM*XKNM C FINE STRUCTURE COMPONENTS C IF(N.GT.4)THEN IFINS=1 FINEST(1)=0. FINSWT(1)=1. GO TO 30 ENDIF C IF(MMN.EQ.1)GO TO 22 C USE M.EQ.INF STRUCTURE IFINS=LNCOMP(N) DO 21 I=1,IFINS FINEST(I)=STCOMP(I,N)*1.E7 FINSWT(I)=STCPWT(I,N)/XN2 21 CONTINUE GO TO 30 C FOR ALPHA LINES 22 IFINS=LNGHAL(N) IPOS=ISTAL(N) DO 23 I=1,IFINS K=IPOS-1+I FINEST(I)=STALPH(K)*1.E7 FINSWT(I)=STWTAL(K)/XN2/3. 23 CONTINUE C NOW DO THIS DEPTH 30 DEL=-10.*DELW/WAVE*FREQNM FREQ=FREQNM+DEL C THESE HALF-WIDTHS ARE REALLY DNU/NU HWSTK=STARK*FO(J) C HWLOR=RESONT*XNFPH(J,1)+VDW*T3NHE(J)+RADAMP HWLOR=RESONT*XNFH(J)+VDW*T3NHE(J)+RADAMP C SPECIFY LARGEST HALF WIDTH IN CASE OF CORE CALC C NWID=1, DOPPLER =2, LORENTZ =3, STARK NWID=1 IF(DOPPH(J).GE.HWSTK.AND.DOPPH(J).GE.HWLOR)GO TO 31 NWID=2 IF(HWLOR.GE.HWSTK)GO TO 31 NWID=3 31 HFWID=FREQNM*AMAX1(DOPPH(J),HWLOR,HWSTK) C SETS FLAG IF IN A LINE CORE C HPROFL=0. HPROF4=0. IFCORE=0 IF(ABS(DEL).LE.HFWID)IFCORE=1 DOP=FREQNM*DOPPH(J) IF(IFCORE.EQ.1)GO TO (32,40,50),NWID C DO DOPPLER C PUT FINE STRUCTURE IN DOPPLER CORE 32 DO 33 I=1,IFINS D=ABS(FREQ-FREQNM-FINEST(I))/DOP C IF(D.LE.7.)HPROF4=HPROF4+EXP(-D*D)/1.77245/DOP*FINSWT(I) C IF(D.LE.7.)HPROFL=HPROFL+EXP(-D*D)/1.77245/DOP*FINSWT(I) C SAME NORMALIZATION AS VOIGT FUNCTION IF(D.LE.7.)HPROF4=HPROF4+FASTEX(D*D)*FINSWT(I) 33 CONTINUE IF(IFCORE.EQ.1)RETURN C DO LORENTZ 40 IF(N.NE.1.OR.FREQ.GT.1.8474E15)GO TO 41 C INSERT LYMAN ALPHA CUTOFF ALA SANDO AND WORMHOUDT (1973 PHYS REV A C 7,1889) FF=1.-FREQ/1.8476E15 C HWLOR=RESONT*PH(J,1)/(1.+EXP(-4492./T(J))*SQRT(FF)*EXP(1398./ C HWLOR=RESONT*XNFPH(J,1)/(1.+FASTEX(4492./T(J))*SQRT(FF)*EXP(1398./ HWLOR=RESONT*XNFH(J)/(1.+FASTEX(4492./T(J))*SQRT(FF)*EXP(1398./ 1T(J)**.333333*FF))+VDW*T3NHE(J)+RADAMP 41 HHW=FREQNM*HWLOR HPROF4=HPROF4+HHW/3.14159/(DEL**2+HHW**2)*1.77245*DOP C HPROFL=HPROFL+HHW/3.1416/(DEL**2+HHW**2) IF(IFCORE.EQ.1)RETURN C DO STARK 50 WTY1=1./(1.+XNE(J)/Y1WHT) Y1SCAL=Y1NUM*Y1S(J)*WTY1+Y1B(J)*(1.-WTY1) C1=C1D(J)*C1CON*Y1SCAL C2=C2D(J)*C2CON G1=6.77*SQRT(C1) GNOT=G1*AMAX1(0.,.2114+ALOG(SQRT(C2)/C1))*(1.-GCON1(J)-GCON2(J)) BETA=ABS(DEL)/FO(J)*DBETA Y1=C1*BETA Y2=C2*BETA**2 GAM=GNOT C IF(Y2.LE..001)GO TO 51 IF(Y2.LE.1.E-4.AND.Y1.LE.1.E-5)GO TO 51 C GAM=G1*(.5*EXP(-AMIN1(80.,Y1))+VCSE1F(Y1)-.5*VCSE1F(Y2))* C GAM=G1*(.5*FASTEX(AMIN1(80.,Y1))+VCSE1F(Y1)-.5*VCSE1F(Y2))* GAM=G1*(.5*FASTEX(AMIN1(80.,Y1))+FASTE1(Y1)-.5*FASTE1(Y2))* 1(1.-GCON1(J)/(1.+(90.*Y1)**3)-GCON2(J)/(1.+2000.*Y1)) IF(GAM.LE.1.E-20)GAM=0. 51 PRQS=SOFBET(BETA,PP(J),N,M) F=0. IF(GAM.GT.0.)F=GAM/3.14159/(GAM**2+BETA**2) P1=(.9*Y1)**2 FNS=(P1+.03*SQRT(Y1))/(P1+1.) C HPROFL=HPROFL+(PRQS*(1.+FNS)+F)/FO(J)*DBETA C SAME NORMALIZATION AS VOIGT FUNCTION HPROF4=HPROF4+(PRQS*(1.+FNS)+F)/FO(J)*DBETA*1.77245*DOP RETURN END SUBROUTINE HE2LIN RETURN END SUBROUTINE TABVOIGT(VSTEPS,N) COMMON /H1TAB/H0TAB(2001),H1TAB(2001),H2TAB(2001) DIMENSION TABVI(81),TABH1(81) DATA TABVI/0.,.1,.2,.3,.4,.5,.6,.7,.8,.9,1.,1.1,1.2,1.3,1.4,1.5, 11.6,1.7,1.8,1.9,2.,2.1,2.2,2.3,2.4,2.5,2.6,2.7,2.8,2.9,3.,3.1,3.2, 2 3.3,3.4,3.5,3.6,3.7,3.8,3.9,4.0,4.2,4.4,4.6,4.8,5.0,5.2,5.4,5.6, 3 5.8,6.0,6.2,6.4,6.6,6.8,7.0,7.2,7.4,7.6,7.8,8.0,8.2,8.4,8.6,8.8, 4 9.0,9.2,9.4,9.6,9.8,10.0,10.2,10.4,10.6,10.8,11.0,11.2,11.4,11.6, 5 11.8,12.0/ DATA TABH1/-1.12838,-1.10596,-1.04048,-.93703,-.80346,-.64945, 1-.48552,-.32192,-.16772,-.03012,.08594,.17789,.24537,.28981, 2.31394,.32130,.31573,.30094,.28027,.25648,.231726,.207528,.184882, 3.164341,.146128,.130236,.116515,.104739,.094653,.086005,.078565, 4 .072129,.066526,.061615,.057281,.053430,.049988,.046894,.044098, 5 .041561,.039250,.035195,.031762,.028824,.026288,.024081,.022146, 6 .020441,.018929,.017582,.016375,.015291,.014312,.013426,.012620, 7 .0118860,.0112145,.0105990,.0100332,.0095119,.0090306,.0085852, 8 .0081722,.0077885,.0074314,.0070985,.0067875,.0064967,.0062243, 9 .0059688,.0057287,.0055030,.0052903,.0050898,.0049006,.0047217, T .0045526,.0043924,.0042405,.0040964,.0039595/ C PRETABULATE VOIGT FUNCTION C 100 STEPS PER DOPPLER WIDTH GIVES 2 PER CENT ACCURACY DO 1 I=1,N 1 H0TAB(I)=FLOAT(I-1)/VSTEPS CALL MAP1(TABVI,TABH1,81,H0TAB,H1TAB,N) DO 2 I=1,N VV=(FLOAT(I-1)/VSTEPS)**2 H0TAB(I)=EXP(-VV) 2 H2TAB(I)=H0TAB(I)-(VV+VV)*H0TAB(I) RETURN END FUNCTION VOIGT(V,A) C FAST VOIGT COMMON /H1TAB/H0TAB(2001),H1TAB(2001),H2TAB(2001) IV=V*200.+1.5 IF(A.LT..2)GO TO 10 IF(A.GT.1.4)GO TO 2 IF(A+V.GT.3.2)GO TO 2 VV=V*V HH1=H1TAB(IV)+H0TAB(IV)*1.12838 HH2=H2TAB(IV)+HH1*1.12838-H0TAB(IV) HH3=(1.-H2TAB(IV))*.37613-HH1*.66667*VV+HH2*1.12838 HH4=(3.*HH3-HH1)*.37613+H0TAB(IV)*.66667*VV*VV VOIGT=((((HH4*A+HH3)*A+HH2)*A+HH1)*A+H0TAB(IV))* 1 (((-.122727278*A+.532770573)*A-.96284325)*A+.979895032) RETURN 2 AA=A*A VV=V*V U=(AA+VV)*1.4142 UU=U*U VOIGT= A ((((AA-10.*VV)*AA*3.+15.*VV*VV)/UU+3.*VV-AA)/UU+1.)*A*.79788/U RETURN 10 IF(V.GT.10.)GO TO 12 11 VOIGT=(H2TAB(IV)*A+H1TAB(IV))*A+H0TAB(IV) RETURN 12 VOIGT=.5642*A/V**2 RETURN END FUNCTION EXPI(N,X) C LOW PRECISION VERSION 1.E-5 C EXPONENTIAL INTEGRAL FOR POSITIVE ARGUMENTS AFTER CODY AND C THACHER, MATH. OF COMP.,22,641(1968) DATA X1/-1.E20/ DATA A0,A1,A2,B0,B1/-4.43668255,4.42054938,3.16274620,7.68641124, 1 5.65655216/ DATA C0,C1,C2,D1,D2/.0012102205,.98147989,.75339742,1.6198645, 1 .29135151/ DATA E0,E1,F1/-.9969698,-.4257849,2.318261/ IF(X.EQ.X1)GO TO 40 EX=EXP(-X) X1=X IF(X.GT.4.)GO TO 10 IF(X.GT.1.)GO TO 20 IF(X.GT.0.)GO TO 30 EX1=0. GO TO 40 10 EX1=(EX+EX*(E0+E1/X)/(X+F1))/X GO TO 40 20 EX1=EX*(C2+(C1+C0*X)*X)/(D2+(D1+X)*X) GO TO 40 30 EX1=(A0+(A1+A2*X)*X)/(B0+(B1+X)*X)-ALOG(X) 40 EXPI=EX1 IF(N.EQ.1)RETURN N1=N-1 DO 41 I=1,N1 41 EXPI=(EX-X*EXPI)/FLOAT(I) RETURN END FUNCTION FASTE1(X) COMMON /EXTAB/EXTAB(1001),EXTABF(1001),E1TAB(2000) C DO 3457 I=1,2000 C3457 E1TAB(I)=EXPI(1,FLOAT(I)*.01) FASTE1=0. IF(X.GT.20)RETURN IF(X.LT..5)GO TO 1 FASTE1=E1TAB(IFIX(X*100.+.5)) RETURN 1 IF(X.LE.0.)RETURN FASTE1=(1.-.22464*X)*X-ALOG(X)-.57721 RETURN END SUBROUTINE ABORT PARAMETER (SS$_ABORT='002C'X) CALL LIB$STOP(%VAL(SS$_ABORT)) END SUBROUTINE BEGTIME C WRITES OUT ELAPSED SYSTEM ACCOUNTING MESSAGE PARAMETER (SS$_ABORT='002C'X) IF(.NOT.LIB$INIT_TIMER())CALL LIB$STOP(%VAL(SS$_ABORT)) RETURN ENTRY ENDTIME IF(.NOT.LIB$SHOW_TIMER())CALL LIB$STOP(%VAL(SS$_ABORT)) RETURN END