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