PROGRAM PLOTSYN C revised 12oct2000 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 IFDLIN=1 SPECTRUM LINES ARE DOUBLE WEIGHT C IFDLIN=0 SPECTRUM LINES ARE 1 WEIGHT C IFDLIN=N SPECTRUM LINES ARE N 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 NOLABY=1 NOTHING IS WRITTEN ALONG THE Y AXIS SO PLOTS CAN BE ABUTTED IN X 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 VALUE 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 AXISWT IS THE LINE WEIGHT FOR THE AXES =1.,2.,3.,12.,OR 23. DEFAULT=1. C -1. MEANS NO AXIS C SCALCALC IF 0 NO SCALING OF CALCULATED SPECTRUM C IF NOT 0 SCALES SPECTRUM COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WAVE,WBEGDOP REAL*8 TITLE(74),XMU(20),WLEDGE(333),TEFF,GLOG REAL*8 WLEDGE200(200) 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) CHARACTER*100 TEXT(100) CHARACTER*60 STRING60 CHARACTER*10 STRINGCOLOR CHARACTER*2 STRING2 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),IDATE(3),ITIME(2), 1JOBID(2) REAL*8 USERID,FILENAME CHARACTER*10 COLOROBS,COLORCALC CHARACTER*9 HEADERDATA(5) CHARACTER*6 WW6,STRING6 CHARACTER*7 WW7,STRING7 CHARACTER*9 STRING9 DATA IFPANL/80*1/ READ(5,1001)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1,NOWAVE, 1NOCALC,NOLABY,IFTEXT,IFOVER 1001 FORMAT(12I8) WRITE(6,1002)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1, 1NOWAVE,NOCALC,NOLABY,IFTEXT,IFOVER 1002 FORMAT(1X,11I8/' IFLABL IFABSO IFCONT IFGRID IFDLIN', 1' IFLOG JUST1 NOWAVE NOCALC NOLABY IFTEXT IFOVER') READ(5,1001) IF(IFTEXT.NE.0)THEN DO 9003 ITEXT=1,100 READ(5,'(A100)')TEXT(ITEXT) IF(TEXT(ITEXT).EQ.' ')GO TO 9004 9003 CONTINUE 9004 NTEXT=ITEXT-1 ENDIF READ(5,1001)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, 1IFPROC,IFSIRUV,IFOBSN WRITE(6,1003)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, 1IFPROC,IFSIRUV,IFOBSN 1003 FORMAT(1X,11I8/' IFNOAX IFMU NOPRNT IFKPNO IFKPK', 1' IFSACP IFHAWA IFNRL IFPROC IFSIRUV IFOBSN') READ(5,1001) READ(5,1001)IFSIRV,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC,IFFTS, 1IFFTS2,IFJUNG WRITE(6,1004)IFSIRV,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC, 1IFFTS,IFFTS2,IFJUNG 1004 FORMAT(1X,10I8/' IFSIRV IFARC IFSUNF IFSOIR IFHALL', 1' IFENGV IFOPAC IFFTS IFFTS2 IFJUNG') READ(5,1001) READ(5,1005)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX, 1 COLOROBS 1005 FORMAT(8F10.3,A10) WRITE(6,1006)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX, 1 COLOROBS 1006 FORMAT(1X,8F10.3,A10/' YSCALE XSCALE WEAK PANEL'// 1' CYCLES OFFSET RMIN RMAX COLOROBS') READ(5,1001) READ(5,1007)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS, 1 DOPCALC,COLORCALC 1007 FORMAT(E10.3,7F10.3,A10) WRITE(6,1008)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS, 1 DOPCALC,COLORCALC 1008 FORMAT(1PE10.3,0P7F10.3,A10/' TOP WNEW1 WNEW2 '// 1'TICKTOP TICKBOT SMOOTH DOPOBS DOPCALC COLORCALC') READ(5,1001) READ(5,1027)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1AXISWT,SCALCALC 1027 FORMAT(F10.3,E10.3,4F10.3,E10.3,F10.3,E10.3) WRITE(6,1028)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1AXISWT,SCALCALC 1028 FORMAT(F10.3,1PE10.3,0P4F10.3,1PE10.3,0PF10.3,0PE10.3/ 1' DOPTERR SCALOBS ZEROOBS RMIN2', 2' RMAX2 XOFFSET SCALOB2 AXISWT SCALCALC') 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 IF(AXISWT.EQ.0.)AXISWT=1. MINWT=ABS(AXISWT) IF(SCALCALC.EQ.0)SCALCALC=1. C OPEN(UNIT=55,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') IF(NOCALC.EQ.1)GO TO 207 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, 1WLEDGE200 C 1WLEDGE C PATCH FOR SPECTRA THAT HAVE BEEN SQUASHED NAV=IFSURF/10 IFSURF=IFSURF-NAV*10 IF(NAV.EQ.0)NAV=1 C C 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)*NAV) 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)*NAV) 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) READ(7)NLINES WRITE(93)NLINES DO 2208 I=1,NLINES READ(7)LINDAT8,LINDAT 2208 WRITE(93)LINDAT8,LINDAT ENDIF CALL MAXLENGTH(500) CALL INITPLT(70) C CALL START AT (1.,.5) C CALL START AT (0.,OFFSET) 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) IF(XSCALE.EQ.15.)W2=W1+.15 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 REALTECH LASER CALL START AT (9./32.,0.) 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) CALL WEIGHT(MINWT) IPAN1=1 WW=W1 WRITE(WW7,'(F7.1)')WW WRITE(HEADERDATA(1),'(A8,A1)')USERID WRITE(HEADERDATA(2),'(A4,A4)')JOBID WRITE(HEADERDATA(3),'(A4,A4)')ITIME WRITE(HEADERDATA(4),'(A4,A4,A1)')IDATE WRITE(HEADERDATA(5),'(A8,A1)')FILENAME c canon is 0.5 higher than xerox THESE ARE CANON CANON=0. CANON=.5 IF(NOWAVE.EQ.0)THEN C CALL STRINGX10(WW6,0.,14.35-OFFSET+CANON) C CALL STRINGX10(WW6,20.5,14.35-OFFSET+CANON) CALL STRINGY10(WW7,-.2,11.00-OFFSET+CANON) C CALL STRINGY10(WW6,23.6,12.00-OFFSET+CANON) C FOR MINOLTA CALL STRINGY10(WW7,23.59,11.00-OFFSET+CANON) C CALL STRINGX(HEADERDATA(1),3.5,15.00-OFFSET+CANON) Cc CALL STRINGX(HEADERDATA(2),3.5,14.85-OFFSET+CANON) C CALL STRINGX(HEADERDATA(3),3.5,14.85-OFFSET+CANON) C CALL STRINGX(HEADERDATA(4),3.5,14.70-OFFSET+CANON) C CALL STRINGX(HEADERDATA(5),3.5,14.55-OFFSET+CANON) CALL STRINGY(HEADERDATA(1),-.40,10.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(3),-.55,10.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(4),-.70,10.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(5),-.85,10.00-OFFSET+CANON) ENDIF C CALL STRINGX(MESSAGE(1),4.5,15.00-OFFSET+CANON) C CALL STRINGX(MESSAGE(2),4.5,14.85-OFFSET+CANON) C CALL STRINGX(MESSAGE(3),4.5,14.70-OFFSET+CANON) C CALL STRINGX(MESSAGE(4),10.0,15.00-OFFSET+CANON) C CALL STRINGX(MESSAGE(5),10.0,14.85-OFFSET+CANON) C CALL STRINGX(MESSAGE(6),10.0,14.70-OFFSET+CANON) C CALL STRINGX(MESSAGE(7),15.5,15.00-OFFSET+CANON) C CALL STRINGX(MESSAGE(8),15.5,14.85-OFFSET+CANON) C CALL STRINGX(MESSAGE(9),15.5,14.70-OFFSET+CANON) CALL STRINGY(MESSAGE(1),22.85,.0) CALL STRINGY(MESSAGE(2),23.00,.0) CALL STRINGY(MESSAGE(3),23.15,.0) CALL STRINGY(MESSAGE(4),23.30,.0) CALL STRINGY(MESSAGE(5),23.45,.0) CALL STRINGY(MESSAGE(6),22.85,5.5) CALL STRINGY(MESSAGE(7),23.00,5.5) CALL STRINGY(MESSAGE(8),23.15,5.5) CALL STRINGY(MESSAGE(9),23.30,5.5) C IF(IFTEXT.NE.0)THEN DO 9005 ITEXT=1,NTEXT READ(TEXT(ITEXT),'(A2,F8.5,F10.5,A60,A10)')XORY,X,Y,STRING60, 1STRINGCOLOR CALL COLOR BLACK IF(STRINGCOLOR.EQ.'RED ')CALL COLOR RED IF(STRINGCOLOR.EQ.'BLUE ')CALL COLOR BLUE IF(STRINGCOLOR.EQ.'ROYAL BLUE')CALL COLOR ROYAL BLUE IF(STRINGCOLOR.EQ.'CYAN ')CALL COLOR CYAN IF(STRINGCOLOR.EQ.'ORANGE ')CALL COLOR ORANGE IF(STRINGCOLOR.EQ.'LACQUER RE')CALL COLOR LACQUER RED IF(STRINGCOLOR.EQ.'GREEN ')CALL COLOR GREEN IF(STRINGCOLOR.EQ.'YELLOW ')CALL COLOR YELLOW IF(STRINGCOLOR.EQ.'MAGENTA ')CALL COLOR MAGENTA IF(STRINGCOLOR.EQ.'BLACK ')CALL COLOR BLACK IF(STRINGCOLOR.EQ.'GRAY ')CALL COLOR GRAY IF(STRINGCOLOR.EQ.'LIGHT GRAY')CALL COLOR LIGHT GRAY IF(STRINGCOLOR.EQ.'DARK GRAY ')CALL COLOR DARK GRAY IF(STRINGCOLOR.EQ.'BROWN ')CALL COLOR BROWN IF(STRINGCOLOR.EQ.'CRIMSON ')CALL COLOR CRIMSON IF(STRINGCOLOR.EQ.'AQUAMARINE')CALL COLOR AQUAMARINE IF(STRINGCOLOR.EQ.'LIME ')CALL COLOR LIME IF(STRINGCOLOR.EQ.'FIRE ')CALL COLOR FIRE IF(STRINGCOLOR.EQ.'YELLOW GRE')CALL COLOR YELLOW GREEN IF(STRINGCOLOR.EQ.'FOREST GRE')CALL COLOR FOREST GREEN IF(STRINGCOLOR.EQ.'BRITISH RA')CALL COLOR BRITISH RACING GREEN IF(STRINGCOLOR.EQ.'EVERGREEN ')CALL COLOR EVERGREEN IF(STRINGCOLOR.EQ.'MAROON ')CALL COLOR MAROON IF(STRINGCOLOR.EQ.'PURPLE ')CALL COLOR PURPLE IF(STRINGCOLOR.EQ.'PUMPKIN ')CALL COLOR PUMPKIN IF(STRINGCOLOR.EQ.'PLUM ')CALL COLOR PLUM IF(STRINGCOLOR.EQ.'COCOA ')CALL COLOR COCOA IF(STRINGCOLOR.EQ.'MULBERRY ')CALL COLOR MULBERRY IF(XORY.EQ.'X ')CALL STRINGX (STRING60,X,Y) IF(XORY.EQ.'X1')CALL STRINGX1(STRING60,X,Y) IF(XORY.EQ.'X2')CALL STRINGX2(STRING60,X,Y) IF(XORY.EQ.'X3')CALL STRINGX3(STRING60,X,Y) IF(XORY.EQ.'X4')CALL STRINGX4(STRING60,X,Y) IF(XORY.EQ.'X5')CALL STRINGX5(STRING60,X,Y) IF(XORY.EQ.'X6')CALL STRINGX6(STRING60,X,Y) IF(XORY.EQ.'X7')CALL STRINGX7(STRING60,X,Y) IF(XORY.EQ.'X8')CALL STRINGX8(STRING60,X,Y) IF(XORY.EQ.'X9')CALL STRINGX9(STRING60,X,Y) IF(XORY.EQ.'Y ')CALL STRINGY (STRING60,X,Y) IF(XORY.EQ.'Y1')CALL STRINGY1(STRING60,X,Y) IF(XORY.EQ.'Y2')CALL STRINGY2(STRING60,X,Y) IF(XORY.EQ.'Y3')CALL STRINGY3(STRING60,X,Y) IF(XORY.EQ.'Y4')CALL STRINGY4(STRING60,X,Y) IF(XORY.EQ.'Y5')CALL STRINGY5(STRING60,X,Y) IF(XORY.EQ.'Y6')CALL STRINGY6(STRING60,X,Y) IF(XORY.EQ.'Y7')CALL STRINGY7(STRING60,X,Y) IF(XORY.EQ.'Y8')CALL STRINGY8(STRING60,X,Y) IF(XORY.EQ.'Y9')CALL STRINGY9(STRING60,X,Y) CALL COLOR BLACK 9005 CONTINUE ENDIF END=(W2-W1)*10.*XSCALE IF(XSCALE.EQ.15.)END=22.5 YTOP=3.125*YSCALE IF(AXISWT.LT.0.)GO TO 17 C DRAW BOX CALL JUMP TO (0.,0.) CALL LINE TO (END,0.) CALL LINE TO (END,YTOP) CALL LINE TO (0.,YTOP) CALL LINE TO (0.,0.) C C X AXIS 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..0012.AND.MOD(I,5000).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 IF(XSCALE.LT..0012.AND.MOD(I,1000).NE.1)GO TO 11 IF(XSCALE.LT..00012.AND.MOD(I,10000).NE.1)GO TO 11 IF(XSCALE.LT..00006.AND.MOD(I,20000).NE.1)GO TO 11 IF(XSCALE.LT..00003.AND.MOD(I,100000).NE.1)GO TO 11 IF(XSCALE.LT..000012.AND.MOD(I,100000).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(XSCALE.LT..0022.AND.MOD(I,1000).NE.1)GO TO 11 IF(XSCALE.LT..0011.AND.MOD(I,2500).NE.1)GO TO 11 IF(IFNOAX.NE.1.AND.XSCALE.GE..2)THEN WRITE(WW7,'(F7.1)')WAVE CALL STRINGX2(WW7,X-.4,-.3) ENDIF IF(IFNOAX.NE.1.AND.XSCALE.LT..2)THEN IWAVE=WAVE WRITE(WW7,'(I7)')IWAVE CALL STRINGX2(WW7,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(MINWT) 11 CONTINUE C c IF(XSCALE.GT.10..AND.IFNOAX.NE.1)THEN c N=END*.1+.05 c DO 1611 I=1,N c WAVE=W1+FLOAT(I)/XSCALE c X=I*10 c WRITE(STRING9,'(F9.4)')WAVE c 1611 CALL STRINGX2(STRING9,X-.4,-.3) c ENDIF C C Y AXIS DO 12 I=1,11 Y=FLOAT(I-1)*YTOP/10. 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(IFNOAX.EQ.-1.AND.NOLABY.EQ.0)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 WRITE(STRING6,'(F2.1)')R C CALL STRINGX2(STRING6,-.23,Y) CC CALL BCDX(1,R,2,6H(F2.1),.15,-.23,Y) C CALL WEIGHT(MINWT) C WRITE(STRING6,'(F3.2)')R 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 WRITE(STRING6,'(F6.1)')RMAX C CALL STRINGX2(STRING6,-.9,Y-.05) C CALL WEIGHT(MINWT) 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(MINWT) CALL STRINGX2(' .@ @ @ @ 99 ',-.88,YTOP*.9-.05) CALL STRINGX2(' .@ @ @ @ 98 ',-.88,YTOP*.8-.05) CALL STRINGX2(' .@ @ @ @ 97 ',-.88,YTOP*.7-.05) CALL STRINGX2(' .@ @ @ @ 96 ',-.88,YTOP*.6-.05) CALL STRINGX2(' .@ @ @ @ 95 ',-.88,YTOP*.5-.05) CALL STRINGX2(' .@ @ @ @ 94 ',-.88,YTOP*.4-.05) CALL STRINGX2(' .@ @ @ @ 93 ',-.88,YTOP*.3-.05) CALL STRINGX2(' .@ @ @ @ 92 ',-.88,YTOP*.2-.05) CALL STRINGX2(' .@ @ @ @ 91 ',-.88,YTOP*.1-.05) CALL STRINGX2(' .@ @ @ @ 90 ',-.88,YTOP*.0-.05) GO TO 17 ENDIF DO 13 I=1,10,ITWO Y=FLOAT(I-1)*YTOP/10. R=(RMAX-RMIN)/10.*FLOAT(I-1)+RMIN CALL WEIGHT(MINWT) IF(IFNOAX.EQ.1.OR.NOLABY.EQ.1)GO TO 13 C IF(RMAX-RMIN.GE..5)WRITE(STRING6,'(F6.2)')R C IF(RMAX-RMIN.LT..5)WRITE(STRING6,'(F6.2)')R WRITE(STRING6,'(F6.1)')R IF(RMAX-RMIN.LT.1.)WRITE(STRING6,'(F6.2)')R IF(I.GT.1)Y=Y-.03 IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,Y) IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,Y) 13 CONTINUE IF(IFNOAX.EQ.1.OR.NOLABY.EQ.1)GO TO 17 WRITE(STRING6,'(F6.1)')RMAX C IF(RMAX-RMIN.GE..5)WRITE(STRING6,'(F6.1)')RMAX C IF(RMAX-RMIN.LT..5)WRITE(STRING6,'(F6.1)')RMAX IF(RMAX-RMIN.LT.1.)WRITE(STRING6,'(F6.2)')RMAX IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,YTOP-.08) IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,YTOP-.16) GO TO 17 14 IF(IFABSO.EQ.1.OR.NOLABY.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 WRITE(STRING6,'(F6.1)')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(MINWT) 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(MINWT) 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(MINWT) 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(MINWT) 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 IF(IFGRID.EQ.5.OR.IFGRID.EQ.6)THEN C CALL COLOR PALE GREEN CALL RGBCOLORS(90,100,90) CALL WEIGHT(1) DO 4041 I=1,299 X=I*.075 CALL JUMP TO (X,0.) IF(MOD(I,10).NE.0)CALL LINE TO (X,YTOP) 4041 CONTINUE CALL WEIGHT(12) NYGRID=50 IF(NGRID.EQ.6)NYGRID=100 DO 4042 I=1,NYGRID-1 Y=(I*YTOP)/NYGRID CALL JUMP TO (0.,Y) IF(MOD(I,5).NE.0)CALL LINE TO (END,Y) 4042 CONTINUE CALL COLOR GRAY CALL WEIGHT(1) DO 4043 I=1,299 X=I*.075 CALL JUMP TO (X,0.) IF(MOD(I,10).EQ.0)CALL LINE TO (X,YTOP) 4043 CONTINUE CALL WEIGHT(12) CALL COLOR LIGHT GRAY DO 4044 I=1,NYGRID-1 Y=(I*YTOP)/NYGRID CALL JUMP TO (0.,Y) IF(MOD(I,5).EQ.0)CALL LINE TO (END,Y) 4044 CONTINUE CALL COLOR BLACK CALL WEIGHT(2) DO 4045 I=1,301,50 X=(I-1)*.075 CALL JUMP TO (X,0.) CALL LINE TO (X,YTOP) 4045 CONTINUE CALL WEIGHT(MINWT) ENDIF C IF(IFGRID.EQ.10.OR.IFGRID.EQ.11)THEN C CALL COLOR PALE GREEN CALL RGBCOLORS(90,100,90) CALL WEIGHT(1) DO 4051 I=1,274 X=I*.0818182 CALL JUMP TO (X,0.) IF(MOD(I,5).NE.0)CALL LINE TO (X,YTOP) 4051 CONTINUE CALL WEIGHT(12) NYGRID=50 IF(IFGRID.EQ.11)NYGRID=100 DO 4052 I=1,NYGRID-1 Y=(I*YTOP)/NYGRID CALL JUMP TO (0.,Y) IF(MOD(I,5).NE.0)CALL LINE TO (END,Y) 4052 CONTINUE CALL COLOR GRAY CALL WEIGHT(1) DO 4053 I=1,274 X=I*.0818182 CALL JUMP TO (X,0.) IF(MOD(I,5).EQ.0)CALL LINE TO (X,YTOP) 4053 CONTINUE CALL WEIGHT(12) CALL COLOR LIGHT GRAY DO 4054 I=1,NYGRID-1 Y=(I*YTOP)/NYGRID CALL JUMP TO (0.,Y) IF(MOD(I,5).EQ.0)CALL LINE TO (END,Y) 4054 CONTINUE CALL COLOR BLACK CALL WEIGHT(2) DO 4055 I=1,276,25 X=(I-1)*.0818182 CALL JUMP TO (X,0.) CALL LINE TO (X,YTOP) 4055 CONTINUE CALL WEIGHT(MINWT) ENDIF 20 IF(NOCALC.EQ.0.AND.NOLABY.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.1)CALL STRINGY2('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) NSKIP=NSKIP/NAV 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)*NAV) IF(WAVE.LT.W1)GO TO 23 IF(WAVE.GT.W2+.0001)GO TO 24 FREQ=2.99792458E17/WAVE HLAM=Q2(MU)*FREQ/WAVE*SCALCALC 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*SCALCALC HMAX=AMAX1(HMAX,CONT) HMIN=AMIN1(HMIN,CONT) 23 CONTINUE C 24 WRITE(6,25)HMIN,HMAX 25 FORMAT(1P2E12.3) IF(NOLABY.EQ.1)GO TO 270 WRITE(STRING9,3535)HMAX CALL STRINGY2(STRING9,-.8,10.00-OFFSET+CANON) C CALL STRINGY2(STRING9,END+.6,YTOP-1.2) C WRITE(STRING9,3535)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. WRITE(STRING6,'(F6.2)')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 CONTINUE CALL COLOR BLACK IF(COLOROBS.EQ.'RED ')CALL COLOR RED IF(COLOROBS.EQ.'BLUE ')CALL COLOR BLUE IF(COLOROBS.EQ.'ROYAL BLUE')CALL COLOR ROYAL BLUE IF(COLOROBS.EQ.'CYAN ')CALL COLOR CYAN IF(COLOROBS.EQ.'ORANGE ')CALL COLOR ORANGE IF(COLOROBS.EQ.'LACQUER RE')CALL COLOR LACQUER RED IF(COLOROBS.EQ.'GREEN ')CALL COLOR GREEN IF(COLOROBS.EQ.'YELLOW ')CALL COLOR YELLOW IF(COLOROBS.EQ.'MAGENTA ')CALL COLOR MAGENTA IF(COLOROBS.EQ.'BLACK ')CALL COLOR BLACK IF(COLOROBS.EQ.'GRAY ')CALL COLOR GRAY IF(COLOROBS.EQ.'LIGHT GRAY')CALL COLOR LIGHT GRAY IF(COLOROBS.EQ.'DARK GRAY ')CALL COLOR DARK GRAY IF(COLOROBS.EQ.'BROWN ')CALL COLOR BROWN IF(COLOROBS.EQ.'CRIMSON ')CALL COLOR CRIMSON IF(COLOROBS.EQ.'AQUAMARINE')CALL COLOR AQUAMARINE IF(COLOROBS.EQ.'LIME ')CALL COLOR LIME IF(COLOROBS.EQ.'FIRE ')CALL COLOR FIRE IF(COLOROBS.EQ.'YELLOW GRE')CALL COLOR YELLOW GREEN IF(COLOROBS.EQ.'FOREST GRE')CALL COLOR FOREST GREEN IF(COLOROBS.EQ.'BRITISH RA')CALL COLOR BRITISH RACING GREEN IF(COLOROBS.EQ.'EVERGREEN ')CALL COLOR EVERGREEN IF(COLOROBS.EQ.'MAROON ')CALL COLOR MAROON IF(COLOROBS.EQ.'PURPLE ')CALL COLOR PURPLE IF(COLOROBS.EQ.'PUMPKIN ')CALL COLOR PUMPKIN IF(COLOROBS.EQ.'PLUM ')CALL COLOR PLUM IF(COLOROBS.EQ.'COCOA ')CALL COLOR COCOA IF(COLOROBS.EQ.'MULBERRY ')CALL COLOR MULBERRY CALL OBSERV C READS FROM 56 IF(MOD(IFOBSN,10).EQ.1)CALL OBSERV1(IFOBSN) C READS FROM 57 IF(MOD(IFOBSN,10).EQ.2)CALL OBSERV2(IFOBSN) 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 IF(IFSIRV.GT.0)CALL OBSSIR(IFSIRV) IF(IFSIRUV.GT.0)CALL OBSSIR(IFSIRUV) C READS FROM 67 IF(IFARC.GT.0)CALL OBSARC(IFARC) C READS FROM 68 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 NSKIP=NSKIP/NAV DO 230 I=1,NSKIP 230 READ(7) 231 N1=NSKIP+1 ISTART=0 CALL WEIGHT(MINWT) IF(IFDLIN.GT.0)CALL WEIGHT(IFDLIN) 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(MINWT) NSKIP=0 GO TO 735 ENDIF C CALL WEIGHT(1) IF(IFDLIN.GT.0)CALL WEIGHT(IFDLIN) XOLD=0. YOLD=0. DO 33 IWL=N1,NWL READ(7)(Q2(I),I=1,NMU2) WAVE=WBEGDOP*RATIO**((IWL-1)*NAV) IF(WAVE.LT.W1)GO TO 33 IF(WAVE.GT.W2+.0001)GO TO 34 FREQ=2.99792458E17/WAVE HLAM=Q2(MU)*FREQ/WAVE*SCALCALC CONT=Q2(MUNMU)*FREQ/WAVE*SCALCALC 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 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 33 CONTINUE CALL WEIGHT(MINWT) 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)*NAV) IF(WAVE.LT.W1)GO TO 733 IF(WAVE.GT.W2+.0001)GO TO 734 FREQ=2.99792458E17/WAVE HLAM=Q2(MU)*FREQ/WAVE*SCALCALC CONT=Q2(MUNMU)*FREQ/WAVE*SCALCALC C 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 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 733 CONTINUE 732 CALL WEIGHT(MINWT) NSKIP=0 GO TO 735 734 NSKIP=NWL-IWL CALL WEIGHT(MINWT) 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)WRITE(STRING9,3535)CONT IF(IFABSO.EQ.1)WRITE(STRING9,3535)HMAX 3535 FORMAT(1PE9.3) C IF(NOLABY.EQ.0)CALL STRINGY2(STRING9,END+.4,YTOP-1.2) CALL WEIGHT(MINWT) IF(NOLABY.EQ.0.AND.IFLABL.NE.0) 1CALL STRINGY(STRING9,-.25,YTOP+.25) C 1CALL 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) NSKIP=NSKIP/NAV IF(NSKIP.EQ.0)GO TO 37 DO 36 I=1,NSKIP 36 READ(7) 37 N1=NSKIP+1 ISTART=0 CALL WEIGHT(MINWT) IF(IFDLIN.GT.0)CALL WEIGHT(IFDLIN) 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)*NAV) IF(WAVE.LT.W1)GO TO 43 IF(WAVE.GT.W2+.0001)GO TO 44 FREQ=2.99792458E17/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 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 43 CONTINUE CALL WEIGHT(MINWT) NSKIP=0 GO TO 50 44 NSKIP=NWL-IWL CALL WEIGHT(MINWT) 50 CALL COLOR BLACK 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(IFOBSN) C READS A SPECTRUM IN WAVELENGTH-INTENSITY PAIRS C IFOBSN = 1 FORMATTED ABSOLUTE C IFOBSN = 11 FORMATTED RELATIVE C IFOBSN = 21 BINARY ABSOLUTE C IFOBSN = 31 BINARY RELATIVE COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WI,W COMMON /WISI/WI(800000),SI(800000) DATA IREAD/0/ WOLD=0. IF(IREAD.EQ.1)GO TO 5 IREAD=1 IF(IFOBSN.LE.11)THEN OPEN(UNIT=56,SHARED,READONLY,TYPE='OLD',FORM='FORMATTED') DO 2 I=1,800000 READ(56,*,END=3)W,S WI(I)=W*(1.D0+DOPOBS/2.99792458D5) SCALOB=(W-WNEW1)/(WNEW2-WNEW1)*(SCALOB2-SCALOBS)+SCALOBS SI(I)=(S-ZEROOBS)*SCALOB 2 CONTINUE ELSE OPEN(UNIT=56,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') DO 6 I=1,800000 READ(56,END=3)W,S WI(I)=W*(1.D0+DOPOBS/2.99792458D5) SCALOB=(W-WNEW1)/(WNEW2-WNEW1)*(SCALOB2-SCALOBS)+SCALOBS SI(I)=(S-ZEROOBS)*SCALOB 6 CONTINUE ENDIF 3 N=I CLOSE(UNIT=56) 5 ISTART=0 CALL WEIGHT(2) CALL WEIGHT(3) SMAX=HMAX IF(IFOBSN.EQ.11.OR.IFOBSN.EQ.31)SMAX=1. DO 14 I=1,N W=WI(I) IF(W.LT.W1)GO TO 14 IF(W.GT.W2)GO TO 15 IF(W.LT.WOLD)ISTART=0 WOLD=W X=(W-W1)*XSCALE*10. Y=(ABS(SI(I))/SMAX-RMIN)/(RMAX-RMIN)*3.125*YSCALE IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 CALL LINE TO (X,Y) 14 CONTINUE 15 CALL WEIGHT(MINWT) RETURN END SUBROUTINE OBSERV2(IFOBSN) C READS A SPECTRUM IN WAVELENGTH-INTENSITY PAIRS C PLOTS IT TWICE, NORMAL AND 10X SCALE C IFOBSN = 12 FORMATTED RESIDUAL C IFOBSN = 32 BINARY RESIDUAL COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WI,W COMMON /WISI/WI(800000),SI(800000) DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 5 IREAD=1 IF(IFOBSN.LE.12)THEN OPEN(UNIT=57,SHARED,READONLY,TYPE='OLD',FORM='FORMATTED') DO 2 I=1,800000 READ(57,*,END=3)W,S WI(I)=W*(1.D0+DOPOBS/2.99792458D5) SCALOB=(W-WNEW1)/(WNEW2-WNEW1)*(SCALOB2-SCALOBS)+SCALOBS SI(I)=(S-ZEROOBS)*SCALOB 2 CONTINUE ELSE OPEN(UNIT=57,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') DO 6 I=1,800000 READ(57,END=3)W,S WI(I)=W*(1.D0+DOPOBS/2.99792458D5) SCALOB=(W-WNEW1)/(WNEW2-WNEW1)*(SCALOB2-SCALOBS)+SCALOBS SI(I)=(S-ZEROOBS)*SCALOB 6 CONTINUE ENDIF 3 NIN=I-1 CLOSE(UNIT=57) 5 ISTART=0 CALL WEIGHT(2) CALL WEIGHT(3) 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 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) C Y=(S-.9)/(1.0-.9)*3.125*YSCALE Y=(S-RMIN2)/(RMAX2-RMIN2)*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 CALL WEIGHT(MINWT) 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) 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(MINWT) 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(MINWT) RETURN C LIMB 30 IF(W1.GT.973.9)RETURN IF(W2.LT.367.6)RETURN REWIND 60 ISTART=0 CALL WEIGHT(MINWT) 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(MINWT) 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) 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(MINWT) 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(MINWT) RETURN END SUBROUTINE OBSKPK(IFKPK) C HARVARD ROCKET SPECTRA KOHL,PARKINSON,KURUCZ COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) 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(MINWT) RETURN END SUBROUTINE OBSSACP(IFSACP) C SAC PEAK SOLAR ATLAS BY BECKERS, BRIDGES, AND GILLIAM COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) RETURN END SUBROUTINE OBSHAWA(IFHAWA) C HAWAII ROCKET SPECTRA ALLEN, MCALLISTER, AND JEFFRIES (1977) C IFHAWA=1 WEIGHT=2 C IFHAWA=2 WEIGHT=1 COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI(50000),W REAL*4 SHAWAII(50000),SS(50000) DATA IREAD/0/ IF(IREAD.EQ.0)THEN OPEN(UNIT=63,SHARED,READONLY,TYPE='OLD',FORM='FORMATTED') READ(63,63)SS 63 FORMAT(8F10.0) CLOSE(UNIT=63) IREAD=1 DO 64 I=4,50000-3 64 SHAWAII(I)= 1 SS(I)*.302+(SS(I-1)+SS(I+1))*.227+(SS(I-2)+SS(I+2))*.098+ 2 (SS(I-3)+SS(I+3))*.024 SHAWAII(1)=SS(1) SHAWAII(2)=SS(2) SHAWAII(3)=SS(3) SHAWAII(49998)=SS(49998) SHAWAII(49999)=SS(49999) SHAWAII(50000)=SS(50000) SMAX=4.E7 DO 65 I=1,50000 WI(I)=268.D0+(I-1)*.0005D0 WI(I)=WI(I)*(1.D0+DOPOBS/299792.458) 65 SS(I)=SHAWAII(I)/SMAX*SCALOBS DO 66 I=4,50000-3 66 SHAWAII(I)= 1 SS(I)*.302+(SS(I-1)+SS(I+1))*.227+(SS(I-2)+SS(I+2))*.098+ 2 (SS(I-3)+SS(I+3))*.024 SHAWAII(1)=SS(1) SHAWAII(2)=SS(2) SHAWAII(3)=SS(3) SHAWAII(49998)=SS(49998) SHAWAII(49999)=SS(49999) SHAWAII(50000)=SS(50000) ENDIF IF(W2.LT.WI(1))RETURN IF(W1.GE.WI(50000))RETURN ISTART=0 CALL WEIGHT(2) IF(IFHAWA.EQ.2)CALL WEIGHT(MINWT) DO 14 I=1,50000 IF(WI(I).LT.W1)GO TO 14 IF(WI(I).GT.W2)GO TO 15 X=(WI(I)-W1)*XSCALE*10. S=SHAWAII(I) Y=S*3.125*YSCALE IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 CALL LINE TO (X,Y) 14 CONTINUE 15 CALL WEIGHT(MINWT) RETURN END SUBROUTINE OBSNRL(IFNRL) RETURN END SUBROUTINE OBSPROC(IFPROC) COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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)*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(MINWT) RETURN END SUBROUTINE OBSSIR(IFSIR) C PLOTS FURENLID, KURUCZ, WESTIN, AND WESTIN SIRIUS ATLAS C IFSIR=1 WEIGHT=2 C IFSIR=2 WEIGHT=1 C IFSIR=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 C IFSIR=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 C IFSIR DOE NOT WORK TEMPORAILY BECAUSE OF DIFFERENT WEIGHTS FOR SCANS COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W,WSCANBEG(132),WSCANEND(132) DIMENSION RESCALE(40,132),WRESCALE(40,132),NRESCALE(132) DIMENSION NSCANBEG(133),FIXSCAN(2,132) COMMON /WISI/WI(250000),SI(250000),ISCAN(250000),SS(250000) DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 9 OPEN(UNIT=96,SHARED,READONLY,TYPE='OLD',FORM='FORMATTED') DO 9697 I=1,10000 READ(96,9696)JSCAN,WSCAN,RSCAN 9696 FORMAT(I5,F10.4,F10.3) PRINT 9696,JSCAN,WSCAN,RSCAN IF(JSCAN.EQ.0)GO TO 9698 NRESCALE(JSCAN)=NRESCALE(JSCAN)+1 WRESCALE(NRESCALE(JSCAN),JSCAN)=WSCAN 9697 RESCALE(NRESCALE(JSCAN),JSCAN)=RSCAN 9698 CONTINUE IREAD=1 OPEN(UNIT=66,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') NIN=0 IIIOLD=0 DO 4 I=1,500000 C W IS THE AIR WAVELENGTH C S IS THE PSEUDO-RESIDUAL FLUX READ(66,END=5)W,S,III W=W*(1.D0+DOPOBS/299792.458D0) IF(W.LT.WNEW1)GO TO 4 IF(W.GT.WNEW2+50.)GO TO 5 IF(W.GT.WNEW2)GO TO 4 IF(III.EQ.1.AND.W.GT.325.36)GO TO 4 IF(III.EQ.2.AND.W.GT.325.5)GO TO 4 IF(III.EQ.2.AND.W.LT.325.36)GO TO 4 IF(III.EQ.3.AND.W.LT.325.5)GO TO 4 IF(III.EQ.4.AND.W.LT.334.3)GO TO 4 IF(III.EQ.4.AND.W.GT.334.7)GO TO 4 IF(III.EQ.5.AND.W.LT.350.7)GO TO 4 IF(III.EQ.5.AND.W.GT.350.88)GO TO 4 IF(III.EQ.3.AND.W.GT.350.7)GO TO 4 IF(III.EQ.6.AND.W.LT.350.88)GO TO 4 IF(III.EQ.3.AND.W.gT.334.478.AND.W.LT.334.545)GO TO 4 IF(III.EQ.6.AND.W.gT.351.22.AND.W.LT.351.295)GO TO 4 IF(III.EQ.6.AND.W.GT.367.)GO TO 4 IF(III.EQ.132.AND.W.LT.759.)GO TO 4 IF(III.EQ.132.AND.Wnew2.LT.763.)GO TO 4 IF(III.EQ.131.AND.Wnew2.gT.763.)GO TO 4 NIN=NIN+1 IF(NIN.GT.250000)CALL ABORT WI(NIN)=W SI(NIN)=S ISCAN(NIN)=III IF(IIIOLD.EQ.III)GO TO 4 IIIOLD=III WSCANBEG(III)=W NSCANBEG(III)=NIN 4 CONTINUE 5 CONTINUE NSCANBEG(IIIOLD+1)=I IF(NIN.EQ.0)RETURN DO 501 I=1,NIN W4=WI(I) III=ISCAN(I) MMMM=MAP1(WRESCALE(1,III),RESCALE(1,III),NRESCALE(III),W4,R,1) c c 3% scattering, constant zeroobs=.03 c c IF(III.LE.6)ZEROBS=0. IF(III.EQ.132)ZEROBS=0. SI(I)=(SI(I)*R-ZEROOBS)/(1.-ZEROOBS) 501 SS(I)=SI(I) NWING=1 NWING=2 NWING=3 DO 505 I=1+NWING,NIN-NWING C IF(ISCAN(I).GT.6)GO TO 505 IF(ISCAN(I).NE.ISCAN(I-NWING))GO TO 505 IF(ISCAN(I).NE.ISCAN(I+NWING))GO TO 505 C SI(I)=SS(I-1)*.197+SS(I)*.606+SS(I+1)*.197 C SI(I)=(SS(I-1)+SS(I)+SS(I+1))/3. C SI(I)=SS(I)*.404+(SS(I-1)+SS(I+1))*.244+(SS(I-2)+SS(I+2))*.054 SI(I)=SS(I)*.302+(SS(I-1)+SS(I+1))*.227+(SS(I-2)+SS(I+2))*.098+ 1 (SS(I-3)+SS(I+3))*.024 505 CONTINUE 9 IF(NIN.EQ.0)RETURN NWEIGHT=2 IF(IFSIR.EQ.2.OR.IFSIR.EQ.12)NWEIGHT=1 ISCANOLD=0 YSCAN=0. XOLD=0. YOLD=0. DO 14 I=1,NIN W=WI(I) IF(W.LT.W1)GO TO 14 IF(W.GT.W2)GO TO 14 X=(W-W1)*XSCALE*10. Y=(SI(I)-RMIN)/(RMAX-RMIN)*3.125*YSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP.AND.RMAX.NE.1.)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0..AND.RMAX.NE.1.) 1XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(YTOP-YOLD) IF(ISCANOLD.NE.ISCAN(I))THEN ISCANOLD=ISCAN(I) YSCAN=YSCAN+.18 CALL WEIGHT(NWEIGHT) IF(NWEIGHT.EQ.2.AND.MOD(ISCANOLD,2).EQ.0)CALL WEIGHT(3) CALL IBCDX(1,ISCAN(I),3,4H(I3),.15,XNEW,YSCAN) CALL JUMP TO (XNEW,YNEW) ENDIF CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 14 CONTINUE 15 CONTINUE CALL WEIGHT(1) IF(IFSIR.LT.3)RETURN NWEIGHT=2 IF(IFSIR.EQ.2.OR.IFSIR.EQ.12.OR.IFSIR.EQ.5)NWEIGHT=1 ISCANOLD=0 YSCAN=0. XOLD=0. YOLD=0. DO 24 I=1,NIN W=WI(I) IF(W.LT.W1)GO TO 24 IF(W.GT.W2)GO TO 24 X=(W-W1)*XSCALE*10. Y=(SI(I)-.9)/(1.-.9)*3.125*YSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP.AND.RMAX.NE.1.)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0..AND.RMAX.NE.1.) 1XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(YTOP-YOLD) IF(ISCANOLD.NE.ISCAN(I))THEN ISCANOLD=ISCAN(I) CALL WEIGHT(NWEIGHT) IF(NWEIGHT.EQ.2.AND.MOD(ISCANOLD,2).EQ.0)CALL WEIGHT(3) IF(IFSIR.EQ.5)CALL WEIGHT(1) CALL JUMP TO (XNEW,YNEW) ENDIF CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 24 CONTINUE 25 CONTINUE 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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 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) C IF(IFSUNF.EQ.2.OR.IFSUNF.EQ.12)CALL WEIGHT(MINWT) 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 C CALL WEIGHT(MINWT) 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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 ALREADY REMOVED I THINK CC REMOVE GRAVITATIONAL RED SHIFT C 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 IF(NIN.EQ.0)RETURN DO 6 I=2,NIN IF(WI(I).GT.WI(I-1))GO TO 6 WI(I)=1.D7/(1.D7/WI(I-1)-.004D0) 6 CONTINUE 9 IF(NIN.EQ.0)RETURN CALL WEIGHT(2) IF(IFSOIR.EQ.2.OR.IFSOIR.EQ.4)CALL WEIGHT(MINWT) 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(MINWT) 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(MINWT) 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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(MINWT) 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(MINWT) 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 weight=2 is changed to 3 for emphasis 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/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W,AIRTOVAC 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 IF(IFVAC.EQ.1)W=AIRTOVAC(W) 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(3) IF(IFFTS.EQ.2.OR.IFFTS.EQ.12)CALL WEIGHT(MINWT) 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(MINWT) IF(IFFTS.EQ.21)CALL WEIGHT(3) 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) C Y=(S-.9)/(1.0-.9)*3.125*YSCALE Y=(S-RMIN2)/(RMAX2-RMIN2)*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(MINWT) RETURN END SUBROUTINE OBSFTS2(IFFTS2) C PLOTS THE RATIO OF TWO SPECTRA FROM THE FTS AT KITT PEAK C IFFTS2=1 WEIGHT=2 C IFFTS2=2 WEIGHT=1 C IFFTS2=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 C IFFTS2=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT 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 C IF(S1.GT.0.)SI(NIN)=MIN(1.,S2/S1) SI(NIN)=SI(NIN)*SCALOBS 4 CONTINUE 5 CONTINUE 9 IF(NIN.EQ.0)RETURN CALL WEIGHT(2) IF(IFFTS2.EQ.2.OR.IFFTS2.EQ.12)CALL WEIGHT(MINWT) 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(MINWT) IF(IFFTS2.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) C Y=(S-.9)/(1.0-.9)*3.125*YSCALE Y=(S-RMIN2)/(RMAX2-RMIN2)*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 24/INCH TWO ROWS, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=11 12/INCH ONE ROW, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=21 12/INCH ONE ROW, ATMOSPHERIC LINES HAVE FULL LABELS C IFLABL=31 24/INCH LOWER ROW ATOMS UPPER ROW MOLECULES COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI,RWL REAL*8 TITLE(74),XMU(20),WLEDGE(333),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 CHARACTER*6 NAMEAF(999),NAME C REAL*8 MOLAF(999) CHARACTER*10 CLABEL,CLABELP,COTHER1,COTHER2 EQUIVALENCE (CLABEL,LABEL(1)),(CLABELP,LABELP(1)) EQUIVALENCE (COTHER1,OTHER1(1)),(COTHER2,OTHER2(1)) CHARACTER*10 LABEL10,LABEL10P CHARACTER*9 STRING9 CHARACTER*21 STRING21 CHARACTER*25 STRING25 CHARACTER*30 STRING30 CHARACTER*33 STRING33 CHARACTER*1 COLON CHARACTER*38 LABAF,L38 CHARACTER*34 L34 CHARACTER*62 STRING62 CHARACTER*62 ROWATOM(10000),ROWMOL(10000),ROWALL(20000) EQUIVALENCE (ROWALL(1),ROWATOM(1)),(ROWALL(10001),ROWMOL(1)) INTEGER ICOLORATOM(10000),ICOLORMOL(10000),ICOLORALL(20000) EQUIVALENCE (ICOLORALL(1),ICOLORATOM(1)) EQUIVALENCE (ICOLORALL(10001),ICOLORMOL(1)) INTEGER IFTERRATOM(10000),IFTERRMOL(10000),IFTERRALL(20000) EQUIVALENCE (IFTERRALL(1),IFTERRATOM(1)) EQUIVALENCE (IFTERRALL(10001),IFTERRMOL(1)) REAL*8 XSORTATOM(10000),XSORTMOL(10000),XSORTALL(20000) EQUIVALENCE (XSORTALL(1),XSORTATOM(1)) EQUIVALENCE (XSORTALL(10001),XSORTMOL(1)) REAL*8 XSORT(20000) INTEGER ITAGATOM(10000),ITAGMOL(10000),ITAGALL(20000) EQUIVALENCE (ITAGALL(1),ITAGATOM(1)),(ITAGALL(10001),ITAGMOL(1)) INTEGER ICELLATOM(10000),ICELLMOL(10000),ICELLALL(20000) EQUIVALENCE (ICELLALL(1),ICELLATOM(1)) EQUIVALENCE (ICELLALL(10001),ICELLMOL(1)) DIMENSION ICOLORMAPATOM(99),ICOLORMAPALL(999) DATA ICOLORMAPATOM/ 2, 2, 2, 2, 2,20, 2, 2, 2, 1 2,25,41, 2,40, 2,38, 2, 2, 2, 2 9,27,11,15, 5,37,23,17,16,35, 3 33,24,24,24,24,24,24,24,24,24, 4 24,24,24,24,24,24,24,24,24,24, 5 24,24,24,24,24,24,24, 4, 4, 4, 6 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 7 4, 4,10,10,10,10,10,10,10,10, 8 10,10,10,10,10,10,10,10,10,10, 9 10,10,10,10,10,10,10,10,10,10/ DATA ICOLORMAPALL/ 2, 2, 2, 2, 2,20, 2, 2, 2, 1 2,25,41, 2,40, 2,38, 2, 2, 2, 2 9,27,11,15, 5,37,23,17,16,35, 3 33,24,24,24,24,24,24,24,24,24, 4 24,24,24,24,24,24,24,24,24,24, 5 24,24,24,24,24,24,24, 4, 4, 4, 6 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 7 4, 4,10,10,10,10,10,10,10,10, 8 10,10,10,10,10,10,10,10,10,10, 9 10,10,10,10,10,10,10,10,10,10, A 900*10/ CALL NAMEMOL(NAMEAF) ICOLORMAPALL(606)=23 ICOLORMAPALL(607)=1 ICOLORMAPALL(608)=26 ICOLORMAPALL(101)=16 ICOLORMAPALL(106)=15 ICOLORMAPALL(107)=40 ICOLORMAPALL(108)=23 ICOLORMAPALL(112)=9 ICOLORMAPALL(114)=5 ICOLORMAPALL(814)=6 ICOLORMAPALL(822)=11 C ICOLORMAPALL(10108)=16 ICOLORMAPALL(101)=16 C CELLIN=12. CELLIN=8. C IF(IFLABL.EQ.1)CELLIN=24. IF(IFLABL.EQ.1)CELLIN=16. MAXCEL=40000 DO 333 I=1,MAXCEL IFCELL(I,2)=0 333 IFCELL(I,1)=0 C LINESLABEL=0 LINESATOM=0 LINESMOL=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(NBUP.EQ.-1)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.99792458E17/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.3,F6.3,F6.3,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3 A8,A2,A8,A2,F7.4,F7.3,3F6.3) IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 C LIMIT ON CONVERGING SERIES IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)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..30)GO TO 70 IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. 1RESID.GT..100)GO TO 70 LINESLABEL=LINESLABEL+1 COLON=' ' IF(WL.LT.0.)COLON=':' RESID1000=MIN(RESID*1000.+.5,1.E9) IRESID=RESID1000 IELO=ELO IDWL=NINT(DWL*10000.) IDGFLOG=NINT(DGFLOG*1000.) WRITE(STRING9,'(SPI4,SPI5)')IDWL,IDGFLOG IF(STRING9.EQ.' +0 +0')STRING9=' ' I=WAVEI*10. RWL=WAVEI-I*.1D0 IWL=RWL*10000.D0+.5D0 IF(IWL.EQ.1000)IWL=0 C C TERRESTRIAL MOLECULE IF(NBUP.NE.-1)GO TO 62 ISOAF=NELION NAME=NAMEAF(ISOAF) WRITE(STRING21,'(I3.3,1X,A6,I4,I4,2X)')IWL,NAME,IELO,IRESID IF(REF.EQ.4HGOLD) 1 WRITE(STRING21,'(I3.3,1X,A4,I5,I4,3X)')IWL,NAME,IELO,IRESID WRITE(LABAF,'(A8,A2,A8,A8,A2,A8,A2)')LABEL,LABELP(1),OTHER1, 1OTHER2 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) IF(IFLABL.NE.21)GO TO 6800 STRING62=STRING21(1:18)//L38(1:35)//STRING9 GO TO 6801 6800 LL34=34 ICOLOR=27 IF(CODE.EQ.10108.)THEN ICOLOR=16 L34=L34(15:19) LL34=5 ENDIF IF(CODE.EQ.808.)THEN ICOLOR=4 L34=L34(1:5)//'-'//L34(7:9)//L34(15:16)//L34(11:13) LL34=15 ENDIF IF(CODE.EQ.60808.)THEN ICOLOR=2 L34=L34(2:13) LL34=12 ENDIF STRING62=STRING21(1:18)//L34(1:LL34)//STRING9 6801 IF(IFLABL.EQ.31)THEN LINESMOL=LINESMOL+1 XSORTMOL(LINESMOL)=(WAVEL-W1)*10.*XSCALE ICELLMOL(LINESMOL)=XSORTMOL(LINESMOL)*CELLIN+1. ROWMOL(LINESMOL)=STRING62 ICOLORMOL(LINESMOL)=ICOLOR IFTERRMOL(LINESMOL)=1 ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING62 ICOLORALL(LINESMOL)=ICOLOR IFTERRALL(LINESMOL)=1 ENDIF 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)STRING62 6802 FORMAT(70X,A62) GO TO 70 C C STELLAR MOLECULE 62 IF(CODE.LT.100.)GO TO 64 IF(CODE.NE.10108.)GO TO 112 COLON=':' WRITE(STRING33,1113)IWL,COLON,LABELP(2),IELO,IRESID C1113 FORMAT(I3.3,A1,' 10108',1X,A2,I6,I4) 1113 FORMAT(I3.3,A1,'10108',1X,A2,I6,I4) GO TO 114 112 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 IF(LABEL10(8:8).NE.' ')THEN READ(LABEL10,'(5X,I3)')N J=N ENDIF WRITE(STRING33,113)IWL,COLON,ICODE,LABELP(2),VUP,VLO,J,PQR, 1 IRESID,STRING9 113 FORMAT(I3.3,A1,I3,1X,A2,I3,1H-,I2,I3,A1,I4,A9) 114 ICOLOR=10 IF(CODE.EQ.606.)ICOLOR=23 IF(CODE.EQ.607.)ICOLOR=1 IF(CODE.EQ.608.)ICOLOR=26 IF(CODE.EQ.106.)ICOLOR=15 IF(CODE.EQ.107.)ICOLOR=40 IF(CODE.EQ.108.)ICOLOR=23 IF(CODE.EQ.112.)ICOLOR=9 IF(CODE.EQ.114.)ICOLOR=5 IF(CODE.EQ.814.)ICOLOR=6 IF(CODE.EQ.822.)ICOLOR=11 IF(CODE.EQ.10108.)ICOLOR=16 IF(IFLABL.EQ.31)THEN LINESMOL=LINESMOL+1 XSORTMOL(LINESMOL)=(WAVEL-W1)*10.*XSCALE ICELLMOL(LINESMOL)=XSORTMOL(LINESMOL)*CELLIN+1. ROWMOL(LINESMOL)=STRING33 ICOLORMOL(LINESMOL)=ICOLOR IFTERRMOL(LINESMOL)=0 IF(CODE.EQ.10108.)ROWMOL(LINESMOL)=STRING33(1:24)//CLABEL(1:6)// 1 COTHER1(4:9)//CLABELP(1:6)//COTHER2(4:9) ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING33 ICOLORALL(LINESLABEL)=ICOLOR IFTERRALL(LINESLABEL)=0 ENDIF 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,6565)STRING33 6565 FORMAT(99X,A33) 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 65 FORMAT(99X,A21) GO TO 70 C C ATOM 64 WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,STRING9 7114 FORMAT(I3.3,A1,F6.2,I7,I4,A9) ICODE=CODE IF(IFLABL.EQ.31)THEN LINESATOM=LINESATOM+1 XSORTATOM(LINESATOM)=(WAVEL-W1)*10.*XSCALE ICELLATOM(LINESATOM)=XSORTATOM(LINESATOM)*CELLIN+1. ROWATOM(LINESATOM)=STRING30 ICOLORATOM(LINESATOM)=ICOLORMAPATOM(ICODE) IFTERRATOM(LINESATOM)=0 ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING30 ICOLORALL(LINESATOM)=ICOLORMAPATOM(ICODE) IFTERRALL(LINESATOM)=0 ENDIF 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,5565)STRING30 5565 FORMAT(99X,A30) 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 C IF(IFLABL.NE.31)GO TO 140 IF(LINESMOL.EQ.0)GO TO 130 CALL TAGSORT(XSORTMOL,XSORT,LINESMOL,ITAGMOL) DO 125 LINE=1,LINESMOL L=ITAGMOL(LINE) XWL=XSORTMOL(L) NCELL=ICELLMOL(L) I=NCELL-1 IF(I.GT.0.AND.IFCELL(NCELL,2).EQ.1.AND.IFCELL(I,2).EQ.0.AND. 1IFCELL(NCELL+1,2).EQ.1)GO TO 123 DO 122 I=NCELL,MAXCEL IF(IFCELL(I,2).EQ.0)GO TO 123 122 CONTINUE 123 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,2).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,2)=1 XCELL=NCELL/CELLIN+.04 C YCELL=YTOP+2.40 YCELL=YTOP+2.50 ICODE=0 IF(IFTERRMOL(L).EQ.1)THEN CALL COLOR BLUE ELSE CALL COLOR RED READ(ROWMOL(L)(5:7),'(I3)')ICODE ENDIF CALL STRINGY (ROWMOL(L)(1:3),XCELL,YCELL) CALL COLORN(ICOLORMOL(L)) IF(ICODE.GT.0)CALL COLORN(ICOLORMAPALL(ICODE)) CALL STRINGY (' '//ROWMOL(L)(4:),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) CALL COLOR BLACK 125 CONTINUE C 130 IF(LINESATOM.EQ.0)RETURN CALL TAGSORT(XSORTATOM,XSORT,LINESATOM,ITAGATOM) DO 135 LINE=1,LINESATOM L=ITAGATOM(LINE) XWL=XSORTATOM(L) NCELL=ICELLATOM(L) I=MAX(NCELL-1,1) IF(I.GT.0.AND.IFCELL(NCELL,1).EQ.1.AND.IFCELL(I,1).EQ.0.AND. 1IFCELL(NCELL+1,1).EQ.1)GO TO 133 DO 132 I=NCELL,MAXCEL IF(IFCELL(I,1).EQ.0)GO TO 133 132 CONTINUE 133 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,1).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,1)=1 XCELL=NCELL/CELLIN YCELL=YTOP+0.1 IF(IFTERRATOM(L).EQ.1)THEN CALL COLOR BLUE ELSE CALL COLOR RED READ(ROWATOM(L)(5:7),'(I3)')ICODE ENDIF CALL STRINGY (ROWATOM(L)(1:3),XCELL,YCELL) CALL COLORN(ICOLORATOM(L)) IF(ICODE.GT.0)CALL COLORN(ICOLORMAPALL(ICODE)) CALL STRINGY (' '//ROWATOM(L)(4:),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) CALL COLOR BLACK 135 CONTINUE RETURN C 140 IF(LINESLABEL.EQ.0)RETURN CALL TAGSORT(XSORTALL,XSORT,LINESLABEL,ITAGALL) DO 145 LINE=1,LINESLABEL L=ITAGALL(LINE) XWL=XSORTALL(L) NCELL=ICELLALL(L) I=MAX(NCELL-1,1) IF(I.GT.0.AND.IFCELL(NCELL,1).EQ.1.AND.IFCELL(I,1).EQ.0.AND. 1IFCELL(NCELL+1,1).EQ.1)GO TO 143 DO 142 I=NCELL,MAXCEL IF(IFCELL(I,1).EQ.0)GO TO 143 142 CONTINUE 143 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,1).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,1)=1 XCELL=NCELL/CELLIN IF(IFLABL.NE.1)XCELL=XCELL-.04 YCELL=YTOP+.1 IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+2.81 IF(IFTERRALL(L).EQ.1)THEN CALL COLOR BLUE ELSE CALL COLOR RED READ(ROWALL(L)(5:7),'(I3)')ICODE ENDIF CALL STRINGY (ROWALL(L)(1:3),XCELL,YCELL) CALL COLORN(ICOLORALL(L)) IF(ICODE.GT.0)CALL COLORN(ICOLORMAPALL(ICODE)) CALL STRINGY (' '//ROWALL(L)(4:),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) 145 CALL LINE TO (XCELL-.04,YTOP+.08) RETURN END SUBROUTINE NAMEMOL(MOLNAME) C IDENTIFIES ISOTOPE CODES FOR HITRAN LINE LIST CHARACTER*6 MOLNAME(999) DO 1 I=1,999 1 MOLNAME(I)=' ' C C H2O MOLNAME(11)='H20 ' MOLNAME(14)='HDO ' MOLNAME(12)='H2O 18' MOLNAME(13)='H2O 17' C CO2 MOLNAME(21)='CO2 ' MOLNAME(22)='CO2 13' MOLNAME(23)='CO2 18' MOLNAME(24)='CO2 17' MOLNAME(25)='CO2 38' MOLNAME(26)='CO2 37' MOLNAME(27)='CO2 88' MOLNAME(28)='CO2 78' C O3 MOLNAME(31)='O3 ' MOLNAME(32)='O3 668' MOLNAME(33)='O3 686' C N2O MOLNAME(41)='N2O ' MOLNAME(42)='N2O456' MOLNAME(43)='N2O546' MOLNAME(44)='N2O 18' MOLNAME(45)='N2O 17' C CO MOLNAME(51)='CO ' MOLNAME(52)='CO 13 ' MOLNAME(53)='CO 18 ' MOLNAME(54)='CO 17 ' MOLNAME(55)='CO 38 ' MOLNAME(56)='CO 37 ' C CH4 MOLNAME(61)='CH4 ' MOLNAME(62)='CH4 13' MOLNAME(63)='CH3D ' C O2 MOLNAME(71)='O2 ' MOLNAME(72)='O2 18 ' MOLNAME(73)='O2 17 ' MOLNAME(74)='O2 77 ' MOLNAME(75)='O2 78 ' MOLNAME(76)='O2 88 ' C OH MOLNAME(131)='OH ' MOLNAME(132)='OH 18 ' MOLNAME(133)='OD ' C RETURN END SUBROUTINE TAGSORT(SAVE,DATA,N,TAG) INTEGER X,TAG(N) REAL*8 Z,DATA(N),SAVE(N) DO 99 I=1,N DATA(I)=SAVE(I) 99 TAG(I)=I NTRY=0 SRT00030 N1=2 SRT00040 15 DO 1 J=N1,N SRT00050 Z=DATA(J) SRT00060 X=TAG(J) SRT00070 IF(J-2)1,2,3 SRT00090 2 IF(Z-DATA(1))4,1,1 SRT00100 4 DATA(2)=DATA(1) SRT00110 DATA(1)=Z SRT00120 TAG(2)=TAG(1) SRT00130 TAG(1)=X SRT00150 GO TO 1 SRT00170 3 K7=J-1 SRT00180 IF(Z-DATA(K7))5,1,1 SRT00190 5 LFST=1 SRT00200 LAST=K7 SRT00210 6 MID=(LFST+LAST)/2 SRT00220 IF(Z-DATA(MID))7,8,9 SRT00230 7 IF(MID-LAST)10,8,8 SRT00240 10 LAST=MID SRT00250 GO TO 6 SRT00260 8 NSTART=MID SRT00270 GO TO 11 SRT00280 9 IF(LFST-MID)12,13,13 SRT00290 12 LFST=MID SRT00300 GO TO 6 SRT00310 13 NSTART=MID+1 SRT00320 11 DO 14 I=NSTART,K7 SRT00330 K9=J+NSTART-I SRT00340 TAG(K9)=TAG(K9-1) SRT00350 14 DATA(K9)=DATA(K9-1) SRT00370 DATA(NSTART)=Z SRT00380 TAG(NSTART)=X SRT00400 1 CONTINUE SRT00410 NTRY=NTRY+1 SRT00420 DO 16 I=2,N SRT00430 IF(DATA(I)-DATA(I-1))17,16,16 SRT00440 17 N1=I SRT00450 IF(NTRY-5)15,15,18 SRT00460 16 CONTINUE SRT00470 18 RETURN SRT00480 END SRT00490 SUBROUTINE COLORN(ICOLOR) GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22, 1 23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41),ICOLOR 1 CALL COLOR RED RETURN 2 CALL COLOR BLUE RETURN 3 CALL COLOR ROYAL BLUE RETURN 4 CALL COLOR CYAN RETURN 5 CALL COLOR ORANGE RETURN 6 CALL COLOR LACQUER RED RETURN 7 CALL COLOR GREEN RETURN 8 CALL COLOR YELLOW RETURN 9 CALL COLOR MAGENTA RETURN 10 CALL COLOR BLACK RETURN 11 CALL COLOR GRAY RETURN 12 CALL COLOR LIGHT GRAY RETURN 13 CALL COLOR DARK GRAY RETURN 14 CALL COLOR BROWN RETURN 15 CALL COLOR CRIMSON RETURN 16 CALL COLOR AQUAMARINE RETURN 17 CALL COLOR LIME RETURN 18 CALL COLOR FIRE RETURN 19 CALL COLOR YELLOW GREEN RETURN 20 CALL COLOR FOREST GREEN RETURN 21 CALL COLOR BRITISH RACING GREEN RETURN 22 CALL COLOR EVERGREEN RETURN 23 CALL COLOR MAROON RETURN 24 CALL COLOR PURPLE RETURN 25 CALL COLOR PUMPKIN RETURN 26 CALL COLOR PLUM RETURN C PALE TEAL 27 CALL RGBCOLORS(50,100,80) RETURN C PALE BLUE GREEN 28 CALL RGBCOLORS(70,100,80) RETURN C PALE BLUE GRAY 29 CALL RGBCOLORS(60,80,80) RETURN C SALMON 30 CALL RGBCOLORS(100,80,70) RETURN C PALE YELLOW GREEN 31 CALL RGBCOLORS(90,100,70) RETURN 32 CALL COLOR MULBERRY RETURN 33 CALL COLOR OLIVE RETURN 34 CALL COLOR LIGHT GREEN RETURN 35 CALL COLOR BURNT ORANGE RETURN 36 CALL COLOR KHAKI RETURN 37 CALL COLOR LIGHT OLIVE RETURN 38 CALL COLOR CAMEL RETURN 39 CALL COLOR TEAL RETURN 40 CALL COLOR COCOA RETURN 41 CALL COLOR MUSTARD RETURN END SUBROUTINE LABEL2 C RESID IS CENTER/TOP I.E. THE FRACTION OF THE PLOTTED PAGE IN PER MIL C LABELS COMPUTED SPECTRUM C IFLABL=2 24/INCH TWO ROWS, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=12 12/INCH ONE ROW, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=22 12/INCH ONE ROW, ATMOSPHERIC LINES HAVE FULL LABELS C IFLABL=32 24/INCH LOWER ROW ATOMS UPPER ROW MOLECULES COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI REAL*8 TITLE(74),XMU(20),WLEDGE(333),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 CHARACTER*6 NAMEAF(999),NAME C REAL*8 MOLAF(999) CHARACTER*10 LABEL10,LABEL10P CHARACTER*9 STRING9 CHARACTER*21 STRING21 CHARACTER*25 STRING25 CHARACTER*30 STRING30 CHARACTER*33 STRING33 CHARACTER*1 COLON CHARACTER*38 LABAF,L38 CHARACTER*34 L34 CHARACTER*62 STRING62 CHARACTER*62 ROWATOM(10000),ROWMOL(10000),ROWALL(20000) EQUIVALENCE (ROWALL(1),ROWATOM(1)),(ROWALL(10001),ROWMOL(1)) REAL*8 XSORTATOM(10000),XSORTMOL(10000),XSORTALL(20000) EQUIVALENCE (XSORTALL(1),XSORTATOM(1)) EQUIVALENCE (XSORTALL(10001),XSORTMOL(1)) REAL*8 XSORT(20000) INTEGER ITAGATOM(10000),ITAGMOL(10000),ITAGALL(20000) EQUIVALENCE (ITAGALL(1),ITAGATOM(1)),(ITAGALL(10001),ITAGMOL(1)) INTEGER ICELLATOM(10000),ICELLMOL(10000),ICELLALL(20000) EQUIVALENCE (ICELLALL(1),ICELLATOM(1)) EQUIVALENCE (ICELLALL(10001),ICELLMOL(1)) CALL NAMEMOL(NAMEAF) C CELLIN=12. CELLIN=8. C IF(IFLABL.EQ.2)CELLIN=24. IF(IFLABL.EQ.2)CELLIN=16. MAXCEL=40000 DO 333 I=1,MAXCEL IFCELL(I,2)=0 333 IFCELL(I,1)=0 C LINESLABEL=0 LINESATOM=0 LINESMOL=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 C IF(REF.EQ.4HHI92)THEN IF(NBUP.EQ.-1)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.99792458E17/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 C LIMIT ON CONVERGING SERIES IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)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 LINESLABEL=LINESLABEL+1 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 COLON=' ' IF(WL.LT.0.)COLON=':' RESID1000=CENTER/TOP*1000.+.5 RESID1000=MIN(RESID1000,1.E9) IRESID=RESID1000 IELO=ELO IDWL=NINT(DWL*10000.) IDGFLOG=NINT(DGFLOG*1000.) WRITE(STRING9,'(SPI4,SPI5)')IDWL,IDGFLOG IF(STRING9.EQ.' +0 +0')STRING9=' ' I=WAVEI*10. RWL=WAVEI-FLOAT(I)*.1 IWL=RWL*10000.+.5 IF(IWL.EQ.1000)IWL=0 C C TERRESTRIAL MOLECULE C IF(REF.NE.4HHI92)GO TO 62 IF(NBUP.NE.-1)GO TO 62 ISOAF=NELION C MOL=MOLAF(ISOAF) NAME=NAMEAF(ISOAF) WRITE(STRING21,'(I3.3,1X,A6,I4,I4,2X)')IWL,NAME,IELO,IRESID C WRITE(STRING21,'(I3.3,1X,A6,I5,I4,2X)')IWL,NAME,IELO,IRESID C IF(IFLABL.NE.22)GO TO 66 WRITE(LABAF,'(A8,A2,A8,A8,A2,A8,A2)')LABEL,LABELP(1),OTHER1, 1OTHER2 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) IF(IFLABL.NE.22)GO TO 6800 STRING62=STRING21(1:18)//L38(1:35)//STRING9 GO TO 6801 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 LL34=34 IF(CODE.EQ.10108.)THEN C L34=L34(1:6)//L34(8:13)//L34(15:19) C LL34=18 L34=L34(15:19) LL34=5 ENDIF IF(CODE.EQ.808.)THEN L34=L34(1:5)//'-'//L34(8:10)//L34(16:17)//L34(12:14) LL34=15 ENDIF IF(CODE.EQ.60808.)THEN L34=L34(2:13) LL34=12 ENDIF C STRING62=STRING21(1:19)//L34(1:LL34)//STRING9 STRING62=STRING21(1:18)//L34(1:LL34)//STRING9 6801 IF(IFLABL.EQ.32)THEN LINESMOL=LINESMOL+1 XSORTMOL(LINESMOL)=(WAVEL-W1)*10.*XSCALE ICELLMOL(LINESMOL)=XSORTMOL(LINESMOL)*CELLIN+1. ROWMOL(LINESMOL)=STRING62 ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING62 ENDIF 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)STRING62 6802 FORMAT(70X,A62) GO TO 70 C C STELLAR MOLECULE 62 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 IF(LABEL10(8:8).NE.' ')THEN READ(LABEL10,'(5X,I3)')N J=N ENDIF WRITE(STRING33,113)IWL,COLON,ICODE,LABELP(2),VUP,VLO,J,PQR, 1 IRESID,STRING9 113 FORMAT(I3.3,A1,I3,1X,A2,I3,1H-,I2,I3,A1,I4,A9) IF(IFLABL.EQ.32)THEN LINESMOL=LINESMOL+1 XSORTMOL(LINESMOL)=(WAVEL-W1)*10.*XSCALE ICELLMOL(LINESMOL)=XSORTMOL(LINESMOL)*CELLIN+1. ROWMOL(LINESMOL)=STRING33 ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING33 ENDIF 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,6565)STRING33 6565 FORMAT(99X,A33) 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 65 FORMAT(99X,A21) GO TO 70 C C ATOM 64 WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,STRING9 7114 FORMAT(I3.3,A1,F6.2,I7,I4,A9) IF(IFLABL.EQ.32)THEN LINESATOM=LINESATOM+1 XSORTATOM(LINESATOM)=(WAVEL-W1)*10.*XSCALE ICELLATOM(LINESATOM)=XSORTATOM(LINESATOM)*CELLIN+1. ROWATOM(LINESATOM)=STRING30 ELSE XSORTALL(LINESLABEL)=(WAVEL-W1)*10.*XSCALE ICELLALL(LINESLABEL)=XSORTALL(LINESLABEL)*CELLIN+1. ROWALL(LINESLABEL)=STRING30 ENDIF 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,5565)STRING30 5565 FORMAT(99X,A30) 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 C IF(IFLABL.NE.32)GO TO 140 IF(LINESMOL.EQ.0)GO TO 130 CALL TAGSORT(XSORTMOL,XSORT,LINESMOL,ITAGMOL) DO 125 LINE=1,LINESMOL L=ITAGMOL(LINE) XWL=XSORTMOL(L) NCELL=ICELLMOL(L) I=NCELL-1 IF(I.GT.0.AND.IFCELL(NCELL,2).EQ.1.AND.IFCELL(I,2).EQ.0.AND. 1IFCELL(NCELL+1,2).EQ.1)GO TO 123 DO 122 I=NCELL,MAXCEL IF(IFCELL(I,2).EQ.0)GO TO 123 122 CONTINUE 123 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,2).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,2)=1 XCELL=NCELL/CELLIN+.04 C YCELL=YTOP+2.40 YCELL=YTOP+2.50 CALL STRINGY (ROWMOL(L),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) 125 CALL LINE TO (XCELL-.04,YTOP+.08) C 130 IF(LINESATOM.EQ.0)RETURN CALL TAGSORT(XSORTATOM,XSORT,LINESATOM,ITAGATOM) DO 135 LINE=1,LINESATOM L=ITAGATOM(LINE) XWL=XSORTATOM(L) NCELL=ICELLATOM(L) I=MAX(NCELL-1,1) IF(I.GT.0.AND.IFCELL(NCELL,1).EQ.1.AND.IFCELL(I,1).EQ.0.AND. 1IFCELL(NCELL+1,1).EQ.1)GO TO 133 DO 132 I=NCELL,MAXCEL IF(IFCELL(I,1).EQ.0)GO TO 133 132 CONTINUE 133 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,1).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,1)=1 XCELL=NCELL/CELLIN YCELL=YTOP+0.1 CALL STRINGY (ROWATOM(L),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) 135 CALL LINE TO (XCELL-.04,YTOP+.08) RETURN C 140 IF(LINESLABEL.EQ.0)RETURN CALL TAGSORT(XSORTALL,XSORT,LINESLABEL,ITAGALL) DO 145 LINE=1,LINESLABEL L=ITAGALL(LINE) XWL=XSORTALL(L) NCELL=ICELLALL(L) I=MAX(NCELL-1,1) IF(I.GT.0.AND.IFCELL(NCELL,1).EQ.1.AND.IFCELL(I,1).EQ.0.AND. 1IFCELL(NCELL+1,1).EQ.1)GO TO 143 DO 142 I=NCELL,MAXCEL IF(IFCELL(I,1).EQ.0)GO TO 143 142 CONTINUE 143 NCELL=I IF(NCELL.GT.1.AND.IFCELL(NCELL-1,1).EQ.0)NCELL=NCELL-1 IFCELL(NCELL,1)=1 XCELL=NCELL/CELLIN IF(IFLABL.NE.2)XCELL=XCELL-.04 YCELL=YTOP+.1 IF(IFLABL.EQ.2.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+2.81 CALL STRINGY (ROWALL(L),XCELL,YCELL) CALL JUMP TO (XWL,-.05) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) 145 CALL LINE TO (XCELL-.04,YTOP+.08) RETURN END SUBROUTINE LABEL3 RETURN END SUBROUTINE LABEL4 RETURN END SUBROUTINE LABEL5 RETURN END SUBROUTINE LABEL6 RETURN END SUBROUTINE LABEL7(IFOPAC) COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,WNEW1, 2 WNEW2,YTOP,HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET, 3 IFVAC,RMAX,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,MINWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI REAL*8 TITLE(74),XMU(20),WLEDGE(333),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.4HHI92)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.99792458E17/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.4HHI92)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.3,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.3,A1,I3,I3,1H-,I2,I3,A1,I4) GO TO 66 64 ENCODE(21,1414,WORDS)IWL,COLON,CODE,IELO,IRESID 1414 FORMAT(I3.3,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 RETURN END FUNCTION AIRTOVAC(W) IMPLICIT REAL*8 (A-H,O-Z) C W IS AIR WAVELENGTH IN NM C WAVEN IS AIR WAVENUMBER WHICH IS USUALLY GOOD ENOUGH C MUST ITERATE FOR EXACT SOLUTION WAVEN=1.d7/W WNEW=W*(1.0000834213D0+ 1 2406030.D0/(1.30D10-WAVEN**2.)+15997.D0/(3.89D9-WAVEN**2.)) C 1(1.000064328+2949810./(1.46E10-WAVEN**2)+25540./(4.1E9-WAVEN**2)) WAVEN=1.E7/WNEW WNEW=W*(1.0000834213+ 1 2406030./(1.30E10-WAVEN**2)+15997./(3.89E9-WAVEN**2)) WAVEN=1.E7/WNEW AIRTOVAC=W*(1.0000834213+ 1 2406030./(1.30E10-WAVEN**2)+15997./(3.89E9-WAVEN**2)) RETURN END FUNCTION VACTOAIR(W) IMPLICIT REAL*8 (A-H,O-Z) C W IS VACUUM WAVELENGTH IN NM WAVEN=1.E7/W VACTOAIR=W/(1.0000834213+ 1 2406030./(1.30E10-WAVEN**2)+15997./(3.89E9-WAVEN**2)) C 1(1.000064328+2949810./(1.46E10-WAVEN**2)+25540./(4.1E9-WAVEN**2)) RETURN END FUNCTION MAP1(XOLD,FOLD,NOLD,XNEW,FNEW,NNEW) DIMENSION XOLD(1),FOLD(1),XNEW(1),FNEW(1) L=2 LL=0 DO 50 K=1,NNEW 10 IF(XNEW(K).LT.XOLD(L))GO TO 20 L=L+1 IF(L.GT.NOLD)GO TO 30 GO TO 10 20 IF(L.EQ.LL)GO TO 50 IF(L.EQ.2)GO TO 30 IF(L.EQ.3)GO TO 30 L1=L-1 IF(L.GT.LL+1.OR.L.EQ.3)GO TO 21 IF(L.GT.LL+1.OR.L.EQ.4)GO TO 21 CBAC=CFOR BBAC=BFOR ABAC=AFOR IF(L.EQ.NOLD)GO TO 22 GO TO 25 21 L2=L-2 D=(FOLD(L1)-FOLD(L2))/(XOLD(L1)-XOLD(L2)) CBAC=FOLD(L)/((XOLD(L)-XOLD(L1))*(XOLD(L)-XOLD(L2)))+ 1(FOLD(L2)/(XOLD(L)-XOLD(L2))-FOLD(L1)/(XOLD(L)-XOLD(L1)))/ 2(XOLD(L1)-XOLD(L2)) BBAC=D-(XOLD(L1)+XOLD(L2))*CBAC ABAC=FOLD(L2)-XOLD(L2)*D+XOLD(L1)*XOLD(L2)*CBAC IF(L.LT.NOLD)GO TO 25 22 C=CBAC B=BBAC A=ABAC LL=L GO TO 50 25 D=(FOLD(L)-FOLD(L1))/(XOLD(L)-XOLD(L1)) CFOR=FOLD(L+1)/((XOLD(L+1)-XOLD(L))*(XOLD(L+1)-XOLD(L1)))+ 1(FOLD(L1)/(XOLD(L+1)-XOLD(L1))-FOLD(L)/(XOLD(L+1)-XOLD(L)))/ 2(XOLD(L)-XOLD(L1)) BFOR=D-(XOLD(L)+XOLD(L1))*CFOR AFOR=FOLD(L1)-XOLD(L1)*D+XOLD(L)*XOLD(L1)*CFOR WT=0. IF(ABS(CFOR).NE.0.)WT=ABS(CFOR)/(ABS(CFOR)+ABS(CBAC)) A=AFOR+WT*(ABAC-AFOR) B=BFOR+WT*(BBAC-BFOR) C=CFOR+WT*(CBAC-CFOR) LL=L GO TO 50 30 IF(L.EQ.LL)GO TO 50 L=MIN0(NOLD,L) C=0. B=(FOLD(L)-FOLD(L-1))/(XOLD(L)-XOLD(L-1)) A=FOLD(L)-XOLD(L)*B LL=L 50 FNEW(K)=A+(B+C*XNEW(K))*XNEW(K) MAP1=LL-1 RETURN END