diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-02-16 12:40:45 -0500 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-02-16 12:40:45 -0500 |
| commit | 0373ffdfaaaa3845306ca71243d535fdffd941d4 (patch) | |
| tree | 194c3c278d7e352e39d555d31aae93c0be2dfc03 /synthe/plotsynimcol.for | |
| parent | 01b51f73bd06b2d6eabb776ba6cc69e4abfaa0b3 (diff) | |
| download | kasym-0373ffdfaaaa3845306ca71243d535fdffd941d4.tar.gz | |
Initial commit
Diffstat (limited to 'synthe/plotsynimcol.for')
| -rw-r--r-- | synthe/plotsynimcol.for | 3634 |
1 files changed, 3634 insertions, 0 deletions
diff --git a/synthe/plotsynimcol.for b/synthe/plotsynimcol.for new file mode 100644 index 0000000..771d38c --- /dev/null +++ b/synthe/plotsynimcol.for @@ -0,0 +1,3634 @@ + PROGRAM PLOTSYN +c revised 23jan93 +C TAPE7 IS CALCULATED SPECTRUM +C TAPE55 READ BY OBSERV +C TAPE56 READ BY OBSERV1 +C TAPE57 READ BY OBSERV2 +C TAPE58 READ BY OBSENGV +C TAPE59 READ BY OBSHALL +C TAPE60 READ BY OBSKPNO +C TAPE61 READ BY OBSKPK +C TAPE62 READ BY OBSSACP +C TAPE63 READ BY OBSHAWA +C TAPE64 READ BY OBSNRL +C TAPE65 READ BY OBSPROC +C TAPE66 READ BY OBSSIR +C TAPE67 READ BY OBSARC +C TAPE68 READ BY OBSSUNF +C TAPE69 READ BY OBSSOIR +C TAPE71 READ BY OBSFTS2 +C TAPE72 READ BY OBSFTS2 +C TAPE73 READ BY OBSFTS +C TAPE74 READ BY OBSJUNG +C TAPE76 READ BY LABEL5 AFCRL LINE LIST +C TAPE77 READ BY LABEL9 PIERCE AND BRECKENRIDGE +C TAPE93 IS TEMPORARY STORAGE FOR LABEL DATA +C +C IFLABL=N LINES ARE LABELLED. A NUMBER N ENDING IN THE DIGIT I +C PRODUCES A CALL TO SUBROUTINE LABELI +C =1 NORMAL LABELS FOR CALCULATED SPECTRUM, 25/INCH, TWO ROWS +C =11 NORMAL LABELS FOR CALCULATED SPECTRUM, 12.5/INCH, ONE ROW +C =21 +C =31 NORMAL LABELS FOR CALCULATED SPECTRUM, 12.5/INCH, +C LOWER ROW ATOMS, UPPER ROW MOLECULES +C =2 +C =3 +C =4 +C =5 LABEL AFCRL TERRESTRIAL LINES 25/INCH, TWO ROWS +C =15 LABEL AFCRL TERRESTRIAL LINES 12.5/INCH, ONE ROW +C =6 +C =7 NORMAL LABELS FOR CALCULATED OPACITY SPECTRUM, 25/INCH +C =8 +C =9 LABEL PIERCE AND BRECKENRIDGE LINES +C IFLABL=0 NO LABELS +C IFABSO=0 THE PLOT IS IN RESIDUAL INTENSITY OR FLUX +C IFABSO=1 THE PLOT IS IN ABSOLUTE UNITS +C IFCONT=1 AND IFABSO=1 THE CONTINUUM IS PLOTTED +C IFCONT=0 NO CONTINUUM +C IFCONT=2 CONTINUUM USED FOR MAXIMUM BUT NOT PLOTTED +C IFCONT=3 ONLY CONTINUUM IS PLOTTED +C IFGRID=1 A BACKGROUND GRID IS PLOTTED IF XSCALE= 2. +C IFDLINE=1 SPECTRUM LINES ARE DOUBLE WEIGHT +C IFLOG=1 PLOT IS LOG WITH CYCLES CYCLES +C IFLOG=0 PLOT IS LINEAR +C JUST1=0 ALL PANELS ARE PLOTTED +C JUST1 GREATER THAN 0 A TABLE OF SWITCHES FOR EACH PANEL IS READ +C NOWAVE=1 DO NOT PUT WAVELENGTH IN BANNER AT ENDS OF PANELS +C NOWAVE=0 PUT WAVELENGTH IN BANNER AT ENDS OF PANELS +C IFNEWW CHANGE TO NEW STARTING AND STOPPING WAVELENGTHS AS READ IN +C NOCALC=0 CALCULATIONS ARE TO BE READ +C NOCALC=1 NO CALCULATIONS ARE TO BE READ REQUIRES IFNEWW=1 +C IFDUM1 +C IFNOAX=1 AXES ARE NOT LABELLED +C IFNOAX=-1 AXES ARE LABELLED. Y TWICE 0 TO 1 AND .9 TO 1 +C IFMU=0 PLOT FIRST ANGLE OR FLUX +C IFMU=1 TO 20 PLOT ANGLE IFMU +C NOPRNT=0 PRINT ALL LINE DATA +C NOPRNT=1 NO PRINTING OF LINE DATA +C NOPRNT=2 PRINT LINE DATA ONLY FOR LINES THAT ARE LABELLED +C IFKPNO.GT.0 PLOT KITT PEAK PRELIMINARY SOLAR ATLAS +C IFKPK.GT.0 PLOT KOHL, PARKINSON, AND KURUCZ SOLAR ATLAS +C IFSACP.GT.0 PLOT SAC PEAK SOLAR FLUX ATLAS +C IFHAWA.GT.0 PLOT HAWAII SOLAR ATLAS +C IFNRL.GT.0 PLOT NRL SOLAR ATLAS +C IFPROC.GT.0 PLOT GRIFFIN PROCYON ATLAS +C IFDUM2 +C IFSIR.GT.0 PLOT FURENLID SIRIUS ATLAS +C IFARC.GT.0 PLOT GRIFFIN ARCTURUS ATLAS +C IFSUNF.GT.0 PLOT FURENLID AND KURUCZ SOLAR FLUX ATLAS +C IFSOIR.GT.0 PLOT INFRARED FTS SOLAR ATLAS +C IFHALL.GT.0 PLOT HALL INFRARED SUNSPOT ATLAS +C IFENGV.GT.0 PLOT ENGVOLD SUNSPOT ATLAS +C IFOPAC=N INPUT CALCULATED SPECTRUM IS MASS ABSORPTION COEFFICIENT +C OUTPUT FROM SYNTHE. USE ASYNTH(N). PLOT MUST USUALLY BE LOG. +C IFFTS.GT.0 PLOT AN FTS SPECTRUM FROM KITT PEAK +C IFFTS2.GT.0 PLOT THE RATIO OF TWO FTS SPECTRA FROM KITT PEAK +C IFJUNG.GT.0 PLOT JUNGFRAUJOCH SOLAR ATLAS +C YSCALE IS THE HEIGHT OF THE PLOT IN MULTIPLES OF 3.125 +C DEFAULT=1. FOR XSCALE.GT.0 AND XSCALE.LT.1 +C DEFAULT=2. FOR XSCALE.GT.1 +C OTHERWISE YTOP=6.25 +C XSCALE=1. 10 IN/NM +C XSCALE=2. 20 IN/NM +C XSCALE=4. 40 IN/NM +C XSCALE=8. 80 IN/NM +C WEAK IS 1.-RESIDUAL INTENSITY OF THE WEAKEST LINES TO BE LABELED +C IF WEAK = 0 ALL LINES ARE LABELED +C PANEL IS MAXIMUM LENGTH OF EACH PLOT PANEL +C AN ADDITIONAL .1NM IS ADDED FOR OVERLAP BETWEEN PANELS +C CYCLES IS NUMBER OF CYCLES IF PLOT IS LOG +C OFFSET IS THE NUMBER OF INCHES BY WHICH THE PLOT IS DISPLACED +C VERTICALLY +C RMIN IS THE RESIDUAL INTENSITY AT THE BOTTOM OF THE PLOT +C RMAX IS THE RESIDUAL INTENSITY AT THE TOP OF THE PLOT. DEFAULT 1. +C TOP FIXES THE VALUE OF THE TOP OF THE PLOT IF IFABSO = 1 +C IF TOP=0. THE TOP IS SET TO THE MAXIMUM VAUE IN EACH PANEL +C WNEW1 IS A NEW STARTING WAVELENGTH +C WNEW2 IS A NEW STOPPING WAVELENGTH +C TICKTOP IS THE SIZE AND DIRECTION OF TICK MARKS AT THE TOP OF THE PLOT +C TICKBOT IS THE SIZE AND DIRECTION OF TICK MARKS AT THE BOTTOM OF THE PLOT +C DEFAULT IS -0.15 AND +0.15 +C SMOOTH IS A SMOOTHING PARAMETER TO BE TRANSMITTED TO OBS SUBROUTINES +C IT WOULD GENERALLY BE THE FWHM IN POINT NUMBERS OF A GAUSSIAN +C IF NEGATIVE IT IS THE CENTRAL WEIGHT FOR THREE POINT SMOOTHING +C DOPOBS IS A DOPPLER SHIFT IN KM/S FOR THE OBSERVED SPECTRA +C DOPCALC IS A DOPPLER SHIFT IN KM/S FOR THE CALCULATED SPECTRUM +C DOPTERR IS A DOPPLER SHIFT IN KM/S FOR TERRESTRIAL SPECTRUM OR LABELS +C SCALOBS IS A FACTOR BY WHICH AN OBSERVED SPECTRUM IS TO BE SCALED +C ZEROOBS IS A ZERO LEVEL CORRECTION TO AN OBSERVED SPECTRUM +C RMIN2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMIN2 +C RMAX2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMAX2 +C XOFFSET IS THE NUMBER OF INCHES THE PLOT IS DISPLACED IN X +C SCALOB2 IF 0 = SCALOBS +C IF NOT 0 SCALOBS IS THE SCALING FACTOR FOR THE BEGINNING AND +C SCALOB2 IS THE SCALING FACTOR FOR THE END AND +C INTERMEDIATE VALUES ARE LINEARLY INTERPOLATED +C DUMMY7 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WAVE,WBEGDOP + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*8 Q2(40) +C REAL*4 MESSAGE(20,9),ASYNTH(64),TURBV,ALINEC(64) + REAL*4 ASYNTH(64),TURBV,ALINEC(64) + CHARACTER*79 MESSAGE(9) + INTEGER VLO,VUP +CCRAY REAL*8 WORDS(3) + REAL*4 WORDS(6) + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 + DIMENSION IFPANL(80) + COMMON /HEADERDATA/USERID(2),FILENAME(2), + 1 IDATE(3),ITIME(2),JOBID(2) + REAL*8 USERID,FILENAME + CHARACTER*9 HEADERDATA(5) + CHARACTER*6 WW6,STRING6 + CHARACTER*9 STRING9 + CHARACTER*10 COLORCALC + DATA IFPANL/80*1/ +C CALL FILEREP +C CALL BEGTIME +C CALL RDYOUTF(6,0) + READ(5,1001)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1,NOWAVE, + 1NOCALC,IFDUM1 + 1001 FORMAT(10I8) + WRITE(6,1002)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1, + 1NOWAVE,NOCALC,IFDUM1 + 1002 FORMAT(1X,10I8/' IFLABL IFABSO IFCONT IFGRID IFDLIN', + 1' IFLOG JUST1 NOWAVE NOCALC IFDUM1') + READ(5,1001) + READ(5,1001)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IRNRL, + 1IFPROC,IFSIR + WRITE(6,1003)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, + 1IFPROC,IFDUM2 + 1003 FORMAT(1X,10I8/' IFNOAX IFMU NOPRNT IFKPNO IFKPK' + 1' IFSACP IFHAWA IFNRL IFPROC IFDUM2') + READ(5,1001) + READ(5,1001)IFSIR,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC,IFFTS, + 1IFFTS2,IFJUNG + WRITE(6,1004)IFSIR,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC, + 1IFFTS,IFFTS2,IFJUNG + 1004 FORMAT(1X,10I8/' IFSIR IFARC IFSUNF IFSOIR IFHALL', + 1' IFENGV IFOPAC IFFTS IFFTS2 IFJUNG') + READ(5,1001) + READ(5,1005)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX + 1005 FORMAT(8F10.3) + WRITE(6,1006)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX + 1006 FORMAT(1X,8F10.3/75H YSCALE XSCALE WEAK PANEL CYCLE + 1S OFFSET RMIN RMAX) + READ(5,1001) + READ(5,1007)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC + 1007 FORMAT(E10.3,7F10.3) + WRITE(6,1008)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC + 1008 FORMAT(1PE10.3,0P7F10.3/79H TOP WNEW1 WNEW2 TICKTOP + 1 TICKBOT SMOOTH DOPOBS DOPCALC ) + READ(5,1001) + READ(5,1027)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, + 1COLORCALC + 1027 FORMAT(7F10.3,A10) + WRITE(6,1028)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, + 1COLORCALC + 1028 FORMAT(7F10.3,A10/'DOPTERR SCALOBS ZEROOBS RMIN2 RMAX2 + 1 XOFFSET SCALOB2 COLORCALC' ) + READ(5,1001) + READ(5,1009)IFPANL + 1009 FORMAT(80I1) + WRITE(6,1010)IFPANL + 1010 FORMAT(1X,80I1/81H 12345678901234567890123456789012345678901234567 + 1890123456789012345678901234567890) + READ(5,1001) + MU=IFMU + IF(IFMU.EQ.0)MU=1 + IF(JUST1.GT.0)GO TO 1020 + DO 1019 IPANEL=1,80 + 1019 IFPANL(IPANEL)=1 + 1020 CONTINUE + READ(5,2)MESSAGE + 2 FORMAT(1X,A79) + WRITE(6,2)MESSAGE + 5 CONTINUE + IF(RMAX.EQ.0.)RMAX=1. + IFRMAX2=0 + IF(RMIN2.NE.0.)IFRMAX2=1 + IF(RMAX2.NE.0.)IFRMAX2=1 + IF(RMAX2.EQ.0.)RMAX2=1. + Y=YSCALE + IF(XSCALE.EQ.0.)XSCALE=2. + YSCALE=2. + IF(XSCALE.LT.1.)YSCALE=1. + IF(Y.GT.0.)YSCALE=Y + IF(PANEL.EQ.0.)PANEL=5. + IF(SCALOBS.EQ.0.)SCALOBS=1. + IF(SCALOB2.EQ.0.)SCALOB2=SCALOBS +C OPEN(UNIT=55,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') + IF(NOCALC.EQ.1)GO TO 207 +C OPEN(UNIT=7,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') + REWIND 7 + IF(IFOPAC.NE.0)GO TO 205 + READ(7)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF,NMU,XMU,NEDGE, + 1WLEDGE + NMU2=NMU+NMU + MUNMU=MU+NMU + WRITE(6,4)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF + 4 FORMAT(F10.1,F10.3,3X,74A1/F12.4,F10.1,2I10) + IFVAC=1 + IF(TITLE(74).EQ.1HA)IFVAC=0 +C WBEGIN IS THE FIRST CALCULATED WAVELENGTH +C WSTART IS THE FIRST PLOTTED WAVELENGTH + WSTART=WBEGIN + RATIO=1.+1./RESOLU + WEND=WBEGIN*RATIO**(NWL-1) + IWEND=WEND*10.+.5 + WEND=FLOAT(IWEND)/10. + IWSTART=WBEGIN*10.+.5 + WSTART=FLOAT(IWSTART)/10. + IF(WNEW1.EQ.0.)WNEW1=WSTART + IF(WNEW2.EQ.0.)WNEW2=WEND + GO TO 207 + 205 CONTINUE + READ(7)WBEGIN,RESOLU,WLEND,NWL,NRHOX,LINOUT,TURBV,IFVAC + READ(7) + WRITE(6,214)WBEGIN,RESOLU,NWL,NRHOX,IFVAC + 214 FORMAT(F10.3,F10.1,3I10) + IWSTART=WBEGIN*10.+.5 + WSTART=FLOAT(IWSTART)/10. + RATIO=1.+1./RESOLU + WEND=WBEGIN*RATIO**(NWL-1) + IWEND=WEND*10.+.5 + WEND=FLOAT(IWEND)/10. + IF(WNEW1.EQ.0.)WNEW1=WBEGIN + IF(WNEW2.EQ.0.)WNEW2=WEND + 207 CONTINUE + IF(IFLABL.GT.0.AND.NOCALC.EQ.0)THEN + DO 2207 I=1,NWL + 2207 READ(7) + if(abs(dopobs).le.0.)go to 2217 + read(7)nlines,nlines1,nlines2 + write(93)nlines,nlines1,nlines2 + do 2218 i=1,nlines1 + read(7)lindat8,lindat +2218 write(93)lindat8,lindat + do 2219 i=1,nlines2 + read(7)lindat8,lindat +2219 write(93)lindat8,lindat + go to 2220 +2217 READ(7)NLINES + WRITE(93)NLINES + DO 2208 I=1,NLINES + READ(7)LINDAT8,LINDAT + 2208 WRITE(93)LINDAT8,LINDAT +2220 continue + ENDIF + CALL MAXLENGTH(500) + CALL INITPLT(70) +C CALL START AT (1.,.5) +C CALL START AT (0.,OFFSET) + if(ifdlin.eq.0)call weight(1) + if(ifdlin.eq.1)call weight(2) + END=0. + NPANEL=(WNEW2-WNEW1+PANEL-.001)/PANEL + IPAN1=0 + DO 100 IPANEL=1,NPANEL + W1=WNEW1+FLOAT(IPANEL-1)*PANEL + W2= MIN (W1+PANEL+.1,WNEW2) +C W2=AMIN1(W1+PANEL+.1,WNEW2) + WRITE(6,2990)IPANEL,W1,W2 + 2990 FORMAT(6H PANEL,I3,2F10.3) + IF(IFPANL(IPANEL).EQ.0)GO TO 100 + IF(IPAN1.GT.0)CALL PAGE +C IF(IPAN1.GT.0)CALL START AT (10.,0.) +C CALL START AT (4.85,.5+OFFSET) + CALL START AT (1.0+XOFFSET,.5+OFFSET) + IPAN1=1 + WW=W1 + ENCODE(6,2993,WW6)WW + 2993 FORMAT(F6.1) + ENCODE(9,2991,HEADERDATA(1))USERID + ENCODE(9,3992,HEADERDATA(2))JOBID + 3992 FORMAT(A4,A4) + ENCODE(9,3992,HEADERDATA(3))ITIME + ENCODE(9,3993,HEADERDATA(4))IDATE + 3993 FORMAT(A4,A4,A1) + ENCODE(9,2991,HEADERDATA(5))FILENAME + 2991 FORMAT(A8,A1) +c canon is 0.5 higher than xerox THESE ARE CANON + CANON=0. + CANON=.5 +c IF(NOWAVE.EQ.0)THEN +c CALL STRINGX10(WW6,0.,14.20-OFFSET+CANON) +c CALL STRINGX10(WW6,19.5,14.20-OFFSET+CANON) +c CALL STRINGX(HEADERDATA(1),4.0,14.85-OFFSET+CANON) +c CALL STRINGX(HEADERDATA(2),4.0,14.70-OFFSET+CANON) +c CALL STRINGX(HEADERDATA(3),4.0,14.55-OFFSET+CANON) +c CALL STRINGX(HEADERDATA(4),4.0,14.40-OFFSET+CANON) +c CALL STRINGX(HEADERDATA(5),4.0,14.25-OFFSET+CANON) +c ENDIF +C CALL STRINGX(MESSAGE(1),6.,14.85-OFFSET+CANON) +C CALL STRINGX(MESSAGE(2),6.,14.70-OFFSET+CANON) +C CALL STRINGX(MESSAGE(3),6.,14.55-OFFSET+CANON) +C CALL STRINGX(MESSAGE(4),6.,14.40-OFFSET+CANON) +C CALL STRINGX(MESSAGE(5),6.,14.25-OFFSET+CANON) +C CALL STRINGX(MESSAGE(6),12.,14.70-OFFSET+CANON) +C CALL STRINGX(MESSAGE(7),12.,14.55-OFFSET+CANON) +C CALL STRINGX(MESSAGE(8),12.,14.40-OFFSET+CANON) +C CALL STRINGX(MESSAGE(9),12.,14.25-OFFSET+CANON) + CALL STRINGX(MESSAGE(1),3.,10.20) + CALL STRINGX(MESSAGE(2),3.,9.95) + CALL STRINGX(MESSAGE(3),3.,9.70) + CALL STRINGX(MESSAGE(4),3.,9.45) + CALL STRINGX(MESSAGE(5),3.,9.20) + CALL STRINGX2(MESSAGE(6),0.25,0.1) + CALL STRINGX(MESSAGE(7),9.,9.70) + CALL STRINGX(MESSAGE(8),9.,9.45) + CALL STRINGX(MESSAGE(9),9.,9.20) + CALL COLOR BLACK +C +C DRAW BOX + END=(W2-W1)*10.*XSCALE + CALL JUMP TO (0.,0.) + CALL LINE TO (END,0.) + YTOP=3.125*YSCALE + CALL LINE TO (END,YTOP) + CALL LINE TO (0.,YTOP) + CALL LINE TO (0.,0.) +C +C X AXIS + CALL WEIGHT(2) + N=(W2-W1)*10.+1.5 + IF(TICKTOP.EQ.0.)TICKTOP=-.15 + IF(TICKBOT.EQ.0.)TICKBOT=.15 + DO 11 I=1,N + HALF=1. + IF(XSCALE.LT.1..AND.MOD(I,5).NE.1)HALF=.5 + IF(XSCALE.LT..05.AND.MOD(I,100).NE.1)HALF=.5 + IF(XSCALE.LT..01.AND.MOD(I,500).NE.1)HALF=.5 + IF(XSCALE.LT..05.AND.MOD(I,10).NE.1)GO TO 11 + IF(XSCALE.LT..01.AND.MOD(I,100).NE.1)GO TO 11 + X=FLOAT(I-1)*XSCALE + CALL JUMP TO (X,0.) + CALL LINE TO (X,TICKBOT*HALF) + CALL JUMP TO (X,YTOP+TICKTOP*HALF) + CALL LINE TO (X,YTOP) + WAVE=W1+FLOAT(I-1)/10. + IF(XSCALE.LT.1..AND.MOD(I,5).NE.1)GO TO 11 + IF(XSCALE.LT..2.AND.MOD(I,10).NE.1)GO TO 11 + IF(XSCALE.LT..05.AND.MOD(I,100).NE.1)GO TO 11 + IF(XSCALE.LT..01.AND.MOD(I,500).NE.1)GO TO 11 + IF(IFNOAX.NE.1.AND.XSCALE.GE..2)THEN + WRITE(WW6,'(F6.1)')WAVE + CALL STRINGX2(WW6,X-.4,-.3) + ENDIF + IF(IFNOAX.NE.1.AND.XSCALE.LT..2)THEN + IWAVE=WAVE + WRITE(WW6,'(I6)')IWAVE + CALL STRINGX2(WW6,X-.6,-.3) + ENDIF + IF(IFGRID.EQ.0)GO TO 11 + CALL JUMP TO (X,0.) + CALL WEIGHT(12) + CALL LINE TO (X,YTOP) + CALL WEIGHT(1) + 11 CONTINUE +C + IF(XSCALE.GT.10..AND.IFNOAX.NE.1)THEN + N=END*.1+.05 + DO 1611 I=1,N + WAVE=W1+FLOAT(I)/XSCALE + X=I*10 + WRITE(STRING9,'(F9.4)')WAVE + 1611 CALL STRINGX2(STRING9,X-.4,-.3) + ENDIF +c call stringx2('@l (nm)',x-1., 0.3) + If(ifnoax.ne.1)call stringx2('Wavelength (nm)',X/2-1.0, -.6) +C +C Y AXIS + nstep=(rmax-rmin+0.002)*10 + if(rmax.gt.1.)go to 17 +c DO 12 I=1,11 + DO 12 I=1,nstep+1 +c Y=FLOAT(I-1)*YTOP/10. + Y=FLOAT(I-1)*YTOP/nstep + CALL JUMP TO (0.,Y) + CALL LINE TO (.15,Y) + CALL JUMP TO (END-.15,Y) + CALL LINE TO (END,Y) + 12 CONTINUE + IF(IFLOG.EQ.1)GO TO 14 + ITWO=1 + IF(YTOP.LT.1.99)ITWO=2 + if(nstep.eq.2)itwo=1 + IF(IFNOAX.EQ.-1)THEN +C DO 613 I=1,10,ITWO +C Y=FLOAT(I-1)*YTOP/10. +C R=(RMAX-RMIN)/10.*FLOAT(I-1)+RMIN +C CALL WEIGHT(12) +C ENCODE(6,2994,STRING6)R +C 2994 FORMAT(F2.1) +C CALL STRINGX2(STRING6,-.23,Y) +CC CALL BCDX(1,R,2,6H(F2.1),.15,-.23,Y) +C CALL WEIGHT(1) +C ENCODE(6,2995,STRING6)R +C 2995 FORMAT(F3.2) +C 613 CALL STRINGX2(STRING6,-.6,Y) +CC 613 CALL BCDX(1,R/10.+.9,3,6H(F3.2),.15,-.6,Y) +C CALL WEIGHT(12) +C ENCODE(6,1313,STRING6)RMAX +C CALL STRINGX2(STRING6,-.9,Y-.05) +C CALL WEIGHT(1) + CALL WEIGHT(12) + CALL STRINGX2(' 1@ @ .@ @ @ @ 00',-.88,YTOP*1.) + CALL STRINGX2(' .@ @ @ @ 9',-.88,YTOP*.9) + CALL STRINGX2(' .@ @ @ @ 8',-.88,YTOP*.8) + CALL STRINGX2(' .@ @ @ @ 7',-.88,YTOP*.7) + CALL STRINGX2(' .@ @ @ @ 6',-.88,YTOP*.6) + CALL STRINGX2(' .@ @ @ @ 5',-.88,YTOP*.5) + CALL STRINGX2(' .@ @ @ @ 4',-.88,YTOP*.4) + CALL STRINGX2(' .@ @ @ @ 3',-.88,YTOP*.3) + CALL STRINGX2(' .@ @ @ @ 2',-.88,YTOP*.2) + CALL STRINGX2(' .@ @ @ @ 1',-.88,YTOP*.1) + CALL STRINGX2(' .@ @ @ @ 0',-.88,YTOP*.0) + CALL WEIGHT(1) + CALL STRINGX2(' .@ @ @ @ 99 ',-.88,YTOP*.9) + CALL STRINGX2(' .@ @ @ @ 98 ',-.88,YTOP*.8) + CALL STRINGX2(' .@ @ @ @ 97 ',-.88,YTOP*.7) + CALL STRINGX2(' .@ @ @ @ 96 ',-.88,YTOP*.6) + CALL STRINGX2(' .@ @ @ @ 95 ',-.88,YTOP*.5) + CALL STRINGX2(' .@ @ @ @ 94 ',-.88,YTOP*.4) + CALL STRINGX2(' .@ @ @ @ 93 ',-.88,YTOP*.3) + CALL STRINGX2(' .@ @ @ @ 92 ',-.88,YTOP*.2) + CALL STRINGX2(' .@ @ @ @ 91 ',-.88,YTOP*.1) + CALL STRINGX2(' .@ @ @ @ 90 ',-.88,YTOP*.0) + GO TO 17 + ENDIF +c DO 13 I=1,10,ITWO + DO 13 I=1,nstep,ITWO +c Y=FLOAT(I-1)*YTOP/10. + Y=FLOAT(I-1)*YTOP/nstep +c R=(RMAX-RMIN)/10.*FLOAT(I-1)+RMIN + R=(RMAX-RMIN)/nstep*FLOAT(I-1)+RMIN + CALL WEIGHT(2) + IF(IFNOAX.EQ.1)GO TO 13 +C IF(RMAX-RMIN.GE..5)ENCODE(6,1313,STRING6)R +C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)R + ENCODE(6,1313,STRING6)R + IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)R + IF(I.GT.1)Y=Y-.03 + IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,Y) +c IF(YSCALE.GT..5)CALL STRINGX(STRING6,-.9,Y) + 13 CONTINUE + if(ifsir.eq.-1)go to 1777 + if(ifsir.eq.0)call stringy2('normalized flux',-0.75, + 1 ytop/2-1.) + if(ifsir.eq.-2)call stringy2('normalized flux',-0.4, + 1 ytop/2-1.0) +1777 IF(IFNOAX.EQ.1)GO TO 17 + ENCODE(6,1313,STRING6)RMAX +C IF(RMAX-RMIN.GE..5)ENCODE(6,1313,STRING6)RMAX + 1313 FORMAT(F6.1) +C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)RMAX + IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)RMAX + 1314 FORMAT(F6.2) + IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,YTOP-.08) + IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,YTOP-.16) +c IF(YSCALE.GT..5)CALL STRINGX(STRING6,-.9,YTOP-.16) + GO TO 17 + 14 IF(IFABSO.EQ.1)GO TO 17 + DO 15 I=1,11 + Y=FLOAT(I-1)*YTOP/10. + R=ALOG10(RMAX)-CYCLES+FLOAT(I-1)*CYCLES/10. + IF(IFNOAX.EQ.1)GO TO 15 + ENCODE(6,1314,STRING6)R + CALL STRINGX2(STRING6,-0.9,Y) + 15 CONTINUE + 17 IF(IFGRID.EQ.0)GO TO 20 +C + IF(IFGRID.EQ.1)THEN + IF(XSCALE.LT.1.)GO TO 20 +C PLOT GRID + XGRID=.1 + IF(XSCALE.EQ.4.)XGRID=.08 + IF(XSCALE.EQ.8.)XGRID=.08 + NGRID=END/XGRID + DO 18 I=1,NGRID + X=FLOAT(I)*XGRID + CALL JUMP TO (X,0.) + CALL WEIGHT(1) +C IF(MOD(I,10).EQ.0)CALL WEIGHT(12) +C CALL LINE TO (X,YTOP) + IF(MOD(I,10).EQ.0)CALL LINE TO (X,YTOP) + IF(MOD(I,10).NE.0)CALL DOTLINE(X,0.,X,YTOP,'E0E0'X) + 18 CONTINUE +C DO 1118 I=1,NGRID*2.5 +C X=NGRID/10. +C X=FLOAT(I)/10./2.5 +C CALL JUMP TO (X,0.) +C CALL WEIGHT(1) +C CALL LINE TO (X,-.07) +C 1118 CONTINUE + DO 19 I=1,49 + Y=FLOAT(I)*YTOP/50. + CALL JUMP TO (0.,Y) + CALL WEIGHT(1) +C IF(MOD(I,5).EQ.0)CALL WEIGHT(12) +C CALL LINE TO (END,Y) + IF(MOD(I,5).EQ.0)CALL LINE TO (END,Y) + IF(MOD(I,5).NE.0)CALL DOTLINE(0.,Y,END,Y,'E0E0'X) + 19 CONTINUE + CALL WEIGHT(1) + ENDIF +C + IF(IFGRID.EQ.2)THEN + N=(W2-W1)*10.*10.+.5 + DO 4019 I=1,N + X=FLOAT(I)*XSCALE*.1 + CALL JUMP TO (X,0.15) + CALL LINE TO (X,YTOP-.15) + 4019 CONTINUE + DO 4020 I=1,10 + Y=FLOAT(I)*YTOP*.1 + CALL JUMP TO (0.,Y) + CALL LINE TO (END,Y) + 4020 CONTINUE + ENDIF +C + IF(IFGRID.EQ.3)THEN + DO 4030 I=1,50 + Y=FLOAT(I)*YTOP*.02 + CALL JUMP TO (0.,Y) + CALL LINE TO (END,Y) + 4030 CONTINUE + ENDIF +C + 20 IF(NOCALC.EQ.0)THEN +C IF(IFLOG.EQ.0)CALL STRINGY2('LIN',END+.4,.2) +C IF(IFLOG.EQ.1)CALL STRINGY2('LOG',END+.4,.2) +c IF(IFABSO.EQ.0)CALL STRINGY2('RESIDUAL',END+.4,0.2) +c IF(IFABSO.EQ.0)CALL STRINGY('RESIDUAL',END+.4,0.2) +c IF(IFABSO.EQ.1)CALL STRINGY2('ABSOLUTE',END+.4,0.2) + IF(IFABSO.EQ.1)CALL STRINGY('ABSOLUTE',END+.4,0.2) + ENDIF + IF(IFABSO.EQ.0)GO TO 27 +C FIND MAX AND MIN + HMAX=0. + HMIN=1.E30 + IF(NOCALC.EQ.1)GO TO 270 + REWIND 7 + READ(7) + NSKIP= LOG(W1/WBEGIN)/ LOG(RATIO)-2. +C NSKIP=ALOG(W1/WBEGIN)/ALOG(RATIO)-2. + NSKIP=MAX0(NSKIP,0) + IF(NSKIP.EQ.0)GO TO 221 + DO 220 I=1,NSKIP + 220 READ(7) + 221 N1=NSKIP+1 + WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) + IF(IFOPAC.GT.0)THEN + READ(7) + DO 223 IWL=N1,NWL + READ(7)(ASYNTH(J),J=1,IFOPAC) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 223 + IF(WAVE.GT.W2+.0001)GO TO 24 + HMAX=AMAX1(HMAX,ASYNTH(IFOPAC)) + HMIN=AMIN1(HMIN,ASYNTH(IFOPAC)) + 223 CONTINUE + GO TO 24 + ENDIF +C + DO 23 IWL=N1,NWL + READ(7)(Q2(I),I=1,NMU2) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 23 + IF(WAVE.GT.W2+.0001)GO TO 24 + FREQ=2.997925E17/WAVE + HLAM=Q2(MU)*FREQ/WAVE + IF(Q2(MU).GT.Q2(MUNMU))HLAM=Q2(MUNMU)*FREQ/WAVE + HMAX=AMAX1(HMAX,HLAM) + HMIN=AMIN1(HMIN,HLAM) + IF(IFCONT.EQ.0)GO TO 23 + CONT=Q2(MUNMU)*FREQ/WAVE + HMAX=AMAX1(HMAX,CONT) + HMIN=AMIN1(HMIN,CONT) + 23 CONTINUE +C + 24 WRITE(6,25)HMIN,HMAX + 25 FORMAT(1P2E12.3) + ENCODE(9,3535,STRING9)HMAX +c CALL STRINGY2(STRING9,END+.6,YTOP-1.2) + ENCODE(9,3535,STRING9)HMIN +c CALL STRINGY2(STRING9,END+.6,YTOP-2.8) + 270 CONTINUE + IF(TOP.GT.0.)HMAX=TOP + IF(IFLOG.EQ.0)GO TO 30 + IF(HMAX.EQ.0.)GO TO 30 + HMAXL=ALOG10(HMAX) + N=(HMAXL+CYCLES/10.-.001)/(CYCLES/10.) + HMAXL=FLOAT(N)*CYCLES/10. + IF(TOP.GT.0.)HMAXL=ALOG10(TOP) + HMINL=HMAXL-CYCLES + HMAX=10.**HMAXL + DO 26 I=1,11 + Y=FLOAT(I-1)*YTOP/10. + H=HMINL+FLOAT(I-1)*CYCLES/10. + ENCODE(6,1314,STRING6)H + CALL STRINGX2(STRING6,-0.9,Y) + 26 CONTINUE + GO TO 30 + 27 IF(IFLOG.EQ.0)GO TO 30 + RMAXL=ALOG10(RMAX) + RMINL=RMAXL-CYCLES +C PLOT OBSERVED SPECTRUM +C READS FROM 55 + 30 CALL OBSERV +C READS FROM 56 + CALL OBSERV1 +C READS FROM 57 + CALL OBSERV2 +C READS FROM 60 + IF(IFKPNO.GT.0)CALL OBSKPNO(IFKPNO) +C READS FROM 61 + IF(IFKPK.GT.0)CALL OBSKPK(IFKPK) +C READS FROM 62 + IF(IFSACP.GT.0)CALL OBSSACP(IFSACP) +C READS FROM 63 + IF(IFHAWA.GT.0)CALL OBSHAWA(IFHAWA) +C READS FROM 64 + IF(IFNRL.GT.0)CALL OBSNRL(IFNRL) +C READS FROM 65 + IF(IFPROC.GT.0)CALL OBSPROC(IFPROC) +C READS FROM 66 +C IF(IFSIR.GT.0)CALL OBSSIR(IFSIR) +C READS FROM 67 + IF(IFARC.GT.0)CALL OBSARC(IFARC) +C READS FROM 68 +c IF(IFSUNF.GT.0)CALL OBSSUNF(IFSUNF) +C READS FROM 69 + IF(IFSOIR.GT.0)CALL OBSSOIR(IFSOIR) +C READS FROM 59 + IF(IFHALL.GT.0)CALL OBSHALL(IFHALL) +C READS FROM 58 + IF(IFENGV.GT.0)CALL OBSENGV(IFENGV) +C READS FROM 73 + IF(IFFTS.GT.0)CALL OBSFTS(IFFTS) +C READS FROM 71 AND 72 +C IF(IFFTS2.GT.0)CALL OBSENGV(IFFTS2) + IF(IFFTS2.GT.0)CALL OBSFTS2(IFFTS2) +C READS FROM 74 + IF(IFJUNG.GT.0)CALL OBSJUNG(IFJUNG) + CALL COLOR BLACK + IF(NOCALC.EQ.1)GO TO 50 + IF(COLORCALC.EQ.'RED ')CALL COLOR RED + IF(COLORCALC.EQ.'BLUE ')CALL COLOR BLUE + IF(COLORCALC.EQ.'ROYAL BLUE')CALL COLOR ROYAL BLUE + IF(COLORCALC.EQ.'CYAN ')CALL COLOR CYAN + IF(COLORCALC.EQ.'ORANGE ')CALL COLOR ORANGE + IF(COLORCALC.EQ.'LACQUER RE')CALL COLOR LACQUER RED + IF(COLORCALC.EQ.'GREEN ')CALL COLOR GREEN + IF(COLORCALC.EQ.'YELLOW ')CALL COLOR YELLOW + IF(COLORCALC.EQ.'MAGENTA ')CALL COLOR MAGENTA + IF(COLORCALC.EQ.'BLACK ')CALL COLOR BLACK + IF(COLORCALC.EQ.'GRAY ')CALL COLOR GRAY + IF(COLORCALC.EQ.'LIGHT GRAY')CALL COLOR LIGHT GRAY + IF(COLORCALC.EQ.'DARK GRAY ')CALL COLOR DARK GRAY + IF(COLORCALC.EQ.'BROWN ')CALL COLOR BROWN + IF(COLORCALC.EQ.'CRIMSON ')CALL COLOR CRIMSON + IF(COLORCALC.EQ.'AQUAMARINE')CALL COLOR AQUAMARINE + IF(COLORCALC.EQ.'LIME ')CALL COLOR LIME + IF(COLORCALC.EQ.'FIRE ')CALL COLOR FIRE + IF(COLORCALC.EQ.'YELLOW GRE')CALL COLOR YELLOW GREEN + IF(COLORCALC.EQ.'FOREST GRE')CALL COLOR FOREST GREEN + IF(COLORCALC.EQ.'BRITISH RA')CALL COLOR BRITISH RACING GREEN + IF(COLORCALC.EQ.'EVERGREEN ')CALL COLOR EVERGREEN + IF(COLORCALC.EQ.'MAROON ')CALL COLOR MAROON + IF(COLORCALC.EQ.'PURPLE ')CALL COLOR PURPLE + IF(COLORCALC.EQ.'PUMPKIN ')CALL COLOR PUMPKIN + IF(COLORCALC.EQ.'PLUM ')CALL COLOR PLUM + IF(COLORCALC.EQ.'COCOA ')CALL COLOR COCOA + IF(COLORCALC.EQ.'MULBERRY ')CALL COLOR MULBERRY + IF(IFCONT.EQ.3)GO TO 735 +C PLOT SPECTRUM + REWIND 7 + READ(7) + NSKIP= LOG(W1/WBEGIN)/ LOG(RATIO)-2. +C NSKIP=ALOG(W1/WBEGIN)/ALOG(RATIO)-2. + NSKIP=MAX0(NSKIP,0) + IF(NSKIP.EQ.0)GO TO 231 + DO 230 I=1,NSKIP + 230 READ(7) + 231 N1=NSKIP+1 + ISTART=0 + CALL WEIGHT(1) + IF(IFDLIN.EQ.1)CALL WEIGHT(2) + WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) +C + IF(IFOPAC.GT.0)THEN + READ(7) + DO 233 IWL=N1,NWL + READ(7)(ASYNTH(J),J=1,IFOPAC) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 233 + IF(WAVE.GT.W2+.0001)GO TO 734 + FREQ=2.99792458E17/WAVE + HLAM=MAX(ASYNTH(IFOPAC),1.E-30) + CONT=HMAX + IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN)/(RMAX-RMIN)*YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP + IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* + 1YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP + IF(Y.LT.0.)Y=0. + IF(Y.GT.YTOP)Y=YTOP + X=(WAVE-W1)*10.*XSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 233 CONTINUE + CALL WEIGHT(1) + NSKIP=0 + GO TO 735 + ENDIF +C + XOLD=0. + YOLD=0. + DO 33 IWL=N1,NWL + READ(7)(Q2(I),I=1,NMU2) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 33 + IF(WAVE.GT.W2+.0001)GO TO 34 + FREQ=2.997925E17/WAVE + HLAM=Q2(MU)*FREQ/WAVE + CONT=Q2(MUNMU)*FREQ/WAVE +C KEEPS EMISSION BELOW CONTINUUM +C IF(IFABSO.EQ.0.AND.HLAM.GT.CONT)HLAM=CONT + IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN)/(RMAX-RMIN)*YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP + IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* + 1YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP + X=(WAVE-W1)*10.*XSCALE + XNEW=X + YNEW=Y + IF(Y.LT.0.)YNEW=0. + IF(Y.GT.YTOP)YNEW=YTOP + IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) + IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* + 1(YTOP-YOLD) + IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) + ISTART=1 + if(ifsunf.eq.0)CALL LINE TO (XNEW,YNEW) + if(ifsunf.eq.1)CALL dplot (XNEW,YNEW,2) + XOLD=X + YOLD=Y + 33 CONTINUE + CALL WEIGHT(1) + IF(IFRMAX2.EQ.0)GO TO 732 + 34 IF(IFRMAX2.EQ.0)GO TO 735 +C + XOLD=0. + YOLD=0. + REWIND 7 + READ(7) + IF(NSKIP.EQ.0)GO TO 731 + DO 730 I=1,NSKIP + 730 READ(7) + 731 N1=NSKIP+1 + ISTART=0 + DO 733 IWL=N1,NWL + READ(7)(Q2(I),I=1,NMU2) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 733 + IF(WAVE.GT.W2+.0001)GO TO 734 + FREQ=2.997925E17/WAVE + HLAM=Q2(MU)*FREQ/WAVE + CONT=Q2(MUNMU)*FREQ/WAVE + IF(IFABSO.EQ.0.AND.HLAM.GT.CONT)HLAM=CONT + IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN2)/(RMAX2-RMIN2)* + 1YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP + IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* + 1YTOP + IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP + X=(WAVE-W1)*10.*XSCALE + XNEW=X + YNEW=Y + IF(Y.LT.0.)YNEW=0. + IF(Y.GT.YTOP)YNEW=YTOP + IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) + IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* + 1(YTOP-YOLD) + IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) + ISTART=1 + if(ifsunf.eq.0)CALL LINE TO (XNEW,YNEW) + if(ifsunf.eq.1)CALL dplot (XNEW,YNEW,2) + XOLD=X + YOLD=Y + 733 CONTINUE + 732 CALL WEIGHT(1) + NSKIP=0 + GO TO 735 + 734 NSKIP=NWL-IWL + CALL WEIGHT(1) + 735 CONTINUE +C 35 IF(IFABSO.EQ.0)CALL BCDX(1,CONT,9,8H(1PE9.3),.15,END+.5,YTOP-.05) +C IF(IFABSO.EQ.0)CALL BCDY(1,CONT,9,8H(1PE9.3),.15,-.05,YTOP+.25) +C IF(IFABSO.EQ.1)CALL BCDX(1,HMAX,9,8H(1PE9.3),.15,END+.5,YTOP-.05) +C IF(IFABSO.EQ.1)CALL BCDY(1,HMAX,9,8H(1PE9.3),.15,-.05,YTOP+.25) + IF(IFABSO.EQ.0)ENCODE(9,3535,STRING9)CONT + IF(IFABSO.EQ.1)ENCODE(9,3535,STRING9)HMAX + 3535 FORMAT(1PE9.3) +c CALL STRINGY2(STRING9,END+.4,YTOP-1.2) +cccc CALL STRINGY(STRING9,END+.4,YTOP-1.2) +c CALL STRINGY2(STRING9,-.15,YTOP+.25) + IF(IFABSO.EQ.0)GO TO 50 + IF(IFCONT.EQ.0)GO TO 50 + IF(IFOPAC.GT.0)GO TO 50 +C PLOT CONTINUUM + REWIND 7 + READ(7) + NSKIP= LOG(W1/WBEGIN)/ LOG(RATIO)-2. +C NSKIP=ALOG(W1/WBEGIN)/ALOG(RATIO)-2. + NSKIP=MAX0(NSKIP,0) + IF(NSKIP.EQ.0)GO TO 37 + DO 36 I=1,NSKIP + 36 READ(7) + 37 N1=NSKIP+1 + ISTART=0 + CALL WEIGHT(1) + IF(IFDLIN.EQ.1)CALL WEIGHT(2) + WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) + XOLD=X + YOLD=Y + DO 43 IWL=N1,NWL + READ(7)(Q2(I),I=1,NMU2) + WAVE=WBEGDOP*RATIO**(IWL-1) + IF(WAVE.LT.W1)GO TO 43 + IF(WAVE.GT.W2+.0001)GO TO 44 + FREQ=2.997925E17/WAVE + CONT=Q2(MUNMU)*FREQ/WAVE + IF(IFLOG.EQ.0)Y=CONT/HMAX*YTOP + IF(IFLOG.EQ.1)Y=(ALOG10(CONT)-HMINL)/CYCLES*YTOP + X=(WAVE-W1)*10.*XSCALE + XNEW=X + YNEW=Y + IF(Y.LT.0.)YNEW=0. + IF(Y.GT.YTOP)YNEW=YTOP + IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) + IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* + 1(YTOP-YOLD) + IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) + ISTART=1 + if(ifsunf.eq.0)CALL LINE TO (XNEW,YNEW) + if(ifsunf.eq.1)CALL dplot (XNEW,YNEW,2) + XOLD=X + YOLD=Y + 43 CONTINUE + CALL WEIGHT(1) + NSKIP=0 + GO TO 50 + 44 NSKIP=NWL-IWL + CALL WEIGHT(1) + 50 IF(IFLABL.EQ.0)GO TO 100 + IF(NOCALC.EQ.1)GO TO 336 + PRINT 1111,NWL,NSKIP + 1111 FORMAT(2I10) +C IF(NSKIP.EQ.0)GO TO 336 +C DO 335 I=1,NSKIP +C 335 READ(7) + 336 CONTINUE + REWIND 93 + ILABL=MOD(IFLABL,10) + IF(ILABL.EQ.1)CALL LABEL1 + IF(ILABL.EQ.2)CALL LABEL2 + IF(ILABL.EQ.3)CALL LABEL3 + IF(ILABL.EQ.4)CALL LABEL4 + IF(ILABL.EQ.5)CALL LABEL5 + IF(ILABL.EQ.6)CALL LABEL6 + IF(ILABL.EQ.7)CALL LABEL7(IFOPAC) + IF(ILABL.EQ.8)CALL LABEL8 + IF(ILABL.EQ.9)CALL LABEL9 + 100 CONTINUE + CALL FIN(70) +C CALL ENDTIME + CALL EXIT + END + SUBROUTINE OBSERV + RETURN + END + SUBROUTINE OBSERV1 + RETURN + END + SUBROUTINE OBSERV2 + RETURN + END + SUBROUTINE OBSKPNO(IFKPNO) +C PRELIMINARY KPNO SOLAR ATLAS BY BRAULT AND TESTERMAN + +C IFKPNO=1 NORMAL PLOT WEIGHT 1 +C IFKPNO=2 NORMAL PLOT WEIGHT 12 +C IFKPNO=3 NORMAL PLOT WEIGHT 12 PLUS 10X WEIGHT 1 +C IFKPNO=10+ABOVE PLOT LIMB +C + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + DATA IREAD/0/ + INTEGER*2 ISPECT(500),LAMBDA,NORD,NSET,NREC + IF(IREAD.EQ.1)GO TO 1 + OPEN(UNIT=60,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + IREAD=1 + 1 CONTINUE + IF(IFKPNO.GT.10)GO TO 30 + IF(IFMU.GE.2)GO TO 30 +C CENTER + IF(W1.GT.1080.)RETURN + IF(W2.LT.294.2)RETURN + REWIND 60 + ISTART=0 + CALL WEIGHT(1) + NSKIP=W1*10.-2942. + IF(NSKIP.GT.0)THEN + DO 2 ISKIP=1,NSKIP + 2 READ(60) + ENDIF + IREAD=NSKIP + XSAVE=100000. + XSAVE1=100000. + LAST=0 + 3 READ(60)LAMBDA,NORD,NSET,NREC,ISPECT + IREAD=IREAD+1 + IF(LAMBDA.LE.LAST)GO TO 3 + LAST=LAMBDA + WAVE=FLOAT(LAMBDA)*.1 + ISTART=0 + IF(IFKPNO.GT.1)CALL WEIGHT(12) + DO 14 I=1,500 + W=WAVE+FLOAT(I-1)*.0002 + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 315 + X=(W-W1)*XSCALE*10. + IF(ISPECT(I).GT.11000)ISPECT(I)=0 + S=FLOAT(ISPECT(I))/10000. + S=(S-ZEROOBS)*SCALOBS + Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)THEN + CALL JUMP TO (X,Y) + IF(XSAVE.LT.X)CALL JUMP TO (XSAVE,YSAVE) + ENDIF + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + XSAVE=X + YSAVE=Y + 315 ISTART=0 + IF(IFKPNO.LT.3.)GO TO 333 + CALL WEIGHT(1) + DO 324 I=1,500 + W=WAVE+FLOAT(I-1)*.0002 + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.W1)GO TO 324 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + XNEW=X + S=FLOAT(ISPECT(I))/10000. + S=(S-ZEROOBS)*SCALOBS + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)THEN + CALL JUMP TO (X,Y) + IF(XSAVE1.LT.X)CALL JUMP TO (XSAVE1,YSAVE1) + ENDIF + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 324 CONTINUE + XSAVE1=X + YSAVE1=Y + 333 IF(IREAD.LT.7950)GO TO 3 + 15 CALL WEIGHT(1) + RETURN +C LIMB + 30 IF(W1.GT.973.9)RETURN + IF(W2.LT.367.6)RETURN + REWIND 60 + ISTART=0 + CALL WEIGHT(1) + NSKIP=7950 + DO 21 ISKIP=1,NSKIP + 21 READ(60) + IREAD=NSKIP + NSKIP=W1*10.-3676.-10. + IF(NSKIP.GT.0)THEN + DO 22 ISKIP=1,NSKIP + 22 READ(60) + IREAD=IREAD+NSKIP + ENDIF + LAST=0 + 23 READ(60)LAMBDA,NORD,NSET,NREC,ISPECT + IREAD=IREAD+1 + IF(LAMBDA.LE.LAST)GO TO 23 + IF(LAMBDA.GT.LAST+1)ISTART=0 + LAST=LAMBDA + WAVE=FLOAT(LAMBDA)*.1 + DO 24 I=1,500 + W=WAVE+FLOAT(I-1)*.0002 + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + X=(W-W1)*XSCALE*10. + S=FLOAT(ISPECT(I))/10000. + IF(S.GT.2.)S=0. + S=(S-ZEROOBS)*SCALOBS + Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 24 CONTINUE + IF(IREAD.LT.13997)GO TO 23 + 25 CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSJUNG(IFJUNG) +C JUNGFRAUJOCH SOLAR ATLAS BY DELBOUILLE, ROLAND, AND NEVEN + +C IFJUNG=1 NORMAL PLOT WEIGHT 1 +C IFJUNG=2 NORMAL PLOT WEIGHT 12 +C IFJUNG=3 NORMAL PLOT WEIGHT 12 PLUS 10X WEIGHT 1 +C IFJUNG=4 NORMAL PLOT WEIGHT 12 PLUS 10X WEIGHT 12 +C + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + DATA IREAD/0/ + INTEGER*2 ISPECT(500),LAMBDA,NORD,NSET,NREC + IF(IREAD.EQ.1)GO TO 1 + OPEN(UNIT=74,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + IREAD=1 + 1 CONTINUE +C CENTER + IF(W1.GT.1000.4)RETURN + IF(W2.LT.299.1)RETURN + REWIND 74 + ISTART=0 + CALL WEIGHT(1) + NSKIP=W1*10.-2991. + IF(NSKIP.GT.0)THEN + DO 2 ISKIP=1,NSKIP + 2 READ(74) + ENDIF + IREAD=NSKIP+2990 + XSAVE=100000. + XSAVE1=100000. + LAST=0 + 3 READ(74)ISPECT + IREAD=IREAD+1 + WAVE=IREAD*.1 + ISTART=0 + IF(IFJUNG.GT.1)CALL WEIGHT(12) + DO 14 I=1,500 + W=WAVE+FLOAT(I-1)*.0002 +C REMOVE GRAVITATIONAL RED SHIFT + W=W*(1.D0-0.636D0/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 315 + X=(W-W1)*XSCALE*10. + S=FLOAT(ISPECT(I))/10000. + S=(S-ZEROOBS)*SCALOBS + Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)THEN + CALL JUMP TO (X,Y) + IF(XSAVE.LT.X)CALL JUMP TO (XSAVE,YSAVE) + ENDIF + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + XSAVE=X + YSAVE=Y + 315 ISTART=0 + IF(IFJUNG.LT.3.)GO TO 333 + CALL WEIGHT(1) + IF(IFJUNG.EQ.4)CALL WEIGHT(12) + DO 324 I=1,500 + W=WAVE+FLOAT(I-1)*.0002 +C REMOVE GRAVITATIONAL RED SHIFT + W=W*(1.D0-0.636D0/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.W1)GO TO 324 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + XNEW=X + S=FLOAT(ISPECT(I))/10000. + S=(S-ZEROOBS)*SCALOBS + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)THEN + CALL JUMP TO (X,Y) + IF(XSAVE1.LT.X)CALL JUMP TO (XSAVE1,YSAVE1) + ENDIF + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 324 CONTINUE + XSAVE1=X + YSAVE1=Y + 333 IF(IREAD.LT.10003)GO TO 3 + 15 CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSKPK(IFKPK) +C HARVARD ROCKET SPECTRA KOHL,PARKINSON,KURUCZ + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WI + COMMON /WISI/WI(355707),SI(355707) + DATA IREAD/0/ + IF(IREAD.EQ.0)READ(61)WI,SI + IREAD=1 + ISTART=0 + CALL WEIGHT(2) + IF(IFMU.EQ.2)GO TO 30 +C SCAN 1A + IOFFSET=0 + DO 14 I=1,30047 + W=ABS(WI(I)) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + IF(W.GT.255.)GO TO 14 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 ISTART=0 +C SCAN 1B + IOFFSET=30047 + DO 16 I=1,61500 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 16 + IF(W.GT.W2)GO TO 17 + IF(W.LT.255.)GO TO 16 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 16 CONTINUE + 17 ISTART=0 +C SCAN 2A + IOFFSET=IOFFSET+61500 + DO 24 I=1,29172 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + IF(W.GT.255.)GO TO 24 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 24 CONTINUE + 25 ISTART=0 +C SCAN 2B + IOFFSET=IOFFSET+29172 + DO 26 I=1,60572 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 26 + IF(W.GT.W2)GO TO 27 + IF(W.LT.255.)GO TO 26 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 26 CONTINUE + 27 CALL WEIGHT(1) + RETURN + 30 IOFFSET=181291 + ISTART=0 +C SCAN 3A + DO 34 I=1,28687 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 34 + IF(W.GT.W2)GO TO 35 + IF(W.GT.255.)GO TO 34 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 34 CONTINUE + 35 ISTART=0 +C SCAN 3B + IOFFSET=IOFFSET+28687 + DO 36 I=1,58100 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 36 + IF(W.GT.W2)GO TO 37 + IF(W.LT.255.)GO TO 36 + IF(W.GT.306.2)GO TO 36 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 36 CONTINUE + 37 ISTART=0 +C SCAN 4A + IOFFSET=IOFFSET+58100 + DO 44 I=1,29112 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 44 + IF(W.GT.W2)GO TO 45 + IF(W.GT.255.)GO TO 44 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 44 CONTINUE + 45 ISTART=0 +C SCAN 4B + IOFFSET=IOFFSET+29112 + DO 46 I=1,60517 + W=ABS(WI(I+IOFFSET)) + IF(W.LT.W1)GO TO 46 + IF(W.GT.W2)GO TO 47 + IF(W.LT.255.)GO TO 46 + IF(W.GT.312.0)GO TO 46 + X=(W-W1)*XSCALE*10. + S=ABS(SI(I+IOFFSET)) + Y=S/HMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 46 CONTINUE + 47 CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSSACP(IFSACP) +C SAC PEAK SOLAR ATLAS BY BECKERS, BRIDGES, AND GILLIAM + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + INTEGER*2 ISPECT(200),LAMBDA,NORM1,NORM2,IS + COMMON /WISI/IS(640000) + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 2 + OPEN(UNIT=62,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + IW=0 + DO 1 IREC=1,3200 + READ(62)ISPECT,LAMBDA,NORM1,NORM2 + DO 1 I=1,200 + IW=IW+1 + 1 IS(IW)=ISPECT(I) + IREAD=1 + CLOSE(UNIT=62) + 2 IF(W1.GE.700.)RETURN + IF(W2.LT.380.)RETURN + I1=(W1-380.)*2000.+1. + I2=(W2-380.)*2000.+1. + I1=MAX0(I1,0) + I2=MIN0(I2,640000) + ISTART=0 + CALL WEIGHT(2) + DO 14 I=I1,I2 + W=380.+FLOAT(I-1)*.0005 + X=(W-W1)*XSCALE*10. + Y=(FLOAT(IS(I))/900.-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSHAWA(IFHAWA) +C HAWAII ROCKET SPECTRA ALLEN, MCALLISTER, AND JEFFRIES +C IFHAWA=1 WEIGHT=2 +C IFHAWA=2 WEIGHT=1 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W +C THE DATA ARE REREAD EACH TIME TO SAVE STORAGE AND ALLOW PLOTTING +C WITH OTHER ATLASES + IF(W2.LT.268.)RETURN + IF(W1.GE.293.)RETURN + OPEN(UNIT=63,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + SMAX=4.E7 + ISTART=0 + CALL WEIGHT(2) + IF(IFHAWA.EQ.2)CALL WEIGHT(1) + I1=(W1-268.)*2000.+1. + I2=(W2-268.)*2000.+1. + I1=MAX0(I1,1) + I2=MIN0(I2,50000) + IF(I1.GT.0)THEN + NSKIP=I1-1 + DO 13 ISKIP=1,NSKIP + 13 READ(63) + ENDIF + DO 14 I=I1,I2 + W=268.+FLOAT(I-1)*.0005 + X=(W-W1)*XSCALE*10. + READ(63)S + Y=S/SMAX*3.125*YSCALE + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + CALL WEIGHT(1) + CLOSE(UNIT=63) + RETURN + END + SUBROUTINE OBSNRL(IFNRL) + RETURN + END + SUBROUTINE OBSPROC(IFPROC) + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W + COMMON /WISI/SI(866000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=65,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + READ(65)SI + 9 CONTINUE + IF(W2.LT.314.)RETURN + IF(W1.GT.747.)RETURN + CALL WEIGHT(2) + ISTART=0 + I1=(W1-314.)*2000. + I1=MAX0(I1,1) + DO 14 I=I1,866000 + W=FLOAT(I-1)*.0005D0+314.D0 + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + Y=SI(I)/100.*3.125*YSCALE + IF(Y.EQ.0.)THEN + ISTART=0 + GO TO 14 + ENDIF + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSARC(IFARC) + RETURN + END + SUBROUTINE OBSSUNF(IFSUNF) +C PLOTS KURUCZ, FURENLID, BRAULT, AND TESTERMAN SOLAR FLUX ATLAS +C IFSUNF=1 WEIGHT=2 +C IFSUNF=2 WEIGHT=1 +C IFSUNF=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFSUNF=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFSUNF=5 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=2 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W,WCUT + DIMENSION WCUT(7) +CCRAY COMMON /WISI/WI(100000),SI(100000) +C COMMON /WISI/WI(450000),SI(450000) + COMMON /WISI/WI(400000),SI(400000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DATA WCUT/329.897,378.2914,401.965,473.8,576.5,753.9,999.7/ + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=68,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + NIN=0 + DO 4 I=1,1137795 +C W IS THE SOLAR AIR WAVELENGTH INCLUDING THE GRAVITATIONAL REDSHIFT +C S IS THE PSEUDO-RESIDUAL FLUX + READ(68,END=5)W,S +C REMOVE GRAVITATIONAL RED SHIFT + W=W*(1.D0-0.636D0/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 +CCRAY IF(NIN.GT.100000)CALL ABORT + IF(NIN.GT.450000)CALL ABORT + WI(NIN)=W + SI(NIN)=(S-ZEROOBS)*SCALOBS + 4 CONTINUE + 5 CONTINUE + 9 IF(NIN.EQ.0)RETURN + CALL WEIGHT(2) + IF(IFSUNF.EQ.2.OR.IFSUNF.EQ.12)CALL WEIGHT(1) + ISTART=0 + DO 14 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CONTINUE + CALL WEIGHT(1) + IF(IFSUNF.LT.3)RETURN + IF(IFSUNF.EQ.5)CALL WEIGHT(2) + ISTART=0 + DO 24 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + X=(W-W1)*XSCALE*10. + XNEW=X + S=SI(I) + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 24 CONTINUE + 25 CONTINUE + RETURN + END + SUBROUTINE OBSSOIR(IFSOIR) +C PLOTS DELBOUILLE, ROLAND, BRAULT, AND TESTERMAN INFRARED SOLAR ATLAS +C IFSOIR=1 WEIGHT=2 +C IFSOIR=2 WEIGHT=1 +C IFSOIR=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFSOIR=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFSOIR=5 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=2 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W,WCUT + DIMENSION WCUT(8) + COMMON /WISI/WI(450000),SI(450000) +C COMMON /WISI/WI(400000),SI(400000) +CCRAY COMMON /WISI/WI(300000) + DATA WCUT/8*0./ + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=69,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + NIN=0 + DO 4 I=1,2037512 +C W IS THE SOLAR AIR WAVELENGTH INCLUDING THE GRAVITATIONAL REDSHIFT +C S IS THE PSEUDO-RESIDUAL INTENSITY + READ(69,END=5)W,S +C REMOVE GRAVITATIONAL RED SHIFT + W=W*(1.D0-0.636D0/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + IF(NIN.GT.450000)CALL ABORT +CCRAY IF(NIN.GT.300000)CALL ABORT +CCRAY IW=(W-WNEW1)*100000. +CCRAY S=AMIN1(AMAX1(S,0.),.999999) +CCRAY WI(NIN)=FLOAT(IW)+S + WI(NIN)=W +C SI(NIN)=S + SI(NIN)=(S-ZEROOBS)*SCALOBS + 4 CONTINUE + 5 CONTINUE + 9 IF(NIN.EQ.0)RETURN + CALL WEIGHT(2) + IF(IFSOIR.EQ.2.OR.IFSOIR.EQ.4)CALL WEIGHT(1) + ISTART=0 + DO 14 I=1,NIN + W=WI(I) +CCRAY IW=WI(I) +CCRAY W=WNEW1+FLOAT(IW)*.00001 + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. +CCRAY S=WI(I)-FLOAT(IW) +CCRAY Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CONTINUE + CALL WEIGHT(1) + IF(IFSOIR.EQ.5)CALL WEIGHT(2) + IF(IFSOIR.LE.2)RETURN + ISTART=0 + DO 24 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + X=(W-W1)*XSCALE*10. + XNEW=X + S=SI(I) + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 24 CONTINUE + 25 CONTINUE + CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSHALL(IFHALL) +C PLOTS HALL INFRARED SUNSPOT ATLAS +C IFHALL=1 SPOT +C IFHALL=2 DISK +C IFHALL=3 RATIO SPOT/DISK + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W + INTEGER*2 IDISK,ISPOT,IRATIO +CCRAY COMMON /WISI/WI(100000),SI(100000) + COMMON /WISI/WI(386000),SI(386000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=59,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') + NIN=0 + DO 4 I=1,386000 + READ(59,END=5)W,IDISK,ISPOT,IRATIO + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + WI(NIN)=W + IF(IFHALL.EQ.1)THEN + SI(NIN)=(FLOAT(ISPOT)*.0001-ZEROOBS)*SCALOBS + GO TO 4 + ELSE IF(IFHALL.EQ.2)THEN + SI(NIN)=(FLOAT(IDISK)*.0001-ZEROOBS)*SCALOBS + GO TO 4 + ELSE IF(IFHALL.EQ.3)THEN + SI(NIN)=FLOAT(IRATIO)*.0001 + IF(IDISK.GT.0)SI(NIN)=FLOAT(ISPOT)/FLOAT(IDISK) + ELSE + CALL ABORT + ENDIF +CCRAY IF(NIN.GT.100000)CALL ABORT + 4 CONTINUE + 5 CONTINUE + 9 IF(NIN.EQ.0)RETURN + CALL WEIGHT(2) + ISTART=0 + DO 14 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE +C Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CONTINUE + CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSENGV(IFENGV) +C PLOTS ENGVOLD SUNSPOT ATLAS +C IFENGV=1 SPOT BLUE MU=.90 +C IFENGV=2 DISK BLUE MU=.90 +C IFENGV=3 RATIO SPOT/DISK BLUE +C IFENGV=4 SPOT RED MU=.94 +C IFENGV=5 DISK RED MU=.94 +C IFENGV=6 RATIO SPOT/DISK RED +C ALL ABOVE HAVE WEIGHT=1 +C IFENGV +10 SAME AS ABOVE BUT WEIGHT=2 +C IFENGV +20 SAME AS ABOVE BUT ALSO PLOTS 10X TIMES YSCALE +C IFENGV +30 SAME AS ABOVE BUT WEIGHT=2 AND ALSO PLOTS 10X TIMES YSCALE + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W,DOPRATIO +CCRAY COMMON /WISI/WI(100000),SS(110000) + COMMON /WISI/WI(400000),SS(410000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DIMENSION SI(400000) + EQUIVALENCE (SI(1),SS(10001)) + DIMENSION WTSMOO(10000) + REAL*8 WAVESTD(66) + DATA WAVESTD/ + 1 775.06585, 775.11146, 775.52666, 776.06611, 776.46590, 777.19615, + 2 777.41790, 777.53998, 778.05662, 778.89450, 779.75891, 779.92034, + 3 780.24764, 780.79131, 781.08178, 781.11496, 782.08077, 782.67650, + 4 783.22071, 783.26518, 783.53055, 783.61275, 783.96605, 784.45597, + 5 784.52997, 784.62974, 784.65223, 784.99732, + 6 530.04003, 530.07511, 530.10445, 530.13139, 530.18653, 530.23074, + 7 530.32257, 530.35452, 530.38423, 530.41823, 530.45604, 530.58647, + 8 530.73673, 530.84250, 530.86808, 530.89032, 531.02218, 531.04653, + 9 531.06919, 531.14506, 531.16311, 531.26480, 531.28574, 531.32391, + A 531.35829, 531.49199, 531.50738, 531.57749, 531.66172, 531.67823, + 1 531.75354, 531.83531, 531.87702, 531.90323, 531.92134, 531.93055, + 2 531.98171, 531.98203/ + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=58,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') +C CONVERT TO SOLAR FROM TERRESTRIAL + DOPSHIFT=-.734 + NIN=0 + NTOT=341914 + IFENG=MOD(IFENGV,10) + IF(IFENG.GT.3)THEN +C CONVERT TO SOLAR FROM TERRESTRIAL + DOPSHIFT=-.884 + DO 1 I=1,341914 + 1 READ(58) + NTOT=507261 + ENDIF + DOPRATIO=1.D0+DOPSHIFT/299792.458D0 + DOPRATIO=DOPRATIO*(1.D0+DOPOBS/299792.458D0) + IF(IFENG.EQ.1.OR.IFENG.EQ.4)THEN + DO 4 I=1,NTOT + READ(58)W,SPOT + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + SI(NIN)=SPOT + WI(NIN)=W*DOPRATIO +CCRAY IF(NIN.GT.100000)CALL ABORT + 4 CONTINUE + ELSE IF(IFENG.EQ.2.OR.IFENG.EQ.5)THEN + DO 14 I=1,NTOT + READ(58)W,SPOT,DISK + IF(W.LT.WNEW1)GO TO 14 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + SI(NIN)=DISK + WI(NIN)=W*DOPRATIO +CCRAY IF(NIN.GT.100000)CALL ABORT + 14 CONTINUE + ELSE IF(IFENG.EQ.3.OR.IFENG.EQ.6)THEN + DO 24 I=1,NTOT + READ(58)W,SPOT,DISK + IF(W.LT.WNEW1)GO TO 24 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + RATIO=1. + IF(DISK.GT..01.AND.SPOT.GT..01)RATIO=SPOT/DISK + IF(RATIO.GT.2.)RATIO=2. + SI(NIN)=RATIO + WI(NIN)=W*DOPRATIO +CCRAY IF(NIN.GT.100000)CALL ABORT + 24 CONTINUE + ELSE + CALL ABORT + ENDIF + 5 CONTINUE + 9 IF(NIN.EQ.0)RETURN + IF(SMOOTH.GT.0.)THEN + NWT=3.*SMOOTH + NWT2=NWT*2+1 + SUMWT=1. + DO 333 I=1,NWT + WTSMOO(I)=EXP(-(2.*FLOAT(I)/SMOOTH*SQRT(ALOG(2.)))**2) + 333 SUMWT=SUMWT+WTSMOO(I)*2. + WTSMOO(NWT+1)=1./SUMWT + DO 334 I=1,NWT + 334 WTSMOO(NWT+1+I)=WTSMOO(I)/SUMWT + DO 335 I=1,NWT + 335 WTSMOO(I)=WTSMOO(NWT2+1-I) + DO 3330 I=1,NWT2 + 3330 PRINT 3333,I,WTSMOO(I) + 3333 FORMAT(I10,F10.7) + DO 337 I=1,NIN + I1=MAX0(I-NWT,1) + I2=MIN0(I+NWT,NIN) + SS(I)=0. + INWT1=I-NWT-1 + DO 336 II=I1,I2 + 336 SS(I)=SS(I)+WTSMOO(II-INWT1)*SI(II) + 337 CONTINUE + DO 338 I=1,NIN + NINI=NIN+1-I + 338 SI(NINI)=SS(NINI) + ENDIF + CALL WEIGHT(1) + IF(IFENGV.GE.10.AND.IFENGV.LE.19)CALL WEIGHT(2) + IF(IFENGV.GE.30.AND.IFENGV.LE.39)CALL WEIGHT(2) + ISTART=0 + DO 54 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 54 + IF(W.GT.W2)GO TO 55 + X=(W-W1)*XSCALE*10. + S=SI(I) + S=(S-ZEROOBS)*SCALOBS + Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE +C Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE +C Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 54 CONTINUE + 55 CONTINUE + CALL WEIGHT(1) + IF(IFENGV.LT.20)RETURN + ISTART=0 + DO 124 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 124 + IF(W.GT.W2)GO TO 125 + X=(W-W1)*XSCALE*10. + XNEW=X + S=SI(I) + S=(S-ZEROOBS)*SCALOBS + Y=(S-RMIN)/(RMAX-RMIN)*3.125*YSCALE + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 124 CONTINUE + 125 CONTINUE +C DO 850 ISTD=1,66 +C W=WAVESTD(ISTD) +C IF(W.LT.W1)GO TO 850 +C IF(W.GT.W2)GO TO 850 +C X=(W-W1)*XSCALE*10. +C CALL JUMP TO (X,0) +C CALL LINE TO (X,YTOP) +C 850 CONTINUE + RETURN + END + SUBROUTINE OBSFTS(IFFTS) +C PLOTS A SPECTRUM FROM THE FTS AT KITT PEAK +C IFFTS=1 WEIGHT=2 +C IFFTS=2 WEIGHT=1 +C IFFTS=11 PLOT TWICE, NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFFTS=12 PLOT TWICE, NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFFTS=21 PLOT TWICE, NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=2 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W +C COMMON /WISI/WI(400000),SI(400000) + COMMON /WISI/WI(400000),SS(410000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DIMENSION SI(400000) + EQUIVALENCE (SI(1),SS(10001)) + DIMENSION WTSMOO(10000) + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=73,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED', + 1BLOCKSIZE=12000,RECORDSIZE=3,RECORDTYPE='FIXED') + READ(73)WFTS1,WFTS2,NFTS + NIN=0 + DO 4 I=1,NFTS +C W IS THE AIR WAVELENGTH +C IF IT IS A SOLAR SPECTRUM W INCLUDES THE GRAVITATIONAL REDSHIFT +C S IS THE PSEUDO-RESIDUAL FLUX OR INTENSITY + READ(73)W,S +C REMOVE GRAVITATIONAL RED SHIFT +C W=W*(1.D0-0.636/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + IF(NIN.GT.450000)CALL ABORT + WI(NIN)=W + SCALOB=(W-WNEW1)/(WNEW2-WNEW1)*(SCALOB2-SCALOBS)+SCALOBS + SI(NIN)=(S-ZEROOBS)*SCALOB + 4 CONTINUE + 5 CONTINUE +C + IF(SMOOTH.EQ.0.)GO TO 9 + IF(SMOOTH.GT.0.)THEN + NWT=3.*SMOOTH + NWT2=NWT*2+1 + SUMWT=1. + DO 333 I=1,NWT + WTSMOO(I)=EXP(-(2.*FLOAT(I)/SMOOTH*SQRT(ALOG(2.)))**2) + 333 SUMWT=SUMWT+WTSMOO(I)*2. + WTSMOO(NWT+1)=1./SUMWT + DO 334 I=1,NWT + 334 WTSMOO(NWT+1+I)=WTSMOO(I)/SUMWT + DO 335 I=1,NWT + 335 WTSMOO(I)=WTSMOO(NWT2+1-I) + ELSE + NWT=1 + NWT2=3 + WTSMOO(2)=ABS(SMOOTH) + WTSMOO(1)=(1.-WTSMOO(2))*.5 + WTSMOO(3)=WTSMOO(1) + ENDIF + DO 3330 I=1,NWT2 + 3330 PRINT 3333,I,WTSMOO(I) + 3333 FORMAT(I10,F10.7) + DO 337 I=1,NIN + I1=MAX0(I-NWT,1) + I2=MIN0(I+NWT,NIN) + SS(I)=0. + INWT1=I-NWT-1 + DO 336 II=I1,I2 + 336 SS(I)=SS(I)+WTSMOO(II-INWT1)*SI(II) + 337 CONTINUE + DO 338 I=1,NIN + NINI=NIN+1-I + 338 SI(NINI)=SS(NINI) +C + 9 IF(NIN.EQ.0)RETURN + CALL WEIGHT(2) + IF(IFFTS.EQ.2.OR.IFFTS.EQ.12)CALL WEIGHT(1) + ISTART=0 + DO 14 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE +C Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CONTINUE + CALL WEIGHT(1) + IF(IFFTS.EQ.21)CALL WEIGHT(2) + IF(IFFTS.LT.3)RETURN + ISTART=0 + DO 24 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + X=(W-W1)*XSCALE*10. + XNEW=X + S=SI(I) + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 24 CONTINUE + 25 CONTINUE + CALL WEIGHT(1) + RETURN + END + SUBROUTINE OBSFTS2(IFFTS2) +C PLOTS THE RATIO OF TWO SPECTRA FROM THE FTS AT KITT PEAK +C IFFTS=1 WEIGHT=2 +C IFFTS=2 WEIGHT=1 +C IFFTS=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 +C IFFTS=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 WI,W +C COMMON /WISI/WI(450000),SI(450000) + COMMON /WISI/WI(400000),SI(400000) +C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 9 + IREAD=1 + OPEN(UNIT=71,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED', + 1BLOCKSIZE=12000,RECORDSIZE=3,RECORDTYPE='FIXED') + OPEN(UNIT=72,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED', + 1BLOCKSIZE=12000,RECORDSIZE=3,RECORDTYPE='FIXED') + READ(71)W,NFTS + READ(72)W,NFTS + NIN=0 + DO 4 I=1,NFTS +C W IS THE AIR WAVELENGTH +C IF IT IS A SOLAR SPECTRUM W INCLUDES THE GRAVITATIONAL REDSHIFT +C S IS THE PSEUDO-RESIDUAL FLUX OR INTENSITY + READ(71)W,S1 + READ(72)W,S2 +C REMOVE GRAVITATIONAL RED SHIFT +C W=W*(1.D0-0.636/299792.458D0) + W=W*(1.D0+DOPOBS/299792.458D0) + IF(W.LT.WNEW1)GO TO 4 + IF(W.GT.WNEW2)GO TO 5 + NIN=NIN+1 + IF(NIN.GT.450000)CALL ABORT + WI(NIN)=W + S2=S2-ZEROOBS + S1=S1-ZEROOBS + SI(NIN)=1. + IF(S1.GT.0.)SI(NIN)=S2/S1 + SI(NIN)=SI(NIN)*SCALOBS + 4 CONTINUE + 5 CONTINUE + 9 IF(NIN.EQ.0)RETURN + CALL WEIGHT(2) + IF(IFFTS.EQ.2.OR.IFFTS.EQ.12)CALL WEIGHT(1) + ISTART=0 + DO 14 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 14 + IF(W.GT.W2)GO TO 15 + X=(W-W1)*XSCALE*10. + Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE +C Y=AMAX1(Y,0.) + IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + CALL LINE TO (X,Y) + 14 CONTINUE + 15 CONTINUE + CALL WEIGHT(1) + IF(IFFTS.LT.3)RETURN + ISTART=0 + DO 24 I=1,NIN + W=WI(I) + IF(W.LT.W1)GO TO 24 + IF(W.GT.W2)GO TO 25 + X=(W-W1)*XSCALE*10. + XNEW=X + S=SI(I) + Y=(S-.9)/(1.0-.9)*3.125*YSCALE + YNEW=Y + IF(ISTART.EQ.0)THEN + IF(Y.LT.0.)Y=0. + GO TO 240 + ENDIF + IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 + Y=0. + IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 + IF(YOLD.LE.0.)GO TO 239 + X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) + GO TO 240 + 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW + 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) + ISTART=1 + XOLD=XNEW + YOLD=YNEW + CALL LINE TO (X,Y) + 24 CONTINUE + 25 CONTINUE + RETURN + END + SUBROUTINE LABEL1 +C LABELS COMPUTED SPECTRUM +C IFLABL=1 25/INCH TWO ROWS, ATMOSPHERIC LINES HAVE PARTIAL LABELS +C IFLABL=11 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE PARTIAL LABELS +C IFLABL=21 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE FULL LABELS +C IFLABL=31 12.5/INCH LOWER ROW ATOMS UPPER ROW MOLECULES + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG + COMMON /CELL/MAXCEL,IFCELL(40000,2) + REAL*8 Q2(40) + INTEGER VLO,VUP + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 + DIMENSION NAMEAF(999),MOLAF(999) + REAL*8 NAME,NAMEAF + CHARACTER*21 STRING21 + CHARACTER*25 STRING25 + CHARACTER*30 STRING30 + CHARACTER*1 COLON + CHARACTER*38 LABAF,L38 + CHARACTER*34 L34 + CHARACTER*53 STRING53 + CHARACTER*10 LABEL10,LABEL10P + CALL NAMEMOL(NAMEAF,MOLAF) +C CELLIN=12.5 + CELLIN=8. +C IF(IFLABL.EQ.1)CELLIN=25. + IF(IFLABL.EQ.1)CELLIN=16. + MAXCEL=40000 + DO 333 I=1,MAXCEL + IFCELL(I,2)=0 + 333 IFCELL(I,1)=0 + READ(93)NLINES + PRINT 334,NLINES,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NLINES + READ(93)LINDAT8,LINDAT + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + WAVEI=WAVEL + IF(REF.EQ.4HAFGL)THEN + VDOP=GS + WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) + ENDIF + WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC + CENTER=CENTER*FREQ/WLVAC + CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + 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, + 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) + IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 +cc IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. +cc 1RESID.GT..800)GO TO 70 +cc IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. +cc 1RESID.GT..030)GO TO 70 +cc IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. +cc 1RESID.GT..100)GO TO 70 + if(iso1.gt.0.and.iso2.eq.0)go to 70 + IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 61 CONTINUE + MROW=1 + IF(CODE.GT.100.AND.IFLABL.EQ.31)MROW=2 + COLON=' ' + IF(WL.LT.0.)COLON=':' + IRESID=RESID*1000.+.5 +C NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 + NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1. + I=NCELL-1 + IF(I.GT.0.AND.IFCELL(NCELL,MROW).EQ.1.AND.IFCELL(I,MROW).EQ.0.AND. + 1IFCELL(NCELL+1,MROW).EQ.1)GO TO 63 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I,MROW).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IFCELL(NCELL,MROW)=1 + XCELL=FLOAT(NCELL)/CELLIN + IF(IFLABL.NE.1)XCELL=XCELL-.04 + YCELL=YTOP+.1 + IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+1.80 +C IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+1.80 + IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+2.40 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEI*10. + RWL=WAVEI-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 70 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 +C + IF(REF.EQ.4HAFGL)THEN + ISOAF=NELION + MOL=MOLAF(ISOAF) + NAME=NAMEAF(ISOAF) + WRITE(STRING21,'(I3,1X,A6,I5,I4,2X)')IWL,NAME,IELO,IRESID + IF(IFLABL.NE.21)GO TO 66 + WRITE(LABAF,'(A8,A2,A8,A2,A8,A2,A8)')LABEL,LABELP,OTHER1,OTHER2(1) +CCCCCCC + I38=2 + L38=LABAF(1:2) + DO 6100 I=3,38 + IF(LABAF(I-2:I).EQ.' ')GO TO 6100 + I38=I38+1 + L38=L38(1:I38-1)//LABAF(I:I) + 6100 CONTINUE + L34=L38(1:34) + GO TO 6800 +C +C +CCCCCCC +C GO TO (6100,6200,6300,6400,6500,6600,6700),MOL +CC H20 +CCSAMPLE FROM AFCRL TAPE +CC2345678901234567890123456789012345678901234567890123456789012345678901234567890 +CC17879.736 0.174E-26.0940 206.301 4 3 1 3 2 2 1 0 4 0 0 0 77 161 1 +CC JUP KAUPKCUP V1UPV2UPV3UP +CC JLO KALOKCLO V1LOV2LOV3LO +CC NEW HITRAN FORMAT +CC 12345678901234567890123456789012345678 +CC 4 3 1 3 2 2 104 000 +CC +CC READ(11,1,END=145)WAVENO,STRENGTH,WIDTH,E1,JUP,KAUP,KCUP,JLO, +CC 1KALO,KCLO,V1UP,V2UP,V3UP,V1LO,V2LO,V3LO,DATE,ISO,MOL +CC 1 FORMAT(F10.3,E10.3,F5.4,F10.3,3I3,1X,3I3,2X,3I2,1X,3I2,A4,I4,I3) +CC 6100 L34=LABAF(1:21)//LABAF(23:23)//LABAF(25:25)//LABAF(27:28)// +CC 1LABAF(30:30)//LABAF(32:32)//LABAF(34:34) +C 6100 L34=LABAF(7:7)//LABAF(1:6)//LABAF(10:16)//LABAF(24:28)// +C 1LABAF(33:36) +C GO TO 6800 +CC CO2 +C 6200 L34=LABAF(3:4)//LABAF(6:6)//LABAF(8:8)//LABAF(10:10)// +C 1LABAF(12:14)//LABAF(19:19)//LABAF(21:21)//LABAF(23:23)// +C 2LABAF(25:25)//LABAF(27:27)//LABAF(29:35) +C GO TO 6800 +CC O3 +C 6300 L34=LABAF(1:21)//LABAF(23:23)//LABAF(25:25)//LABAF(27:28)// +C 1LABAF(30:30)//LABAF(32:32)//LABAF(34:34) +C GO TO 6800 +CC N20 +C 6400 L34=LABAF(3:4)//LABAF(6:6)//LABAF(8:8)//LABAF(10:10)// +C 1LABAF(19:19)//LABAF(21:21)//LABAF(23:23)//LABAF(25:25)// +C 2LABAF(29:34) +C GO TO 6800 +CC CO +C 6500 L34=LABAF(7:8)//'-'//LABAF(16:16)//LABAF(30:34) +C GO TO 6800 +CC CH4 +C 6600 L34=LABAF(1:34) +C GO TO 6800 +CC O2 +CC 12345678901234567890123456789012345678 +CC R15Q16 B2 X0 +CC 6700 L34=LABAF(17:18)//LABAF(8:8)//'-'//LABAF(19:19)//LABAF(16:16)// +CC 1LABAF(28:34)//LABAF(20:25) +C 6700 L34=LABAF(25:28)//'-'//LABAF(35:36)//LABAF(10:16) + 6800 CONTINUE + STRING53=STRING21(1:19)//L34 + CALL STRINGY(STRING53,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,6802)STRING53 + 6802 FORMAT(79X,A53) + GO TO 70 + ENDIF +C + IF(CODE.LT.100.)GO TO 64 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ + WRITE(LABEL10,'(A8,A2)')LABEL + WRITE(LABEL10P,'(A8,A2)')LABELP + READ(LABEL10,'(A1)')AMULT + IF(AMULT.NE.1H3.AND.AMULT.NE.1H1)THEN + READ(LABEL10,'(1X,I2)')VLO + READ(LABEL10P,'(1X,I2)')VUP + ELSE + READ(LABEL10,'(2X,I2)')VLO + READ(LABEL10P,'(2X,I2)')VUP + ENDIF + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,113)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID,IDWL, + 1 IDGFLOG + 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4,SPI4,SPI5) + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 67 + 64 CONTINUE + IF(IFLABL.EQ.31)THEN + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,IDWL,IDGFLOG + 7114 FORMAT(I3,A1,F6.2,I7,I4,SPI4,SPI5) + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 67 + ENDIF + WRITE(STRING21,114)IWL,COLON,CODE,IELO,IRESID + 114 FORMAT(I3,A1,F6.2,I7,I4) + 66 CONTINUE + CALL STRINGY(STRING21,XCELL,YCELL) + 67 CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,65)STRING21 + 65 FORMAT(107X,A21) + IF(NOPRNT.NE.7)GO TO 70 + IF(DWL.EQ.0..AND.DGFLOG.EQ.0..AND.DGAMMAR.EQ.0..AND. + 1DGAMMAS.EQ.0..AND.DGAMMAW.EQ.0.)GO TO 70 + + WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 1CENTER,CONCEN, + 2WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 3DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + WRITE(6,65)STRING21 + 70 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE LABEL2 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG +CCRAY COMMON /CELL/MAXCEL,IFCELL(10000) + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*8 Q2(40) + INTEGER VLO,VUP + REAL*4 WORDS(6) +CCRAY REAL*8 WORDS(3) + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 +CCRAY MAXCEL=10000 + MAXCEL=40000 + cellin=12.5 + if(iflabl.eq.2)cellin=25. + DO 333 I=1,MAXCEL + 333 IFCELL(I)=0 + READ(93)NLINES + PRINT 334,NLINES,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NLINES + READ(93)LINDAT8,LINDAT + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC + CENTER=CENTER*FREQ/WLVAC + CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + 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, + 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) + IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 + IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. + 1RESID.GT..800)GO TO 70 + IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. + 1RESID.GT..030)GO TO 70 + IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. + 1RESID.GT..100)GO TO 70 + IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 61 CONTINUE + COLON=(1H ) + IF(WL.LT.0)COLON=1H: + IRESID=RESID*1000.+.5 +c NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 + ncell=(wavel-w1)*10.*cellin*xscale+1.5 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IF(MOD(NCELL,2).EQ.1)GO TO 6666 + IF(IFCELL(NCELL-1).EQ.0)THEN + NCELL=NCELL-1 + GO TO 6666 + ELSE IF(IFCELL(NCELL+1).EQ.0)THEN + NCELL=NCELL+1 + ENDIF + 6666 CONTINUE + IFCELL(NCELL)=1 +c XCELL=FLOAT(NCELL)*.04 + xcell=float(ncell)/cellin + YCELL=YTOP+.1 +c IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 + if(iflabl.eq.2.and.mod(ncell,2).eq.0)ycell=ytop+1.29 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEL*10. + RWL=WAVEL-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 70 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 + IF(CODE.LT.100.)GO TO 64 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ +C IF(CODE.EQ.106.)THEN + IF(CODE.EQ.999.)THEN + DECODE(8,4445,LABEL)VLO + DECODE(8,4445,LABELP)VUP + 4445 FORMAT(1X,I1) + ELSE IF(CODE.EQ.606..OR.CODE.EQ.106.01)THEN + DECODE(8,4444,LABEL)VLO + DECODE(8,4444,LABELP)VUP + 4444 FORMAT(2X,I2) + ELSE + DECODE(8,4443,LABEL)VLO + DECODE(8,4443,LABELP)VUP + 4443 FORMAT(1X,I2) + ENDIF + ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID + 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4) + GO TO 66 + 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID + 114 FORMAT(I3,A1,F6.2,I7,I4) + 66 IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1)WRITE(6,65)WORDS +C 65 FORMAT(107X,2A8,A5) + 65 FORMAT(107X,5A4,A1) +CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) + CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + 70 CONTINUE + 80 CONTINUE + RETURN + END +C SUBROUTINE LABEL2 +C COMMON /PARAMS/XSCALE, +C 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, +C 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, +C 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, +C 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 +C 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC +C 6 IFVAC,NOPRNT +C REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG +CCRAY COMMON /CELL/MAXCEL,IFCELL(10000) +C COMMON /CELL/MAXCEL,IFCELL(40000) +C REAL*8 Q2(40) +C INTEGER VLO,VUP +C REAL*4 WORDS(6) +CCRAY REAL*8 WORDS(3) +C COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), +C 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, +C 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, +C 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 +C REAL*8 LINDAT8(14) +C REAL*4 LINDAT(28) +C EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) +C REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND +C REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN +C REAL*8 LABEL,LABELP,OTHER1,OTHER2 +CCRAY MAXCEL=10000 +C MAXCEL=40000 +C DO 333 I=1,MAXCEL +C 333 IFCELL(I)=0 +C READ(93)NLINES +C PRINT 334,NLINES,W1,W2 +C 334 FORMAT(I10,2F10.4) +C DO 70 ILINE=1,NLINES +C READ(93)LINDAT8,LINDAT +C WAVEL=WLVAC +C IF(IFVAC.EQ.0)WAVEL=ABS(WL) +C IF(WAVEL.LT.W1)GO TO 70 +C IF(WAVEL.GT.W2)GO TO 70 +C RESID=CENTER/CONCEN +C FREQ=2.997925E17/WLVAC +C CENTER=CENTER*FREQ/WLVAC +C CONCEN=CONCEN*FREQ/WLVAC +C IF(NOPRNT.EQ.0) +C 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, +C 2CENTER,CONCEN, +C 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, +C 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW +C 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X, A8,A2, A8,A2, +C 1F12.4,F9.3,1P2E11.3/ +C 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, +C 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) +C IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 +C IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. +C 1RESID.GT..800)GO TO 70 +C IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. +C 1RESID.GT..030)GO TO 70 +C IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. +C 1RESID.GT..100)GO TO 70 +C IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP +C 61 CONTINUE +C COLON=(1H ) +C IF(WL.LT.0)COLON=1H: +C IRESID=RESID*1000.+.5 +C NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 +C DO 62 I=NCELL,MAXCEL +C IF(IFCELL(I).EQ.0)GO TO 63 +C 62 CONTINUE +C 63 NCELL=I +C IF(MOD(NCELL,2).EQ.1)GO TO 6666 +C IF(IFCELL(NCELL-1).EQ.0)THEN +C NCELL=NCELL-1 +C GO TO 6666 +C ELSE IF(IFCELL(NCELL+1).EQ.0)THEN +C NCELL=NCELL+1 +C ENDIF +C 6666 CONTINUE +C IFCELL(NCELL)=1 +C XCELL=FLOAT(NCELL)*.04 +C YCELL=YTOP+.1 +C IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 +C XWL=(WAVEL-W1)*10.*XSCALE +C IELO=ELO +C I=WAVEL*10. +C RWL=WAVEL-FLOAT(I)*.1 +C IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. +C 1RESID.GT..100)GO TO 70 +C IWL=RWL*10000.+.5 +C IF(IWL.EQ.1000)IWL=0 +C IF(CODE.LT.100.)GO TO 64 +C PQR=1HP +C IF(XJP.GT.XJ)PQR=1HR +C IF(XJP.EQ.XJ)PQR=1HQ +C ICODE=CODE +C J=XJ +C IF(CODE.EQ.106.)THEN +C IF(CODE.EQ.999.)THEN +C DECODE(8,4445,LABEL)VLO +C DECODE(8,4445,LABELP)VUP +C 4445 FORMAT(1X,I1) +C ELSE IF(CODE.EQ.606..OR.CODE.EQ.106.01)THEN +C DECODE(8,4444,LABEL)VLO +C DECODE(8,4444,LABELP)VUP +C 4444 FORMAT(2X,I2) +C ELSE +C DECODE(8,4443,LABEL)VLO +C DECODE(8,4443,LABELP)VUP +C 4443 FORMAT(1X,I2) +C ENDIF +C ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID +C 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4) +C GO TO 66 +C 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID +C 114 FORMAT(I3,A1,F6.2,I7,I4) +C 66 IF(NOPRNT.EQ.2) +C 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, +C 2CENTER,CONCEN, +C 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, +C 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW +C IF(NOPRNT.NE.1)WRITE(6,65)WORDS +C 65 FORMAT(107X,2A8,A5) +C 65 FORMAT(107X,5A4,A1) +CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) +C CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) +C CALL JUMP TO (XWL,-.03) +C CALL LINE TO (XWL,0.) +C CALL JUMP TO (XWL,YTOP) +C CALL LINE TO (XCELL-.04,YTOP+.08) +C 70 CONTINUE +C 80 CONTINUE +C RETURN +C END + SUBROUTINE LABEL3 + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG +CCRAY COMMON /CELL/MAXCEL,IFCELL(10000) + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*8 Q2(40) + INTEGER VLO,VUP +CCRAY REAL*8 WORDS(3) + REAL*4 WORDS(6) + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 +CCRAY MAXCEL=10000 + MAXCEL=40000 + DO 333 I=1,MAXCEL + 333 IFCELL(I)=0 + READ(93)NLINES + PRINT 334,NLINES,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NLINES + READ(93)LINDAT8,LINDAT + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC + CENTER=CENTER*FREQ/WLVAC + CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + 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, + 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) + IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 + IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. + 1RESID.GT..800)GO TO 70 + IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. + 1RESID.GT..030)GO TO 70 + IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. + 1RESID.GT..100)GO TO 70 + IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 61 CONTINUE + COLON=(1H ) + IF(WL.LT.0.)COLON=1H: + IRESID=RESID*1000.+.5 + NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IFCELL(NCELL)=1 + XCELL=FLOAT(NCELL)*.04 + YCELL=YTOP+.1 + IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEL*10. + RWL=WAVEL-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 70 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 + IF(CODE.LT.100.)GO TO 64 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ +C IF(CODE.EQ.106.)THEN + IF(CODE.EQ.999.)THEN + DECODE(8,4445,LABEL)VLO + DECODE(8,4445,LABELP)VUP + 4445 FORMAT(1X,I1) + ELSE IF(CODE.EQ.606..OR.CODE.EQ.106.01)THEN + DECODE(8,4444,LABEL)VLO + DECODE(8,4444,LABELP)VUP + 4444 FORMAT(2X,I2) + ELSE + DECODE(8,4443,LABEL)VLO + DECODE(8,4443,LABELP)VUP + 4443 FORMAT(1X,I2) + ENDIF + ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID + 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4) + GO TO 66 + 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID + 114 FORMAT(I3,A1,F6.2,I7,I4) + 66 IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1)WRITE(6,65)WORDS +C 65 FORMAT(107X,2A8,A5) + 65 FORMAT(107X,5A4,A1) + CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) +CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + 70 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE LABEL4 + RETURN + END + SUBROUTINE LABEL5 +C LABELS ATMOSPHERIC LINES FROM AFCRL LINE LIST +C IFLABL=5 25/INCH TWO ROWS +C IFLABL=15 12.5/INCH ONE ROW + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*4 WORDS(13) +CCRAY REAL*8 WORDS(7) + CHARACTER*38 LABEL,LABELAF + CHARACTER*28 L28 + REAL*8 WAIR,W,E,NAME + COMMON /AFCRL/WAFCRL(25000),EAFCRL(25000),SAFCRL(25000), + 1 LABELAF(25000),MOLAF(25000),ISOAF(25000) + REAL*8 WAFCRL,EAFCRL + REAL*4 SAFCRL + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 332 + IREAD=1 + OPEN(UNIT=76,SHARED,READONLY,TYPE='OLD') + IF(1.E7/17879.736.GT.WNEW2+.1)RETURN + WNEW11=WNEW1-1. + DO 310 ILINE=1,180956 + READ(76,331)W + IF(1.E7/W.GT.WNEW11)GO TO 311 + 310 CONTINUE + RETURN + 311 ILINE=ILINE+1 + NIN=0 + DO 330 I=ILINE,180956 + READ(76,331)W,S,WIDTH,E,LABEL,ISO,MOL + 331 FORMAT(F10.3,E10.3,F5.4,F10.3,A38,I4,I3) + WRITE(6,3331)I,W,S,WIDTH,E,LABEL,ISO,MOL + 3331 FORMAT(I10,F11.3,E10.3,F5.4,F10.3,A38,I4,I3) + WAIR=1.D7/W/ + 1(1.0000834213D0+2406030.D0/(1.30D10-W**2)+15997.D0/(3.89D9-W**2)) + IF(WAIR.LT.WNEW1)GO TO 330 + IF(WAIR.GT.WNEW2)GO TO 332 + NIN=NIN+1 + IF(NIN.GT.25000)CALL ABORT + WAFCRL(NIN)=WAIR + EAFCRL(NIN)=E + SAFCRL(NIN)=ALOG10(S) + LABELAF(NIN)=LABEL + ISOAF(NIN)=ISO + MOLAF(NIN)=MOL + 330 CONTINUE + 332 IF(NIN.EQ.0)RETURN + MAXCEL=40000 + DO 333 I=1,MAXCEL + 333 IFCELL(I)=0 + CELLIN=12.5 + IF(IFLABL.EQ.5)CELLIN=25. + PRINT 334,NIN,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NIN + WAVEL=WAFCRL(ILINE)*(1.D0+DOPTERR/299792.458D0) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + IE=EAFCRL(ILINE) + LABEL=LABELAF(ILINE) + GO TO (100,200,300,400,500,600,700),MOLAF(ILINE) +C H20 + 100 NAME=(6HH2O ) + IF(ISOAF(ILINE).EQ.171)NAME=(6HH2O17 ) + IF(ISOAF(ILINE).EQ.181)NAME=(6HH2O18 ) +C2345678901234567890123456789012345678901234567890123456789012345678901234567890 +C17879.736 0.174E-26.0940 206.301 4 3 1 3 2 2 1 0 4 0 0 0 77 161 1 +C JUP KAUPKCUP V1UPV2UPV3UP +C JLO KALOKCLO V1LOV2LOV3LO +C READ(11,1,END=145)WAVENO,STRENGTH,WIDTH,E1,JUP,KAUP,KCUP,JLO, +C 1KALO,KCLO,V1UP,V2UP,V3UP,V1LO,V2LO,V3LO,DATE,ISO,MOL +C 1 FORMAT(F10.3,E10.3,F5.4,F10.3,3I3,1X,3I3,2X,3I2,1X,3I2,A4,I4,I3) + L28=LABEL(1:21)//LABEL(23:23)//LABEL(25:25)//LABEL(27:28)// + 1LABEL(30:30)//LABEL(32:32)//LABEL(34:34) + GO TO 800 + 200 NAME=(6HCO2 ) + L28=LABEL(3:4)//LABEL(6:6)//LABEL(8:8)//LABEL(10:10)// + 1LABEL(12:14)//LABEL(19:19)//LABEL(21:21)//LABEL(23:23)// + 2LABEL(25:25)//LABEL(27:27)//LABEL(29:35) + IF(ISOAF(ILINE).EQ.626)GO TO 800 + ENCODE(6,201,NAME)ISOAF(ILINE) + 201 FORMAT(3HCO2,I3) + GO TO 800 + 300 NAME=(6HO3 ) + L28=LABEL(1:21)//LABEL(23:23)//LABEL(25:25)//LABEL(27:28)// + 1LABEL(30:30)//LABEL(32:32)//LABEL(34:34) + IF(ISOAF(ILINE).EQ.666)GO TO 800 + ENCODE(6,301,NAME)ISOAF(ILINE) + 301 FORMAT(3HO3 ,I3) + GO TO 800 + 400 NAME=(6HN2O ) + L28=LABEL(3:4)//LABEL(6:6)//LABEL(8:8)//LABEL(10:10)// + 1LABEL(19:19)//LABEL(21:21)//LABEL(23:23)//LABEL(25:25)// + 2LABEL(29:34) + IF(ISOAF(ILINE).EQ.446)GO TO 800 + ENCODE(6,401,NAME)ISOAF(ILINE) + 401 FORMAT(3HN2O,I3) + GO TO 800 + 500 NAME=(6HCO ) + L28=LABEL(7:8)//'-'//LABEL(16:16)//LABEL(30:34) + IF(ISOAF(ILINE).EQ.26)GO TO 800 + IF(ISOAF(ILINE).EQ.27)NAME=(6HCO17 ) + IF(ISOAF(ILINE).EQ.28)NAME=(6HCO18 ) + IF(ISOAF(ILINE).EQ.36)NAME=(6HCO13 ) + GO TO 800 + 600 NAME=(6HCH4 ) +C CANNOT FIT IN WHOLE LABEL. DROP LOWER QUANTUM NUMBERS. + L28=LABEL(1:10)//LABEL(20:34) + IF(ISOAF(ILINE).EQ.211)GO TO 800 + ENCODE(6,601,NAME)ISOAF(ILINE) + 601 FORMAT(3HCH4,I3) + GO TO 800 + 700 NAME=(6HO2 ) + L28=LABEL(17:18)//LABEL(8:8)//'-'//LABEL(19:19)//LABEL(16:16)// + 1LABEL(28:34)//LABEL(20:25) + IF(ISOAF(ILINE).EQ.66)GO TO 800 + IF(ISOAF(ILINE).EQ.67)NAME=(6HO217 ) + IF(ISOAF(ILINE).EQ.68)NAME=(6HO218 ) + 800 CONTINUE + NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I +C IF(MOD(NCELL,2).EQ.1)GO TO 163 +C IF(IFCELL(NCELL-1).EQ.0)THEN +C NCELL=NCELL-1 +C GO TO 163 +C ENDIF +C IF(IFCELL(NCELL+1).EQ.0)NCELL=NCELL+1 + 163 IFCELL(NCELL)=1 + XCELL=FLOAT(NCELL)/CELLIN + IF(IFLABL.NE.5)XCELL=XCELL-.04 + YCELL=YTOP+.1 + IF(IFLABL.EQ.5.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+2.98 + XWL=(WAVEL-W1)*10.*XSCALE + I=WAFCRL(ILINE) + RWL=WAFCRL(ILINE)-FLOAT(I) + IWL=RWL*10000.+.5 + IF(IWL.EQ.10000)IWL=0 + 64 ENCODE(50,114,WORDS)IWL,NAME,IE,SAFCRL(ILINE),L28 + 114 FORMAT(I4,1X,A6,I5,F6.2,A28) + 66 IF(NOPRNT.NE.1)WRITE(6,65)WAVEL,WAFCRL(ILINE),EAFCRL(ILINE),WORDS + 65 FORMAT(F12.4,F10.3,F10.3,2X,12A4,A2) +C 65 FORMAT(F12.4,F10.3,F10.3,2X,6A8,A2) + CALL BCDY(13,WORDS,50,9H(12A4,A2),.07,XCELL,YCELL) +CCRAY CALL BCDY(7,WORDS,50,8H(6A8,A2),.07,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + 70 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE NAMEMOL(MOLNAME,MOLCODE) +C IDENTIFIES ISOTOPE CODES FOR AFCRL LINE LIST + DIMENSION MOLNAME(999),MOLCODE(999) + REAL*8 MOLNAME + DO 1 I=1,999 + MOLNAME(I)=6H + 1 MOLCODE(I)=0 +C H2O + MOLCODE(161)=1 + MOLCODE(162)=1 + MOLCODE(181)=1 + MOLCODE(171)=1 +C CO2 + MOLCODE(626)=2 + MOLCODE(636)=2 + MOLCODE(628)=2 + MOLCODE(627)=2 + MOLCODE(638)=2 + MOLCODE(637)=2 + MOLCODE(828)=2 +C O3 + MOLCODE(666)=3 + MOLCODE(668)=3 + MOLCODE(686)=3 +C N2O + MOLCODE(446)=4 + MOLCODE(456)=4 + MOLCODE(546)=4 + MOLCODE(448)=4 + MOLCODE(447)=4 +C CO + MOLCODE( 26)=5 + MOLCODE( 36)=5 + MOLCODE( 28)=5 + MOLCODE( 27)=5 +C CH4 + MOLCODE(211)=6 + MOLCODE(311)=6 + MOLCODE(212)=6 +C O2 + MOLCODE( 66)=7 + MOLCODE( 68)=7 + MOLCODE( 67)=7 +C +C H2O + MOLNAME(161)=6HH20 + MOLNAME(162)=6HHDO + MOLNAME(181)=6HH2O 18 + MOLNAME(171)=6HH2O 17 +C CO2 + MOLNAME(626)=6HCO2 + MOLNAME(636)=6HCO2 13 + MOLNAME(628)=6HCO2 18 + MOLNAME(627)=6HCO2 17 + MOLNAME(638)=6HCO2 38 + MOLNAME(637)=6HCO2 37 + MOLNAME(828)=6HCO2 88 +C O3 + MOLNAME(666)=6HO3 + MOLNAME(668)=6HO3 668 + MOLNAME(686)=6HO3 686 +C N2O + MOLNAME(446)=6HN2O + MOLNAME(456)=6HN2O456 + MOLNAME(546)=6HN2O546 + MOLNAME(448)=6HN2O 18 + MOLNAME(447)=6HN2O 17 +C CO + MOLNAME( 26)=6HCO + MOLNAME( 36)=6HCO 13 + MOLNAME( 28)=6HCO 18 + MOLNAME( 27)=6HCO 17 +C CH4 + MOLNAME(211)=6HCH4 + MOLNAME(311)=6HCH4 13 + MOLNAME(212)=6HCH3D +C O2 + MOLNAME( 66)=6HO2 + MOLNAME( 68)=6HO2 18 + MOLNAME( 67)=6HO2 17 + MOLNAME( 77)=6HO2 77 + MOLNAME( 78)=6HO2 78 + MOLNAME( 79)=6HO2 88 +C + RETURN + END + SUBROUTINE LABEL6 +C for binary stars +C LABELS COMPUTED SPECTRUM +C IFLABL=1 25/INCH TWO ROWS, ATMOSPHERIC LINES HAVE PARTIAL LABELS +C IFLABL=11 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE PARTIAL LABELS +C IFLABL=21 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE FULL LABELS +C IFLABL=31 12.5/INCH LOWER ROW ATOMS UPPER ROW MOLECULES + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG + COMMON /CELL/MAXCEL,IFCELL(40000,2) + REAL*8 Q2(40) + INTEGER VLO,VUP + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 + DIMENSION NAMEAF(999),MOLAF(999) + REAL*8 NAME,NAMEAF + CHARACTER*21 STRING21 + CHARACTER*25 STRING25 + CHARACTER*30 STRING30 + CHARACTER*1 COLON + CHARACTER*38 LABAF,L38 + CHARACTER*34 L34 + CHARACTER*53 STRING53 + CHARACTER*10 LABEL10,LABEL10P + CALL NAMEMOL(NAMEAF,MOLAF) +C CELLIN=12.5 + CELLIN=8. +C IF(IFLABL.EQ.1)CELLIN=25. + IF(IFLABL.EQ.1)CELLIN=16. + MAXCEL=40000 + DO 333 I=1,MAXCEL + IFCELL(I,2)=0 + 333 IFCELL(I,1)=0 + READ(93)NLINES,NLINES1,NLINES2 +c READ(93)NLINES + PRINT 334,NLINES,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NLINES1 + READ(93)LINDAT8,LINDAT + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + WAVEI=WAVEL + IF(REF.EQ.4HAFGL)THEN + VDOP=GS + WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) + ENDIF + WAVEL=WAVEL*(1.D0+DOPterr/299792.458D0) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC + CENTER=CENTER*FREQ/WLVAC + CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + 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, + 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) + IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 + IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. + 1RESID.GT..800)GO TO 70 + IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. + 1RESID.GT..030)GO TO 70 + IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. + 1RESID.GT..100)GO TO 70 + IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 61 CONTINUE + MROW=1 + IF(CODE.GT.100.AND.IFLABL.EQ.31)MROW=2 + COLON=' ' + IF(WL.LT.0.)COLON=':' + IRESID=RESID*1000.+.5 +C NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 + NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1. + I=NCELL-1 + IF(I.GT.0.AND.IFCELL(NCELL,MROW).EQ.1.AND.IFCELL(I,MROW).EQ.0.AND. + 1IFCELL(NCELL+1,MROW).EQ.1)GO TO 63 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I,MROW).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IFCELL(NCELL,MROW)=1 + XCELL=FLOAT(NCELL)/CELLIN + IF(IFLABL.NE.1)XCELL=XCELL-.04 + YCELL=YTOP+.1 + IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+1.80 +C IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+1.80 + IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+2.40 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEI*10. + RWL=WAVEI-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 70 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 +C + IF(REF.EQ.4HAFGL)THEN + ISOAF=NELION + MOL=MOLAF(ISOAF) + NAME=NAMEAF(ISOAF) + WRITE(STRING21,'(I3,1X,A6,I5,I4,2X)')IWL,NAME,IELO,IRESID + IF(IFLABL.NE.21)GO TO 66 + WRITE(LABAF,'(A8,A2,A8,A2,A8,A2,A8)')LABEL,LABELP,OTHER1,OTHER2(1) +CCCCCCC + I38=2 + L38=LABAF(1:2) + DO 6100 I=3,38 + IF(LABAF(I-2:I).EQ.' ')GO TO 6100 + I38=I38+1 + L38=L38(1:I38-1)//LABAF(I:I) + 6100 CONTINUE + L34=L38(1:34) + GO TO 6800 +C +C +CCCCCCC + 6800 CONTINUE + STRING53=STRING21(1:19)//L34 + CALL STRINGY(STRING53,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,6802)STRING53 + 6802 FORMAT(79X,A53) + GO TO 70 + ENDIF +C + IF(CODE.LT.100.)GO TO 64 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ + WRITE(LABEL10,'(A8,A2)')LABEL + WRITE(LABEL10P,'(A8,A2)')LABELP + READ(LABEL10,'(A1)')AMULT + IF(AMULT.NE.1H3.AND.AMULT.NE.1H1)THEN + READ(LABEL10,'(1X,I2)')VLO + READ(LABEL10P,'(1X,I2)')VUP + ELSE + READ(LABEL10,'(2X,I2)')VLO + READ(LABEL10P,'(2X,I2)')VUP + ENDIF + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,113)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID,IDWL, + 1 IDGFLOG + 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4,SPI4,SPI5) + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 67 + 64 CONTINUE + IF(IFLABL.EQ.31)THEN + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,IDWL,IDGFLOG + 7114 FORMAT(I3,A1,F6.2,I7,I4,SPI4,SPI5) + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 67 + ENDIF + WRITE(STRING21,114)IWL,COLON,CODE,IELO,IRESID + 114 FORMAT(I3,A1,F6.2,I7,I4) + 66 CONTINUE + CALL STRINGY(STRING21,XCELL,YCELL) + 67 CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,65)STRING21 + 65 FORMAT(107X,A21) + IF(NOPRNT.NE.7)GO TO 70 + IF(DWL.EQ.0..AND.DGFLOG.EQ.0..AND.DGAMMAR.EQ.0..AND. + 1DGAMMAS.EQ.0..AND.DGAMMAW.EQ.0.)GO TO 70 + + WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 1CENTER,CONCEN, + 2WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 3DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + WRITE(6,65)STRING21 + 70 CONTINUE + call weight(2) + DO 71 ILINE=1,NLINES2 + READ(93)LINDAT8,LINDAT + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + WAVEI=WAVEL + IF(REF.EQ.4HAFGL)THEN + VDOP=GS + WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) + ENDIF + WAVEL=WAVEL*(1.D0+DOPobs/299792.458D0) + IF(WAVEL.LT.W1)GO TO 71 + IF(WAVEL.GT.W2)GO TO 71 + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC + CENTER=CENTER*FREQ/WLVAC + CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 71 + IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. + 1RESID.GT..800)GO TO 71 + IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. + 1RESID.GT..030)GO TO 71 + IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. + 1RESID.GT..100)GO TO 71 + IF(IFABSO.EQ.0)GO TO 661 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 661 CONTINUE + MROW=1 + IF(CODE.GT.100.AND.IFLABL.EQ.31)MROW=2 + COLON=' ' + IF(WL.LT.0.)COLON=':' + IRESID=RESID*1000.+.5 +C NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 + NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1. + I=NCELL-1 + IF(I.GT.0.AND.IFCELL(NCELL,MROW).EQ.1.AND.IFCELL(I,MROW).EQ.0.AND. + 1IFCELL(NCELL+1,MROW).EQ.1)GO TO 663 + DO 662 I=NCELL,MAXCEL + IF(IFCELL(I,MROW).EQ.0)GO TO 663 + 662 CONTINUE + 663 NCELL=I + IFCELL(NCELL,MROW)=1 + XCELL=FLOAT(NCELL)/CELLIN + IF(IFLABL.NE.1)XCELL=XCELL-.04 + YCELL=YTOP+.1 + IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+1.80 +C IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+1.80 + IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+2.40 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEI*10. + RWL=WAVEI-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 71 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 +C + IF(REF.EQ.4HAFGL)THEN + ISOAF=NELION + MOL=MOLAF(ISOAF) + NAME=NAMEAF(ISOAF) + WRITE(STRING21,'(I3,1X,A6,I5,I4,2X)')IWL,NAME,IELO,IRESID + IF(IFLABL.NE.21)GO TO 666 + WRITE(LABAF,'(A8,A2,A8,A2,A8,A2,A8)')LABEL,LABELP,OTHER1,OTHER2(1) +CCCCCCC + I38=2 + L38=LABAF(1:2) + DO 6101 I=3,38 + IF(LABAF(I-2:I).EQ.' ')GO TO 6101 + I38=I38+1 + L38=L38(1:I38-1)//LABAF(I:I) + 6101 CONTINUE + L34=L38(1:34) + GO TO 6801 +C +C +CCCCCCC + 6801 CONTINUE + STRING53=STRING21(1:19)//L34 + CALL STRINGY(STRING53,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,6802)STRING53 + GO TO 71 + ENDIF +C + IF(CODE.LT.100.)GO TO 664 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ + WRITE(LABEL10,'(A8,A2)')LABEL + WRITE(LABEL10P,'(A8,A2)')LABELP + READ(LABEL10,'(A1)')AMULT + IF(AMULT.NE.1H3.AND.AMULT.NE.1H1)THEN + READ(LABEL10,'(1X,I2)')VLO + READ(LABEL10P,'(1X,I2)')VUP + ELSE + READ(LABEL10,'(2X,I2)')VLO + READ(LABEL10P,'(2X,I2)')VUP + ENDIF + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,113)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID,IDWL, + 1 IDGFLOG + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 667 + 664 CONTINUE + IF(IFLABL.EQ.31)THEN + IDWL=NINT(DWL*10000.) + IDGFLOG=NINT(DGFLOG*1000.) + WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,IDWL,IDGFLOG + CALL STRINGY(STRING30,XCELL,YCELL) + GO TO 667 + ENDIF + WRITE(STRING21,114)IWL,COLON,CODE,IELO,IRESID + 666 CONTINUE + CALL STRINGY(STRING21,XCELL,YCELL) + 667 CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,65)STRING21 + IF(NOPRNT.NE.7)GO TO 71 + IF(DWL.EQ.0..AND.DGFLOG.EQ.0..AND.DGAMMAR.EQ.0..AND. + 1DGAMMAS.EQ.0..AND.DGAMMAW.EQ.0.)GO TO 71 + + WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 1CENTER,CONCEN, + 2WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 3DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + WRITE(6,65)STRING21 + 71 CONTINUE + call weight(1) + 80 CONTINUE + RETURN + END + SUBROUTINE LABEL7(IFOPAC) + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI + REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*8 Q2(40) + REAL*4 ALINEC(64) + INTEGER VLO,VUP + REAL*4 WORDS(6) +CCRAY REAL*8 WORDS(3) + 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 + REAL*8 LINDAT8(14) + REAL*4 LINDAT(28) + EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) + REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND + REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN + REAL*8 LABEL,LABELP,OTHER1,OTHER2 + MAXCEL=40000 + DO 333 I=1,MAXCEL + 333 IFCELL(I)=0 + PRINT 334,W1,W2 + 334 FORMAT(2F10.4) + DO 70 ILINE=1,1000000 + READ(7,END=80)LINDAT8,LINDAT,(ALINEC(J),J=1,IFOPAC) + WAVEL=WLVAC + IF(IFVAC.EQ.0)WAVEL=ABS(WL) + WAVEI=WAVEL + IF(REF.EQ.4HAFGL)THEN + VDOP=GS + WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) + ENDIF + WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + CENTER=ALINEC(IFOPAC) + CONCEN=HMAX + RESID=CENTER/CONCEN + FREQ=2.997925E17/WLVAC +C CENTER=CENTER*FREQ/WLVAC +C CONCEN=CONCEN*FREQ/WLVAC + IF(NOPRNT.EQ.0) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + 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, + 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) +C IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 + IF(RESID.LT.WEAK)GO TO 70 + IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. + 1RESID.GT..800)GO TO 70 + IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. + 1RESID.GT..030)GO TO 70 + IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. + 1RESID.GT..100)GO TO 70 + IF(IFABSO.EQ.0)GO TO 61 +C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP +C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP +C RESID=Y/YTOP + 61 CONTINUE + COLON=(1H ) + IF(WL.LT.0.)COLON=1H: + IRESID=RESID*1000.+.5 + NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IFCELL(NCELL)=1 + XCELL=FLOAT(NCELL)*.04 + YCELL=YTOP+.1 + IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 + XWL=(WAVEL-W1)*10.*XSCALE + IELO=ELO + I=WAVEI*10. + RWL=WAVEI-FLOAT(I)*.1 + IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. + 1RESID.GT..100)GO TO 70 + IWL=RWL*10000.+.5 + IF(IWL.EQ.1000)IWL=0 + IF(CODE.LT.100.)GO TO 64 + PQR=1HP + IF(XJP.GT.XJ)PQR=1HR + IF(XJP.EQ.XJ)PQR=1HQ + ICODE=CODE + J=XJ + IF(REF.EQ.4HAFGL)THEN + DECODE(10,4466,LABELP)VUP,AISO + 4466 FORMAT(1X,I1,7X,A1) + DECODE(4,4465,LABEL)VLO,IF + 4465 FORMAT(1X,I1,I2) + IF(CODE.EQ.808.)ACODE=2HO2 + ENCODE(21,4467,WORDS)IWL,COLON,ACODE,VUP,VLO,J,PQR,IF,IRESID,AISO + 4467 FORMAT(I3,A1,A2,I2,1H-,I1,I3,A1,I1,I4,1X,A1) + GO TO 66 + ENDIF + DECODE(1,4443,LABEL)AMULT + 4443 FORMAT(A1) + IF(AMULT.NE.1H3.AND.AMULT.NE.1H1)THEN + DECODE(3,4445,LABEL)VLO + DECODE(3,4445,LABELP)VUP + 4445 FORMAT(1X,I2) + ELSE + DECODE(3,4444,LABEL)VLO + DECODE(3,4444,LABELP)VUP + 4444 FORMAT(2X,I2) + ENDIF + ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID + 113 FORMAT(I3,A1,I3,I3,1H-,I2,I3,A1,I4) + GO TO 66 + 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID + 114 FORMAT(I3,A1,F6.2,I7,I4) + 66 IF(NOPRNT.EQ.2) + 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, + 2CENTER,CONCEN, + 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, + 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW + IF(NOPRNT.NE.1)WRITE(6,65)WORDS + 65 FORMAT(107X,5A4,A1) +C 65 FORMAT(107X,2A8,A5) + CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) +CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.04,YTOP+.08) + 70 CONTINUE + 80 CONTINUE + RETURN + END + SUBROUTINE LABEL8 + RETURN + END + SUBROUTINE LABEL9 +C PIERCE AND BRECKENRIDGE LINE LIST FOR SOLAR CENTRAL INTENSITY + COMMON /PARAMS/XSCALE, + 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, + 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, + 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, + 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,DUMMY7 + 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC + 6 IFVAC,NOPRNT + REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI + COMMON /CELL/MAXCEL,IFCELL(40000) + REAL*4 WORDS(7) + CHARACTER STRING*26 +CCRAY REAL*8 WORDS(4) + REAL*8 WPIERCE(15000) + REAL*4 LABELPI(4,15000),EWPIERCE(15000),STPIERCE(15000) + DATA IREAD/0/ + IF(IREAD.EQ.1)GO TO 332 + IREAD=1 + OPEN(UNIT=77,SHARED,READONLY,TYPE='OLD') + DO 330 I=1,15000 + READ(77,331,END=329)WPIERCE(I),STPIERCE(I),ISIGMA,WAVENO,NUMBER, + 1DELTAW,NOTE,EWPIERCE(I),(LABELPI(K,I),K=1,4) + 331 FORMAT(F11.4,A1,I3,F11.3,I4,F7.3,A1,F8.1,3A4,A2) + 330 CONTINUE + 329 NPIERCE=I-1 + 332 CONTINUE + CELLIN=8. + MAXCEL=40000 + DO 333 I=1,MAXCEL + 333 IFCELL(I)=0 + PRINT 334,NPIERCE,W1,W2 + 334 FORMAT(I10,2F10.4) + DO 70 ILINE=1,NPIERCE + WAVEL=WPIERCE(ILINE)/10.D0 + WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) + IF(WAVEL.LT.W1)GO TO 70 + IF(WAVEL.GT.W2)GO TO 70 + NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 +C NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 + DO 62 I=NCELL,MAXCEL + IF(IFCELL(I).EQ.0)GO TO 63 + 62 CONTINUE + 63 NCELL=I + IFCELL(NCELL)=1 +C XCELL=FLOAT(NCELL)*.04 +C XCELL=FLOAT(NCELL)*.08 + XCELL=FLOAT(NCELL)/CELLIN-.0625 !*.08-.04 + YCELL=YTOP+.1 +C IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 + XWL=(WAVEL-W1)*10.*XSCALE + I=WPIERCE(ILINE) + RWL=WPIERCE(ILINE)-FLOAT(I) + IWL=RWL*10000.+.5 + IF(IWL.EQ.10000)IWL=0 + 64 WRITE(STRING,114)IWL,STPIERCE(ILINE),EWPIERCE(ILINE), + 1(LABELPI(K,ILINE),K=1,4) + 114 FORMAT(I4,A1,F6.1,1X,3A4,A2) + 66 IF(NOPRNT.NE.1)WRITE(6,65)WPIERCE(ILINE),EWPIERCE(ILINE),WORDS + 65 FORMAT(F12.4,F10.1,3X,6A4,A2) +C 65 FORMAT(F12.4,F10.1,3X,3A8,A2) + CALL STRINGY1(STRING,XCELL,YCELL) +C CALL BCDY(7,WORDS,26,8H(6A4,A2),.07,XCELL,YCELL) +CCRAY CALL BCDY(4,WORDS,26,8H(3A8,A2),.07,XCELL,YCELL) + CALL JUMP TO (XWL,-.03) + CALL LINE TO (XWL,0.) + CALL JUMP TO (XWL,YTOP) + CALL LINE TO (XCELL-.0625,YTOP+.08) !.04 + 70 CONTINUE + 80 CONTINUE + RETURN + END |