PROGRAM PLOTSYN c revised 2dec93 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 VAUE IN EACH PANEL C WNEW1 IS A NEW STARTING WAVELENGTH C WNEW2 IS A NEW STOPPING WAVELENGTH C TICKTOP IS THE SIZE AND DIRECTION OF TICK MARKS AT THE TOP OF THE PLOT C TICKBOT IS THE SIZE AND DIRECTION OF TICK MARKS AT THE BOTTOM OF THE PLOT C DEFAULT IS -0.15 AND +0.15 C SMOOTH IS A SMOOTHING PARAMETER TO BE TRANSMITTED TO OBS SUBROUTINES C IT WOULD GENERALLY BE THE FWHM IN POINT NUMBERS OF A GAUSSIAN C IF NEGATIVE IT IS THE CENTRAL WEIGHT FOR THREE POINT SMOOTHING C DOPOBS IS A DOPPLER SHIFT IN KM/S FOR THE OBSERVED SPECTRA C DOPCALC IS A DOPPLER SHIFT IN KM/S FOR THE CALCULATED SPECTRUM C DOPTERR IS A DOPPLER SHIFT IN KM/S FOR TERRESTRIAL SPECTRUM OR LABELS C SCALOBS IS A FACTOR BY WHICH AN OBSERVED SPECTRUM IS TO BE SCALED C ZEROOBS IS A ZERO LEVEL CORRECTION TO AN OBSERVED SPECTRUM C RMIN2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMIN2 C RMAX2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMAX2 C XOFFSET IS THE NUMBER OF INCHES THE PLOT IS DISPLACED IN X C SCALOB2 IF 0 = SCALOBS C IF NOT 0 SCALOBS IS THE SCALING FACTOR FOR THE BEGINNING AND C SCALOB2 IS THE SCALING FACTOR FOR THE END AND C INTERMEDIATE VALUES ARE LINEARLY INTERPOLATED C AXISWT IS THE LINE WEIGHT FOR THE AXES =1,2,3,12,OR 23 DEFAULT=1 C -1 MEANS NO AXIS COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WAVE,WBEGDOP REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG COMMON /CELL/MAXCEL,IFCELL(40000) REAL*8 Q2(40) C REAL*4 MESSAGE(20,9),ASYNTH(64),TURBV,ALINEC(64) REAL*4 ASYNTH(64),TURBV,ALINEC(64) CHARACTER*79 MESSAGE(9) INTEGER VLO,VUP CCRAY REAL*8 WORDS(3) REAL*4 WORDS(6) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 DIMENSION IFPANL(80) COMMON /HEADERDATA/IDATE(3),ITIME(2),JOBID(2),USERID(2), 1FILENAME(2) REAL*8 USERID,FILENAME CHARACTER*9 HEADERDATA(5) CHARACTER*6 WW6,STRING6 CHARACTER*9 STRING9 DATA IFPANL/80*1/ C CALL FILEREP C CALL BEGTIME C CALL RDYOUTF(6,0) READ(5,1001)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1,NOWAVE, 1NOCALC,NOLABY 1001 FORMAT(10I8) WRITE(6,1002)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1, 1NOWAVE,NOCALC,NOLABY 1002 FORMAT(1X,10I8/' IFLABL IFABSO IFCONT IFGRID IFDLIN', 1' IFLOG JUST1 NOWAVE NOCALC NOLABY') READ(5,1001) READ(5,1001)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IRNRL, 1IFPROC,IFSIRUV WRITE(6,1003)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, 1IFPROC,IFSIRUV 1003 FORMAT(1X,10I8/' IFNOAX IFMU NOPRNT IFKPNO IFKPK', 1' IFSACP IFHAWA IFNRL IFPROC IFSIRUV') 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 1005 FORMAT(8F10.3) WRITE(6,1006)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX 1006 FORMAT(1X,8F10.3/75H YSCALE XSCALE WEAK PANEL CYCLE 1S OFFSET RMIN RMAX) READ(5,1001) READ(5,1007)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC 1007 FORMAT(E10.3,7F10.3) WRITE(6,1008)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC 1008 FORMAT(1PE10.3,0P7F10.3/79H TOP WNEW1 WNEW2 TICKTOP 1 TICKBOT SMOOTH DOPOBS DOPCALC ) READ(5,1001) READ(5,1027)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1AXISWT 1027 FORMAT(8F10.3) WRITE(6,1028)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1AXISWT 1028 FORMAT(8F10.3/79H DOPTERR SCALOBS ZEROOBS RMIN2 RMAX2 1 XOFFSET SCALOB2 AXISWT ) 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) C OPEN(UNIT=55,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') IF(NOCALC.EQ.1)GO TO 207 C OPEN(UNIT=7,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') REWIND 7 IF(IFOPAC.NE.0)GO TO 205 READ(7)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF,NMU,XMU,NEDGE, 1WLEDGE NMU2=NMU+NMU MUNMU=MU+NMU WRITE(6,4)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF 4 FORMAT(F10.1,F10.3,3X,74A1/F12.4,F10.1,2I10) IFVAC=1 IF(TITLE(74).EQ.1HA)IFVAC=0 C WBEGIN IS THE FIRST CALCULATED WAVELENGTH C WSTART IS THE FIRST PLOTTED WAVELENGTH WSTART=WBEGIN RATIO=1.+1./RESOLU WEND=WBEGIN*RATIO**(NWL-1) IWEND=WEND*10.+.5 WEND=FLOAT(IWEND)/10. IWSTART=WBEGIN*10.+.5 WSTART=FLOAT(IWSTART)/10. IF(WNEW1.EQ.0.)WNEW1=WSTART IF(WNEW2.EQ.0.)WNEW2=WEND GO TO 207 205 CONTINUE READ(7)WBEGIN,RESOLU,WLEND,NWL,NRHOX,LINOUT,TURBV,IFVAC READ(7) WRITE(6,214)WBEGIN,RESOLU,NWL,NRHOX,IFVAC 214 FORMAT(F10.3,F10.1,3I10) IWSTART=WBEGIN*10.+.5 WSTART=FLOAT(IWSTART)/10. RATIO=1.+1./RESOLU WEND=WBEGIN*RATIO**(NWL-1) IWEND=WEND*10.+.5 WEND=FLOAT(IWEND)/10. IF(WNEW1.EQ.0.)WNEW1=WBEGIN IF(WNEW2.EQ.0.)WNEW2=WEND 207 CONTINUE IF(IFLABL.GT.0.AND.NOCALC.EQ.0)THEN DO 2207 I=1,NWL 2207 READ(7) 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) 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 ENCODE(6,2993,WW6)WW 2993 FORMAT(F6.1) ENCODE(9,2991,HEADERDATA(1))USERID ENCODE(9,3992,HEADERDATA(2))JOBID 3992 FORMAT(A4,A4) ENCODE(9,3992,HEADERDATA(3))ITIME ENCODE(9,3993,HEADERDATA(4))IDATE 3993 FORMAT(A4,A4,A1) ENCODE(9,2991,HEADERDATA(5))FILENAME 2991 FORMAT(A8,A1) c canon is 0.5 higher than xerox THESE ARE CANON CANON=0. CANON=.5 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(WW6,-.2,12.00-OFFSET+CANON) CALL STRINGY10(WW6,23.6,12.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),-.25,11.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(3),-.40,11.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(4),-.55,11.00-OFFSET+CANON) CALL STRINGY(HEADERDATA(5),-.70,11.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 END=(W2-W1)*10.*XSCALE 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 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(WW6,'(F6.1)')WAVE CALL STRINGX2(WW6,X-.4,-.3) ENDIF IF(IFNOAX.NE.1.AND.XSCALE.LT..2)THEN IWAVE=WAVE WRITE(WW6,'(I6)')IWAVE CALL STRINGX2(WW6,X-.6,-.3) ENDIF IF(IFGRID.EQ.0)GO TO 11 CALL JUMP TO (X,0.) CALL WEIGHT(12) CALL LINE TO (X,YTOP) CALL WEIGHT(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 ENCODE(6,2994,STRING6)R C 2994 FORMAT(F2.1) C CALL STRINGX2(STRING6,-.23,Y) CC CALL BCDX(1,R,2,6H(F2.1),.15,-.23,Y) C CALL WEIGHT(MINWT) C ENCODE(6,2995,STRING6)R C 2995 FORMAT(F3.2) C 613 CALL STRINGX2(STRING6,-.6,Y) CC 613 CALL BCDX(1,R/10.+.9,3,6H(F3.2),.15,-.6,Y) C CALL WEIGHT(12) C ENCODE(6,1313,STRING6)RMAX C CALL STRINGX2(STRING6,-.9,Y-.05) C CALL WEIGHT(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) CALL STRINGX2(' .@ @ @ @ 98 ',-.88,YTOP*.8) CALL STRINGX2(' .@ @ @ @ 97 ',-.88,YTOP*.7) CALL STRINGX2(' .@ @ @ @ 96 ',-.88,YTOP*.6) CALL STRINGX2(' .@ @ @ @ 95 ',-.88,YTOP*.5) CALL STRINGX2(' .@ @ @ @ 94 ',-.88,YTOP*.4) CALL STRINGX2(' .@ @ @ @ 93 ',-.88,YTOP*.3) CALL STRINGX2(' .@ @ @ @ 92 ',-.88,YTOP*.2) CALL STRINGX2(' .@ @ @ @ 91 ',-.88,YTOP*.1) CALL STRINGX2(' .@ @ @ @ 90 ',-.88,YTOP*.0) GO TO 17 ENDIF 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)ENCODE(6,1313,STRING6)R C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)R ENCODE(6,1313,STRING6)R IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)R IF(I.GT.1)Y=Y-.03 IF(YSCALE.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 ENCODE(6,1313,STRING6)RMAX C IF(RMAX-RMIN.GE..5)ENCODE(6,1313,STRING6)RMAX 1313 FORMAT(F6.1) C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)RMAX IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)RMAX 1314 FORMAT(F6.2) IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,YTOP-.08) IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,YTOP-.16) 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 ENCODE(6,1314,STRING6)R CALL STRINGX2(STRING6,-0.9,Y) 15 CONTINUE 17 IF(IFGRID.EQ.0)GO TO 20 C IF(IFGRID.EQ.1)THEN IF(XSCALE.LT.1.)GO TO 20 C PLOT GRID XGRID=.1 IF(XSCALE.EQ.4.)XGRID=.08 IF(XSCALE.EQ.8.)XGRID=.08 NGRID=END/XGRID DO 18 I=1,NGRID X=FLOAT(I)*XGRID CALL JUMP TO (X,0.) CALL WEIGHT(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 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) IF(NSKIP.EQ.0)GO TO 221 DO 220 I=1,NSKIP 220 READ(7) 221 N1=NSKIP+1 WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) IF(IFOPAC.GT.0)THEN READ(7) DO 223 IWL=N1,NWL READ(7)(ASYNTH(J),J=1,IFOPAC) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 223 IF(WAVE.GT.W2+.0001)GO TO 24 HMAX=AMAX1(HMAX,ASYNTH(IFOPAC)) HMIN=AMIN1(HMIN,ASYNTH(IFOPAC)) 223 CONTINUE GO TO 24 ENDIF C DO 23 IWL=N1,NWL READ(7)(Q2(I),I=1,NMU2) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 23 IF(WAVE.GT.W2+.0001)GO TO 24 FREQ=2.997925E17/WAVE HLAM=Q2(MU)*FREQ/WAVE IF(Q2(MU).GT.Q2(MUNMU))HLAM=Q2(MUNMU)*FREQ/WAVE HMAX=AMAX1(HMAX,HLAM) HMIN=AMIN1(HMIN,HLAM) IF(IFCONT.EQ.0)GO TO 23 CONT=Q2(MUNMU)*FREQ/WAVE HMAX=AMAX1(HMAX,CONT) HMIN=AMIN1(HMIN,CONT) 23 CONTINUE C 24 WRITE(6,25)HMIN,HMAX 25 FORMAT(1P2E12.3) C IF(NOLABY.EQ.1)GO TO 270 C ENCODE(9,3535,STRING9)HMAX C CALL STRINGY2(STRING9,END+.6,YTOP-1.2) C ENCODE(9,3535,STRING9)HMIN C CALL STRINGY2(STRING9,END+.6,YTOP-2.8) 270 CONTINUE IF(TOP.GT.0.)HMAX=TOP IF(IFLOG.EQ.0)GO TO 30 IF(HMAX.EQ.0.)GO TO 30 HMAXL=ALOG10(HMAX) N=(HMAXL+CYCLES/10.-.001)/(CYCLES/10.) HMAXL=FLOAT(N)*CYCLES/10. IF(TOP.GT.0.)HMAXL=ALOG10(TOP) HMINL=HMAXL-CYCLES HMAX=10.**HMAXL DO 26 I=1,11 Y=FLOAT(I-1)*YTOP/10. H=HMINL+FLOAT(I-1)*CYCLES/10. ENCODE(6,1314,STRING6)H CALL STRINGX2(STRING6,-0.9,Y) 26 CONTINUE GO TO 30 27 IF(IFLOG.EQ.0)GO TO 30 RMAXL=ALOG10(RMAX) RMINL=RMAXL-CYCLES C PLOT OBSERVED SPECTRUM C READS FROM 55 30 CALL OBSERV C READS FROM 56 CALL OBSERV1 C READS FROM 57 CALL OBSERV2 C READS FROM 60 IF(IFKPNO.GT.0)CALL OBSKPNO(IFKPNO) C READS FROM 61 IF(IFKPK.GT.0)CALL OBSKPK(IFKPK) C READS FROM 62 IF(IFSACP.GT.0)CALL OBSSACP(IFSACP) C READS FROM 63 IF(IFHAWA.GT.0)CALL OBSHAWA(IFHAWA) C READS FROM 64 IF(IFNRL.GT.0)CALL OBSNRL(IFNRL) C READS FROM 65 IF(IFPROC.GT.0)CALL OBSPROC(IFPROC) C READS FROM 66 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) IF(NOCALC.EQ.1)GO TO 50 IF(IFCONT.EQ.3)GO TO 735 C PLOT SPECTRUM REWIND 7 READ(7) NSKIP= LOG(W1/WBEGIN)/ LOG(RATIO)-2. C NSKIP=ALOG(W1/WBEGIN)/ALOG(RATIO)-2. NSKIP=MAX0(NSKIP,0) IF(NSKIP.EQ.0)GO TO 231 DO 230 I=1,NSKIP 230 READ(7) 231 N1=NSKIP+1 ISTART=0 CALL WEIGHT(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) IF(WAVE.LT.W1)GO TO 33 IF(WAVE.GT.W2+.0001)GO TO 34 FREQ=2.997925E17/WAVE HLAM=Q2(MU)*FREQ/WAVE CONT=Q2(MUNMU)*FREQ/WAVE C KEEPS EMISSION BELOW CONTINUUM C IF(IFABSO.EQ.0.AND.HLAM.GT.CONT)HLAM=CONT IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN)/(RMAX-RMIN)*YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* 1YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP X=(WAVE-W1)*10.*XSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* 1(YTOP-YOLD) IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) ISTART=1 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) IF(WAVE.LT.W1)GO TO 733 IF(WAVE.GT.W2+.0001)GO TO 734 FREQ=2.997925E17/WAVE HLAM=Q2(MU)*FREQ/WAVE CONT=Q2(MUNMU)*FREQ/WAVE 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)ENCODE(9,3535,STRING9)CONT IF(IFABSO.EQ.1)ENCODE(9,3535,STRING9)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) 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) IF(WAVE.LT.W1)GO TO 43 IF(WAVE.GT.W2+.0001)GO TO 44 FREQ=2.997925E17/WAVE CONT=Q2(MUNMU)*FREQ/WAVE IF(IFLOG.EQ.0)Y=CONT/HMAX*YTOP IF(IFLOG.EQ.1)Y=(ALOG10(CONT)-HMINL)/CYCLES*YTOP X=(WAVE-W1)*10.*XSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* 1(YTOP-YOLD) IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) ISTART=1 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 IF(IFLABL.EQ.0)GO TO 100 IF(NOCALC.EQ.1)GO TO 336 PRINT 1111,NWL,NSKIP 1111 FORMAT(2I10) C IF(NSKIP.EQ.0)GO TO 336 C DO 335 I=1,NSKIP C 335 READ(7) 336 CONTINUE REWIND 93 ILABL=MOD(IFLABL,10) IF(ILABL.EQ.1)CALL LABEL1 IF(ILABL.EQ.2)CALL LABEL2 IF(ILABL.EQ.3)CALL LABEL3 IF(ILABL.EQ.4)CALL LABEL4 IF(ILABL.EQ.5)CALL LABEL5 IF(ILABL.EQ.6)CALL LABEL6 IF(ILABL.EQ.7)CALL LABEL7(IFOPAC) IF(ILABL.EQ.8)CALL LABEL8 IF(ILABL.EQ.9)CALL LABEL9 100 CONTINUE CALL FIN(70) C CALL ENDTIME CALL EXIT END SUBROUTINE OBSERV RETURN END SUBROUTINE OBSERV1 RETURN END SUBROUTINE OBSERV2 RETURN END SUBROUTINE OBSKPNO(IFKPNO) C PRELIMINARY KPNO SOLAR ATLAS BY BRAULT AND TESTERMAN C IFKPNO=1 NORMAL PLOT WEIGHT 1 C IFKPNO=2 NORMAL PLOT WEIGHT 12 C IFKPNO=3 NORMAL PLOT WEIGHT 12 PLUS 10X WEIGHT 1 C IFKPNO=10+ABOVE PLOT LIMB C COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W C THE DATA ARE REREAD EACH TIME TO SAVE STORAGE AND ALLOW PLOTTING C WITH OTHER ATLASES IF(W2.LT.268.)RETURN IF(W1.GE.293.)RETURN OPEN(UNIT=63,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') SMAX=4.E7 ISTART=0 CALL WEIGHT(2) IF(IFHAWA.EQ.2)CALL WEIGHT(MINWT) I1=(W1-268.)*2000.+1. I2=(W2-268.)*2000.+1. I1=MAX0(I1,1) I2=MIN0(I2,50000) IF(I1.GT.0)THEN NSKIP=I1-1 DO 13 ISKIP=1,NSKIP 13 READ(63) ENDIF DO 14 I=I1,I2 W=268.+FLOAT(I-1)*.0005 X=(W-W1)*XSCALE*10. READ(63)S Y=S/SMAX*3.125*YSCALE IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 CALL LINE TO (X,Y) 14 CONTINUE CALL WEIGHT(MINWT) CLOSE(UNIT=63) 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W COMMON /WISI/SI(866000) C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 9 IREAD=1 OPEN(UNIT=65,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') READ(65)SI 9 CONTINUE IF(W2.LT.314.)RETURN IF(W1.GT.747.)RETURN CALL WEIGHT(2) ISTART=0 I1=(W1-314.)*2000. I1=MAX0(I1,1) DO 14 I=I1,866000 W=FLOAT(I-1)*.0005D0+314.D0 IF(W.LT.W1)GO TO 14 IF(W.GT.W2)GO TO 15 X=(W-W1)*XSCALE*10. Y=SI(I)/100.*3.125*YSCALE IF(Y.EQ.0.)THEN ISTART=0 GO TO 14 ENDIF IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 CALL LINE TO (X,Y) 14 CONTINUE 15 CALL WEIGHT(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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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=O 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W,WCUT DIMENSION WCUT(7) CCRAY COMMON /WISI/WI(100000),SI(100000) C COMMON /WISI/WI(450000),SI(450000) COMMON /WISI/WI(400000),SI(400000) C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME DATA WCUT/329.897,378.2914,401.965,473.8,576.5,753.9,999.7/ DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 9 IREAD=1 OPEN(UNIT=68,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') NIN=0 DO 4 I=1,1137795 C W IS THE SOLAR AIR WAVELENGTH INCLUDING THE GRAVITATIONAL REDSHIFT C S IS THE PSEUDO-RESIDUAL FLUX READ(68,END=5)W,S C REMOVE GRAVITATIONAL RED SHIFT W=W*(1.D0-0.636D0/299792.458D0) W=W*(1.D0+DOPOBS/299792.458D0) IF(W.LT.WNEW1)GO TO 4 IF(W.GT.WNEW2)GO TO 5 NIN=NIN+1 CCRAY IF(NIN.GT.100000)CALL ABORT IF(NIN.GT.450000)CALL ABORT WI(NIN)=W SI(NIN)=(S-ZEROOBS)*SCALOBS 4 CONTINUE 5 CONTINUE 9 IF(NIN.EQ.0)RETURN CALL WEIGHT(2) IF(IFSUNF.EQ.2.OR.IFSUNF.EQ.12)CALL WEIGHT(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 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(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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W,WCUT DIMENSION WCUT(8) COMMON /WISI/WI(450000),SI(450000) C COMMON /WISI/WI(400000),SI(400000) CCRAY COMMON /WISI/WI(300000) DATA WCUT/8*0./ DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 9 IREAD=1 OPEN(UNIT=69,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED') NIN=0 DO 4 I=1,2037512 C W IS THE SOLAR AIR WAVELENGTH INCLUDING THE GRAVITATIONAL REDSHIFT C S IS THE PSEUDO-RESIDUAL INTENSITY READ(69,END=5)W,S C REMOVE GRAVITATIONAL RED SHIFT W=W*(1.D0-0.636D0/299792.458D0) W=W*(1.D0+DOPOBS/299792.458D0) IF(W.LT.WNEW1)GO TO 4 IF(W.GT.WNEW2)GO TO 5 NIN=NIN+1 IF(NIN.GT.450000)CALL ABORT CCRAY IF(NIN.GT.300000)CALL ABORT CCRAY IW=(W-WNEW1)*100000. CCRAY S=AMIN1(AMAX1(S,0.),.999999) CCRAY WI(NIN)=FLOAT(IW)+S WI(NIN)=W C SI(NIN)=S SI(NIN)=(S-ZEROOBS)*SCALOBS 4 CONTINUE 5 CONTINUE 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT 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 MINWT=ABS(AXISWT) 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 IFFTS=1 WEIGHT=2 C IFFTS=2 WEIGHT=1 C IFFTS=3 PLOT TWICE NORMAL WITH WEIGHT=2 AND 10 TIMES YSCALE WITH WEIGHT=1 C IFFTS=4 PLOT TWICE NORMAL WITH WEIGHT=1 AND 10 TIMES YSCALE WITH WEIGHT=1 COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W C COMMON /WISI/WI(450000),SI(450000) COMMON /WISI/WI(400000),SI(400000) C COMMON MUST BE REMOVED TO PLOT TWO SPECTRA AT THE SAME TIME DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 9 IREAD=1 OPEN(UNIT=71,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED', 1BLOCKSIZE=12000,RECORDSIZE=3,RECORDTYPE='FIXED') OPEN(UNIT=72,SHARED,READONLY,TYPE='OLD',FORM='UNFORMATTED', 1BLOCKSIZE=12000,RECORDSIZE=3,RECORDTYPE='FIXED') READ(71)W,NFTS READ(72)W,NFTS NIN=0 DO 4 I=1,NFTS C W IS THE AIR WAVELENGTH C IF IT IS A SOLAR SPECTRUM W INCLUDES THE GRAVITATIONAL REDSHIFT C S IS THE PSEUDO-RESIDUAL FLUX OR INTENSITY READ(71)W,S1 READ(72)W,S2 C REMOVE GRAVITATIONAL RED SHIFT C W=W*(1.D0-0.636/299792.458D0) W=W*(1.D0+DOPOBS/299792.458D0) IF(W.LT.WNEW1)GO TO 4 IF(W.GT.WNEW2)GO TO 5 NIN=NIN+1 IF(NIN.GT.450000)CALL ABORT WI(NIN)=W S2=S2-ZEROOBS S1=S1-ZEROOBS SI(NIN)=1. IF(S1.GT.0.)SI(NIN)=S2/S1 SI(NIN)=SI(NIN)*SCALOBS 4 CONTINUE 5 CONTINUE 9 IF(NIN.EQ.0)RETURN CALL WEIGHT(2) IF(IFFTS.EQ.2.OR.IFFTS.EQ.12)CALL WEIGHT(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.LT.3)RETURN ISTART=0 DO 24 I=1,NIN W=WI(I) IF(W.LT.W1)GO TO 24 IF(W.GT.W2)GO TO 25 X=(W-W1)*XSCALE*10. XNEW=X S=SI(I) Y=(S-.9)/(1.0-.9)*3.125*YSCALE YNEW=Y IF(ISTART.EQ.0)THEN IF(Y.LT.0.)Y=0. GO TO 240 ENDIF IF(YNEW.GE.0..AND.YOLD.GE.0.)GO TO 240 Y=0. IF(YNEW.LT.0..AND.YOLD.LT.0.)GO TO 240 IF(YOLD.LE.0.)GO TO 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*(0.-YOLD) GO TO 240 239 X=XOLD+(XNEW-XOLD)/(YNEW-YOLD)*YNEW 240 IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 XOLD=XNEW YOLD=YNEW CALL LINE TO (X,Y) 24 CONTINUE 25 CONTINUE RETURN END SUBROUTINE LABEL1 C LABELS COMPUTED SPECTRUM C IFLABL=1 25/INCH TWO ROWS, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=11 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE PARTIAL LABELS C IFLABL=21 12.5/INCH ONE ROW, ATMOSPHERIC LINES HAVE FULL LABELS C IFLABL=31 12.5/INCH LOWER ROW ATOMS UPPER ROW MOLECULES COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG COMMON /CELL/MAXCEL,IFCELL(40000,2) REAL*8 Q2(40) INTEGER VLO,VUP COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 DIMENSION NAMEAF(999),MOLAF(999) REAL*8 NAME,NAMEAF CHARACTER*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*53 STRING53 CHARACTER*10 LABEL10,LABEL10P CALL NAMEMOL(NAMEAF,MOLAF) C CELLIN=12.5 CELLIN=8. C IF(IFLABL.EQ.1)CELLIN=25. IF(IFLABL.EQ.1)CELLIN=16. MAXCEL=40000 DO 333 I=1,MAXCEL IFCELL(I,2)=0 333 IFCELL(I,1)=0 READ(93)NLINES PRINT 334,NLINES,W1,W2 334 FORMAT(I10,2F10.4) DO 70 ILINE=1,NLINES READ(93)LINDAT8,LINDAT WAVEL=WLVAC IF(IFVAC.EQ.0)WAVEL=ABS(WL) WAVEI=WAVEL IF(REF.EQ.4HAFGL)THEN VDOP=GS WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) ENDIF WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 RESID=CENTER/CONCEN FREQ=2.997925E17/WLVAC CENTER=CENTER*FREQ/WLVAC CONCEN=CONCEN*FREQ/WLVAC IF(NOPRNT.EQ.0) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X, A8,A2, A8,A2, 1F12.4,F9.3,1P2E11.3/ 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. 1RESID.GT..800)GO TO 70 IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. 1RESID.GT..030)GO TO 70 IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. 1RESID.GT..100)GO TO 70 IF(IFABSO.EQ.0)GO TO 61 C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP C RESID=Y/YTOP 61 CONTINUE MROW=1 IF(CODE.GT.100.AND.IFLABL.EQ.31)MROW=2 COLON=' ' IF(WL.LT.0.)COLON=':' IRESID=RESID*1000.+.5 C NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1. I=NCELL-1 IF(I.GT.0.AND.IFCELL(NCELL,MROW).EQ.1.AND.IFCELL(I,MROW).EQ.0.AND. 1IFCELL(NCELL+1,MROW).EQ.1)GO TO 63 DO 62 I=NCELL,MAXCEL IF(IFCELL(I,MROW).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I IFCELL(NCELL,MROW)=1 XCELL=FLOAT(NCELL)/CELLIN IF(IFLABL.NE.1)XCELL=XCELL-.04 YCELL=YTOP+.1 IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)THEN YCELL=YTOP+2.81 IF(IFCELL(NCELL-1,MROW).EQ.0)THEN IFCELL(NCELL-1,MROW)=1 IFCELL(NCELL,MROW)=0 YCELL=YTOP+.1 XCELL=FLOAT(NCELL-1)/CELLIN ENDIF ENDIF C IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+2.00 C IF(IFLABL.EQ.1.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+1.80 C IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+1.80 C IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+2.40 IF(IFLABL.EQ.31.AND.CODE.GT.100.)YCELL=YTOP+2.81 XWL=(WAVEL-W1)*10.*XSCALE IELO=ELO I=WAVEI*10. RWL=WAVEI-FLOAT(I)*.1 IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)GO TO 70 IWL=RWL*10000.+.5 IF(IWL.EQ.1000)IWL=0 C IF(REF.EQ.4HAFGL)THEN ISOAF=NELION MOL=MOLAF(ISOAF) NAME=NAMEAF(ISOAF) WRITE(STRING21,'(I3.3,1X,A6,I5,I4,2X)')IWL,NAME,IELO,IRESID C IF(IFLABL.NE.21)GO TO 66 WRITE(LABAF,'(A8,A2,A8,A2,A8,A2,A8)')LABEL,LABELP,OTHER1,OTHER2(1) CCCCCCC I38=2 L38=LABAF(1:2) DO 6100 I=3,38 IF(LABAF(I-2:I).EQ.' ')GO TO 6100 I38=I38+1 L38=L38(1:I38-1)//LABAF(I:I) 6100 CONTINUE L34=L38(1:34) GO TO 6800 C C CCCCCCC C GO TO (6100,6200,6300,6400,6500,6600,6700),MOL CC H20 CCSAMPLE FROM AFCRL TAPE CC2345678901234567890123456789012345678901234567890123456789012345678901234567890 CC17879.736 0.174E-26.0940 206.301 4 3 1 3 2 2 1 0 4 0 0 0 77 161 1 CC JUP KAUPKCUP V1UPV2UPV3UP CC JLO KALOKCLO V1LOV2LOV3LO CC NEW HITRAN FORMAT CC 12345678901234567890123456789012345678 CC 4 3 1 3 2 2 104 000 CC CC READ(11,1,END=145)WAVENO,STRENGTH,WIDTH,E1,JUP,KAUP,KCUP,JLO, CC 1KALO,KCLO,V1UP,V2UP,V3UP,V1LO,V2LO,V3LO,DATE,ISO,MOL CC 1 FORMAT(F10.3,E10.3,F5.4,F10.3,3I3,1X,3I3,2X,3I2,1X,3I2,A4,I4,I3) CC 6100 L34=LABAF(1:21)//LABAF(23:23)//LABAF(25:25)//LABAF(27:28)// CC 1LABAF(30:30)//LABAF(32:32)//LABAF(34:34) C 6100 L34=LABAF(7:7)//LABAF(1:6)//LABAF(10:16)//LABAF(24:28)// C 1LABAF(33:36) C GO TO 6800 CC CO2 C 6200 L34=LABAF(3:4)//LABAF(6:6)//LABAF(8:8)//LABAF(10:10)// C 1LABAF(12:14)//LABAF(19:19)//LABAF(21:21)//LABAF(23:23)// C 2LABAF(25:25)//LABAF(27:27)//LABAF(29:35) C GO TO 6800 CC O3 C 6300 L34=LABAF(1:21)//LABAF(23:23)//LABAF(25:25)//LABAF(27:28)// C 1LABAF(30:30)//LABAF(32:32)//LABAF(34:34) C GO TO 6800 CC N20 C 6400 L34=LABAF(3:4)//LABAF(6:6)//LABAF(8:8)//LABAF(10:10)// C 1LABAF(19:19)//LABAF(21:21)//LABAF(23:23)//LABAF(25:25)// C 2LABAF(29:34) C GO TO 6800 CC CO C 6500 L34=LABAF(7:8)//'-'//LABAF(16:16)//LABAF(30:34) C GO TO 6800 CC CH4 C 6600 L34=LABAF(1:34) C GO TO 6800 CC O2 CC 12345678901234567890123456789012345678 CC R15Q16 B2 X0 CC 6700 L34=LABAF(17:18)//LABAF(8:8)//'-'//LABAF(19:19)//LABAF(16:16)// CC 1LABAF(28:34)//LABAF(20:25) C 6700 L34=LABAF(25:28)//'-'//LABAF(35:36)//LABAF(10:16) 6800 CONTINUE IF(CODE.EQ.10108.)L34=L34(1:6)//L34(8:13)//L34(15:19) IF(CODE.EQ.808.) 1 L34=L34(1:5)//'-'//L34(8:10)//L34(16:17)//L34(12:14) STRING53=STRING21(1:19)//L34 CALL STRINGY(STRING53,XCELL,YCELL) CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) IF(NOPRNT.EQ.2) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,6802)STRING53 6802 FORMAT(79X,A53) GO TO 70 ENDIF C IF(CODE.LT.100.)GO TO 64 PQR=1HP IF(XJP.GT.XJ)PQR=1HR IF(XJP.EQ.XJ)PQR=1HQ ICODE=CODE J=XJ WRITE(LABEL10,'(A8,A2)')LABEL WRITE(LABEL10P,'(A8,A2)')LABELP READ(LABEL10,'(A1)')AMULT IF(AMULT.NE.1H3.AND.AMULT.NE.1H1)THEN READ(LABEL10,'(1X,I2)')VLO READ(LABEL10P,'(1X,I2)')VUP ELSE READ(LABEL10,'(2X,I2)')VLO READ(LABEL10P,'(2X,I2)')VUP ENDIF IDWL=NINT(DWL*10000.) IDGFLOG=NINT(DGFLOG*1000.) WRITE(STRING9,'(SPI4,SPI5)')IDWL,IDGFLOG C IF(IFLABL.NE.31.AND.STRING9.EQ.' +0 +0')STRING9=' ' IF(STRING9.EQ.' +0 +0')STRING9=' ' 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) CALL STRINGY(STRING33,XCELL,YCELL) GO TO 67 64 CONTINUE C IF(IFLABL.EQ.31)THEN IDWL=NINT(DWL*10000.) IDGFLOG=NINT(DGFLOG*1000.) WRITE(STRING9,'(SPI4,SPI5)')IDWL,IDGFLOG C IF(IFLABL.NE.31.AND.STRING9.EQ.' +0 +0')STRING9=' ' IF(STRING9.EQ.' +0 +0')STRING9=' ' WRITE(STRING30,7114)IWL,COLON,CODE,IELO,IRESID,STRING9 7114 FORMAT(I3.3,A1,F6.2,I7,I4,A9) CALL STRINGY(STRING30,XCELL,YCELL) C GO TO 67 C ENDIF C WRITE(STRING21,114)IWL,COLON,CODE,IELO,IRESID C 114 FORMAT(I3.3,A1,F6.2,I7,I4) C 66 CONTINUE C CALL STRINGY(STRING21,XCELL,YCELL) 67 CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) IF(NOPRNT.EQ.2) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW IF(NOPRNT.NE.1.AND.NOPRNT.NE.7)WRITE(6,65)STRING21 65 FORMAT(107X,A21) IF(NOPRNT.NE.7)GO TO 70 IF(DWL.EQ.0..AND.DGFLOG.EQ.0..AND.DGAMMAR.EQ.0..AND. 1DGAMMAS.EQ.0..AND.DGAMMAW.EQ.0.)GO TO 70 WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 1CENTER,CONCEN, 2WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 3DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW WRITE(6,65)STRING21 70 CONTINUE 80 CONTINUE RETURN END SUBROUTINE LABEL2 COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG CCRAY COMMON /CELL/MAXCEL,IFCELL(10000) COMMON /CELL/MAXCEL,IFCELL(40000) REAL*8 Q2(40) INTEGER VLO,VUP REAL*4 WORDS(6) CCRAY REAL*8 WORDS(3) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 CCRAY MAXCEL=10000 MAXCEL=40000 DO 333 I=1,MAXCEL 333 IFCELL(I)=0 READ(93)NLINES PRINT 334,NLINES,W1,W2 334 FORMAT(I10,2F10.4) DO 70 ILINE=1,NLINES READ(93)LINDAT8,LINDAT WAVEL=WLVAC IF(IFVAC.EQ.0)WAVEL=ABS(WL) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 RESID=CENTER/CONCEN FREQ=2.997925E17/WLVAC CENTER=CENTER*FREQ/WLVAC CONCEN=CONCEN*FREQ/WLVAC IF(NOPRNT.EQ.0) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X, A8,A2, A8,A2, 1F12.4,F9.3,1P2E11.3/ 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. 1RESID.GT..800)GO TO 70 IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. 1RESID.GT..030)GO TO 70 IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. 1RESID.GT..100)GO TO 70 IF(IFABSO.EQ.0)GO TO 61 C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP C RESID=Y/YTOP 61 CONTINUE COLON=(1H ) IF(WL.LT.0)COLON=1H: IRESID=RESID*1000.+.5 NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 DO 62 I=NCELL,MAXCEL IF(IFCELL(I).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I IF(MOD(NCELL,2).EQ.1)GO TO 6666 IF(IFCELL(NCELL-1).EQ.0)THEN NCELL=NCELL-1 GO TO 6666 ELSE IF(IFCELL(NCELL+1).EQ.0)THEN NCELL=NCELL+1 ENDIF 6666 CONTINUE IFCELL(NCELL)=1 XCELL=FLOAT(NCELL)*.04 YCELL=YTOP+.1 IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 XWL=(WAVEL-W1)*10.*XSCALE IELO=ELO I=WAVEL*10. RWL=WAVEL-FLOAT(I)*.1 IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)GO TO 70 IWL=RWL*10000.+.5 IF(IWL.EQ.1000)IWL=0 IF(CODE.LT.100.)GO TO 64 PQR=1HP IF(XJP.GT.XJ)PQR=1HR IF(XJP.EQ.XJ)PQR=1HQ ICODE=CODE J=XJ C IF(CODE.EQ.106.)THEN IF(CODE.EQ.999.)THEN DECODE(8,4445,LABEL)VLO DECODE(8,4445,LABELP)VUP 4445 FORMAT(1X,I1) ELSE IF(CODE.EQ.606..OR.CODE.EQ.106.01)THEN DECODE(8,4444,LABEL)VLO DECODE(8,4444,LABELP)VUP 4444 FORMAT(2X,I2) ELSE DECODE(8,4443,LABEL)VLO DECODE(8,4443,LABELP)VUP 4443 FORMAT(1X,I2) ENDIF ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID 113 FORMAT(I3.3,A1,I3,I3,1H-,I2,I3,A1,I4) GO TO 66 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID 114 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 C 65 FORMAT(107X,2A8,A5) 65 FORMAT(107X,5A4,A1) CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) 70 CONTINUE 80 CONTINUE RETURN END SUBROUTINE LABEL3 COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG CCRAY COMMON /CELL/MAXCEL,IFCELL(10000) COMMON /CELL/MAXCEL,IFCELL(40000) REAL*8 Q2(40) INTEGER VLO,VUP CCRAY REAL*8 WORDS(3) REAL*4 WORDS(6) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 CCRAY MAXCEL=10000 MAXCEL=40000 DO 333 I=1,MAXCEL 333 IFCELL(I)=0 READ(93)NLINES PRINT 334,NLINES,W1,W2 334 FORMAT(I10,2F10.4) DO 70 ILINE=1,NLINES READ(93)LINDAT8,LINDAT WAVEL=WLVAC IF(IFVAC.EQ.0)WAVEL=ABS(WL) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 RESID=CENTER/CONCEN FREQ=2.997925E17/WLVAC CENTER=CENTER*FREQ/WLVAC CONCEN=CONCEN*FREQ/WLVAC IF(NOPRNT.EQ.0) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X, A8,A2, A8,A2, 1F12.4,F9.3,1P2E11.3/ 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. 1RESID.GT..800)GO TO 70 IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. 1RESID.GT..030)GO TO 70 IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. 1RESID.GT..100)GO TO 70 IF(IFABSO.EQ.0)GO TO 61 C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP C RESID=Y/YTOP 61 CONTINUE COLON=(1H ) IF(WL.LT.0.)COLON=1H: IRESID=RESID*1000.+.5 NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 DO 62 I=NCELL,MAXCEL IF(IFCELL(I).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I IFCELL(NCELL)=1 XCELL=FLOAT(NCELL)*.04 YCELL=YTOP+.1 IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 XWL=(WAVEL-W1)*10.*XSCALE IELO=ELO I=WAVEL*10. RWL=WAVEL-FLOAT(I)*.1 IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)GO TO 70 IWL=RWL*10000.+.5 IF(IWL.EQ.1000)IWL=0 IF(CODE.LT.100.)GO TO 64 PQR=1HP IF(XJP.GT.XJ)PQR=1HR IF(XJP.EQ.XJ)PQR=1HQ ICODE=CODE J=XJ C IF(CODE.EQ.106.)THEN IF(CODE.EQ.999.)THEN DECODE(8,4445,LABEL)VLO DECODE(8,4445,LABELP)VUP 4445 FORMAT(1X,I1) ELSE IF(CODE.EQ.606..OR.CODE.EQ.106.01)THEN DECODE(8,4444,LABEL)VLO DECODE(8,4444,LABELP)VUP 4444 FORMAT(2X,I2) ELSE DECODE(8,4443,LABEL)VLO DECODE(8,4443,LABELP)VUP 4443 FORMAT(1X,I2) ENDIF ENCODE(21,113,WORDS)IWL,COLON,ICODE,VUP,VLO,J,PQR,IRESID 113 FORMAT(I3.3,A1,I3,I3,1H-,I2,I3,A1,I4) GO TO 66 64 ENCODE(21,114,WORDS)IWL,COLON,CODE,IELO,IRESID 114 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 C 65 FORMAT(107X,2A8,A5) 65 FORMAT(107X,5A4,A1) CALL BCDY(6,WORDS,21,8H(5A4,A1),.07,XCELL,YCELL) CCRAY CALL BCDY(3,WORDS,21,8H(2A8,A5),.07,XCELL,YCELL) CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) 70 CONTINUE 80 CONTINUE RETURN END SUBROUTINE LABEL4 RETURN END SUBROUTINE LABEL5 C LABELS ATMOSPHERIC LINES FROM AFCRL LINE LIST C IFLABL=5 25/INCH TWO ROWS C IFLABL=15 12.5/INCH ONE ROW COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI COMMON /CELL/MAXCEL,IFCELL(40000) REAL*4 WORDS(13) CCRAY REAL*8 WORDS(7) CHARACTER*38 LABEL,LABELAF CHARACTER*28 L28 REAL*8 WAIR,W,E,NAME COMMON /AFCRL/WAFCRL(25000),EAFCRL(25000),SAFCRL(25000), 1 LABELAF(25000),MOLAF(25000),ISOAF(25000) REAL*8 WAFCRL,EAFCRL REAL*4 SAFCRL DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 332 IREAD=1 OPEN(UNIT=76,SHARED,READONLY,TYPE='OLD') IF(1.E7/17879.736.GT.WNEW2+.1)RETURN WNEW11=WNEW1-1. DO 310 ILINE=1,180956 READ(76,331)W IF(1.E7/W.GT.WNEW11)GO TO 311 310 CONTINUE RETURN 311 ILINE=ILINE+1 NIN=0 DO 330 I=ILINE,180956 READ(76,331)W,S,WIDTH,E,LABEL,ISO,MOL 331 FORMAT(F10.3,E10.3,F5.4,F10.3,A38,I4,I3) WRITE(6,3331)I,W,S,WIDTH,E,LABEL,ISO,MOL 3331 FORMAT(I10,F11.3,E10.3,F5.4,F10.3,A38,I4,I3) WAIR=1.D7/W/ 1(1.0000834213D0+2406030.D0/(1.30D10-W**2)+15997.D0/(3.89D9-W**2)) IF(WAIR.LT.WNEW1)GO TO 330 IF(WAIR.GT.WNEW2)GO TO 332 NIN=NIN+1 IF(NIN.GT.25000)CALL ABORT WAFCRL(NIN)=WAIR EAFCRL(NIN)=E SAFCRL(NIN)=ALOG10(S) LABELAF(NIN)=LABEL ISOAF(NIN)=ISO MOLAF(NIN)=MOL 330 CONTINUE 332 IF(NIN.EQ.0)RETURN MAXCEL=40000 DO 333 I=1,MAXCEL 333 IFCELL(I)=0 CELLIN=12.5 IF(IFLABL.EQ.5)CELLIN=25. PRINT 334,NIN,W1,W2 334 FORMAT(I10,2F10.4) DO 70 ILINE=1,NIN WAVEL=WAFCRL(ILINE)*(1.D0+DOPTERR/299792.458D0) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 IE=EAFCRL(ILINE) LABEL=LABELAF(ILINE) GO TO (100,200,300,400,500,600,700),MOLAF(ILINE) C H20 100 NAME=(6HH2O ) IF(ISOAF(ILINE).EQ.171)NAME=(6HH2O17 ) IF(ISOAF(ILINE).EQ.181)NAME=(6HH2O18 ) C2345678901234567890123456789012345678901234567890123456789012345678901234567890 C17879.736 0.174E-26.0940 206.301 4 3 1 3 2 2 1 0 4 0 0 0 77 161 1 C JUP KAUPKCUP V1UPV2UPV3UP C JLO KALOKCLO V1LOV2LOV3LO C READ(11,1,END=145)WAVENO,STRENGTH,WIDTH,E1,JUP,KAUP,KCUP,JLO, C 1KALO,KCLO,V1UP,V2UP,V3UP,V1LO,V2LO,V3LO,DATE,ISO,MOL C 1 FORMAT(F10.3,E10.3,F5.4,F10.3,3I3,1X,3I3,2X,3I2,1X,3I2,A4,I4,I3) L28=LABEL(1:21)//LABEL(23:23)//LABEL(25:25)//LABEL(27:28)// 1LABEL(30:30)//LABEL(32:32)//LABEL(34:34) GO TO 800 200 NAME=(6HCO2 ) L28=LABEL(3:4)//LABEL(6:6)//LABEL(8:8)//LABEL(10:10)// 1LABEL(12:14)//LABEL(19:19)//LABEL(21:21)//LABEL(23:23)// 2LABEL(25:25)//LABEL(27:27)//LABEL(29:35) IF(ISOAF(ILINE).EQ.626)GO TO 800 ENCODE(6,201,NAME)ISOAF(ILINE) 201 FORMAT(3HCO2,I3) GO TO 800 300 NAME=(6HO3 ) L28=LABEL(1:21)//LABEL(23:23)//LABEL(25:25)//LABEL(27:28)// 1LABEL(30:30)//LABEL(32:32)//LABEL(34:34) IF(ISOAF(ILINE).EQ.666)GO TO 800 ENCODE(6,301,NAME)ISOAF(ILINE) 301 FORMAT(3HO3 ,I3) GO TO 800 400 NAME=(6HN2O ) L28=LABEL(3:4)//LABEL(6:6)//LABEL(8:8)//LABEL(10:10)// 1LABEL(19:19)//LABEL(21:21)//LABEL(23:23)//LABEL(25:25)// 2LABEL(29:34) IF(ISOAF(ILINE).EQ.446)GO TO 800 ENCODE(6,401,NAME)ISOAF(ILINE) 401 FORMAT(3HN2O,I3) GO TO 800 500 NAME=(6HCO ) L28=LABEL(7:8)//'-'//LABEL(16:16)//LABEL(30:34) IF(ISOAF(ILINE).EQ.26)GO TO 800 IF(ISOAF(ILINE).EQ.27)NAME=(6HCO17 ) IF(ISOAF(ILINE).EQ.28)NAME=(6HCO18 ) IF(ISOAF(ILINE).EQ.36)NAME=(6HCO13 ) GO TO 800 600 NAME=(6HCH4 ) C CANNOT FIT IN WHOLE LABEL. DROP LOWER QUANTUM NUMBERS. L28=LABEL(1:10)//LABEL(20:34) IF(ISOAF(ILINE).EQ.211)GO TO 800 ENCODE(6,601,NAME)ISOAF(ILINE) 601 FORMAT(3HCH4,I3) GO TO 800 700 NAME=(6HO2 ) L28=LABEL(17:18)//LABEL(8:8)//'-'//LABEL(19:19)//LABEL(16:16)// 1LABEL(28:34)//LABEL(20:25) IF(ISOAF(ILINE).EQ.66)GO TO 800 IF(ISOAF(ILINE).EQ.67)NAME=(6HO217 ) IF(ISOAF(ILINE).EQ.68)NAME=(6HO218 ) 800 CONTINUE NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 DO 62 I=NCELL,MAXCEL IF(IFCELL(I).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I C IF(MOD(NCELL,2).EQ.1)GO TO 163 C IF(IFCELL(NCELL-1).EQ.0)THEN C NCELL=NCELL-1 C GO TO 163 C ENDIF C IF(IFCELL(NCELL+1).EQ.0)NCELL=NCELL+1 163 IFCELL(NCELL)=1 XCELL=FLOAT(NCELL)/CELLIN IF(IFLABL.NE.5)XCELL=XCELL-.04 YCELL=YTOP+.1 IF(IFLABL.EQ.5.AND.MOD(NCELL,2).EQ.0)YCELL=YTOP+2.98 XWL=(WAVEL-W1)*10.*XSCALE I=WAFCRL(ILINE) RWL=WAFCRL(ILINE)-FLOAT(I) IWL=RWL*10000.+.5 IF(IWL.EQ.10000)IWL=0 64 ENCODE(50,114,WORDS)IWL,NAME,IE,SAFCRL(ILINE),L28 114 FORMAT(I4,1X,A6,I5,F6.2,A28) 66 IF(NOPRNT.NE.1)WRITE(6,65)WAVEL,WAFCRL(ILINE),EAFCRL(ILINE),WORDS 65 FORMAT(F12.4,F10.3,F10.3,2X,12A4,A2) C 65 FORMAT(F12.4,F10.3,F10.3,2X,6A8,A2) CALL BCDY(13,WORDS,50,9H(12A4,A2),.07,XCELL,YCELL) CCRAY CALL BCDY(7,WORDS,50,8H(6A8,A2),.07,XCELL,YCELL) CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.04,YTOP+.08) 70 CONTINUE 80 CONTINUE RETURN END SUBROUTINE NAMEMOL(MOLNAME,MOLCODE) C IDENTIFIES ISOTOPE CODES FOR AFCRL LINE LIST DIMENSION MOLNAME(999),MOLCODE(999) REAL*8 MOLNAME DO 1 I=1,999 MOLNAME(I)=(6H ) 1 MOLCODE(I)=0 C H2O MOLCODE(161)=1 MOLCODE(162)=1 MOLCODE(181)=1 MOLCODE(171)=1 C CO2 MOLCODE(626)=2 MOLCODE(636)=2 MOLCODE(628)=2 MOLCODE(627)=2 MOLCODE(638)=2 MOLCODE(637)=2 MOLCODE(828)=2 C O3 MOLCODE(666)=3 MOLCODE(668)=3 MOLCODE(686)=3 C N2O MOLCODE(446)=4 MOLCODE(456)=4 MOLCODE(546)=4 MOLCODE(448)=4 MOLCODE(447)=4 C CO MOLCODE( 26)=5 MOLCODE( 36)=5 MOLCODE( 28)=5 MOLCODE( 27)=5 C CH4 MOLCODE(211)=6 MOLCODE(311)=6 MOLCODE(212)=6 C O2 MOLCODE( 66)=7 MOLCODE( 68)=7 MOLCODE( 67)=7 C C H2O MOLNAME(161)=(6HH20 ) MOLNAME(162)=(6HHDO ) MOLNAME(181)=(6HH2O 18) MOLNAME(171)=(6HH2O 17) C CO2 MOLNAME(626)=(6HCO2 ) MOLNAME(636)=(6HCO2 13) MOLNAME(628)=(6HCO2 18) MOLNAME(627)=(6HCO2 17) MOLNAME(638)=(6HCO2 38) MOLNAME(637)=(6HCO2 37) MOLNAME(828)=(6HCO2 88) C O3 MOLNAME(666)=(6HO3 ) MOLNAME(668)=(6HO3 668) MOLNAME(686)=(6HO3 686) C N2O MOLNAME(446)=(6HN2O ) MOLNAME(456)=(6HN2O456) MOLNAME(546)=(6HN2O546) MOLNAME(448)=(6HN2O 18) MOLNAME(447)=(6HN2O 17) C CO MOLNAME( 26)=(6HCO ) MOLNAME( 36)=(6HCO 13 ) MOLNAME( 28)=(6HCO 18 ) MOLNAME( 27)=(6HCO 17 ) C CH4 MOLNAME(211)=(6HCH4 ) MOLNAME(311)=(6HCH4 13) MOLNAME(212)=(6HCH3D ) C O2 MOLNAME( 66)=(6HO2 ) MOLNAME( 68)=(6HO2 18 ) MOLNAME( 67)=(6HO2 17 ) MOLNAME( 77)=(6HO2 77 ) MOLNAME( 78)=(6HO2 78 ) MOLNAME( 79)=(6HO2 88 ) C RETURN END SUBROUTINE LABEL6 RETURN END SUBROUTINE LABEL7(IFOPAC) COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG COMMON /CELL/MAXCEL,IFCELL(40000) REAL*8 Q2(40) REAL*4 ALINEC(64) INTEGER VLO,VUP REAL*4 WORDS(6) CCRAY REAL*8 WORDS(3) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 MAXCEL=40000 DO 333 I=1,MAXCEL 333 IFCELL(I)=0 PRINT 334,W1,W2 334 FORMAT(2F10.4) DO 70 ILINE=1,1000000 READ(7,END=80)LINDAT8,LINDAT,(ALINEC(J),J=1,IFOPAC) WAVEL=WLVAC IF(IFVAC.EQ.0)WAVEL=ABS(WL) WAVEI=WAVEL IF(REF.EQ.4HAFGL)THEN VDOP=GS WAVEL=WAVEL*(1.D0+VDOP/299792.458D0) ENDIF WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 CENTER=ALINEC(IFOPAC) CONCEN=HMAX RESID=CENTER/CONCEN FREQ=2.997925E17/WLVAC C CENTER=CENTER*FREQ/WLVAC C CONCEN=CONCEN*FREQ/WLVAC IF(NOPRNT.EQ.0) 1WRITE(6,99)WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,WLVAC,RESID, 2CENTER,CONCEN, 3WL,NELION,GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2, 4DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW 99 FORMAT(1H0,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,1X, A8,A2, A8,A2, 1F12.4,F9.3,1P2E11.3/ 2 1X,0PF10.4,I4,F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,1X, 3 A8,A2,A8,A2,F7.4,F7.3,3F6.2) C IF(RESID.GT.1.-WEAK.AND.RESID.LT.1.+WEAK)GO TO 70 IF(RESID.LT.WEAK)GO TO 70 IF(CODE.EQ.14.00.AND.WLVAC.GT.152..AND.WLVAC.LT.154..AND. 1RESID.GT..800)GO TO 70 IF(CODE.EQ.12.00.AND.WLVAC.GT.251..AND.WLVAC.LT.253..AND. 1RESID.GT..030)GO TO 70 IF(CODE.EQ.13.00.AND.WLVAC.GT.207..AND.WLVAC.LT.208..AND. 1RESID.GT..100)GO TO 70 IF(IFABSO.EQ.0)GO TO 61 C IF(IFLOG.EQ.0)Y=CENTER/HMAX*YTOP C IF(IFLOG.EQ.1)Y=(ALOG10(CENTER)-HMINL)/CYCLES*YTOP C RESID=Y/YTOP 61 CONTINUE COLON=(1H ) IF(WL.LT.0.)COLON=1H: IRESID=RESID*1000.+.5 NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 DO 62 I=NCELL,MAXCEL IF(IFCELL(I).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I IFCELL(NCELL)=1 XCELL=FLOAT(NCELL)*.04 YCELL=YTOP+.1 IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 XWL=(WAVEL-W1)*10.*XSCALE IELO=ELO I=WAVEI*10. RWL=WAVEI-FLOAT(I)*.1 IF(CODE.EQ.6.00.AND.WLVAC.GT.110..AND.WLVAC.LT.111..AND. 1RESID.GT..100)GO TO 70 IWL=RWL*10000.+.5 IF(IWL.EQ.1000)IWL=0 IF(CODE.LT.100.)GO TO 64 PQR=1HP IF(XJP.GT.XJ)PQR=1HR IF(XJP.EQ.XJ)PQR=1HQ ICODE=CODE J=XJ IF(REF.EQ.4HAFGL)THEN DECODE(10,4466,LABELP)VUP,AISO 4466 FORMAT(1X,I1,7X,A1) DECODE(4,4465,LABEL)VLO,IF 4465 FORMAT(1X,I1,I2) IF(CODE.EQ.808.)ACODE=2HO2 ENCODE(21,4467,WORDS)IWL,COLON,ACODE,VUP,VLO,J,PQR,IF,IRESID,AISO 4467 FORMAT(I3.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,114,WORDS)IWL,COLON,CODE,IELO,IRESID 114 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 C PIERCE AND BRECKENRIDGE LINE LIST FOR SOLAR CENTRAL INTENSITY COMMON /PARAMS/IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,IFMU,NOCALC,YSCALE,OFFSET,IFVAC,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR,NOPRNT, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,AXISWT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL,WAVEI COMMON /CELL/MAXCEL,IFCELL(40000) REAL*4 WORDS(7) CHARACTER STRING*26 CCRAY REAL*8 WORDS(4) REAL*8 WPIERCE(15000) REAL*4 LABELPI(4,15000),EWPIERCE(15000),STPIERCE(15000) DATA IREAD/0/ IF(IREAD.EQ.1)GO TO 332 IREAD=1 OPEN(UNIT=77,SHARED,READONLY,TYPE='OLD') DO 330 I=1,15000 READ(77,331,END=329)WPIERCE(I),STPIERCE(I),ISIGMA,WAVENO,NUMBER, 1DELTAW,NOTE,EWPIERCE(I),(LABELPI(K,I),K=1,4) 331 FORMAT(F11.4,A1,I3,F11.3,I4,F7.3,A1,F8.1,3A4,A2) 330 CONTINUE 329 NPIERCE=I-1 332 CONTINUE CELLIN=8. MAXCEL=40000 DO 333 I=1,MAXCEL 333 IFCELL(I)=0 PRINT 334,NPIERCE,W1,W2 334 FORMAT(I10,2F10.4) DO 70 ILINE=1,NPIERCE WAVEL=WPIERCE(ILINE)/10.D0 WAVEL=WAVEL*(1.D0+DOPCALC/299792.458D0) IF(WAVEL.LT.W1)GO TO 70 IF(WAVEL.GT.W2)GO TO 70 NCELL=(WAVEL-W1)*10.*CELLIN*XSCALE+1.5 C NCELL=(WAVEL-W1)*10.*25.*XSCALE+1.5 DO 62 I=NCELL,MAXCEL IF(IFCELL(I).EQ.0)GO TO 63 62 CONTINUE 63 NCELL=I IFCELL(NCELL)=1 C XCELL=FLOAT(NCELL)*.04 C XCELL=FLOAT(NCELL)*.08 XCELL=FLOAT(NCELL)/CELLIN-.0625 !*.08-.04 YCELL=YTOP+.1 C IF(MOD(NCELL,2).EQ.0)YCELL=YTOP+1.29 XWL=(WAVEL-W1)*10.*XSCALE I=WPIERCE(ILINE) RWL=WPIERCE(ILINE)-FLOAT(I) IWL=RWL*10000.+.5 IF(IWL.EQ.10000)IWL=0 64 WRITE(STRING,114)IWL,STPIERCE(ILINE),EWPIERCE(ILINE), 1(LABELPI(K,ILINE),K=1,4) 114 FORMAT(I4,A1,F6.1,1X,3A4,A2) 66 IF(NOPRNT.NE.1)WRITE(6,65)WPIERCE(ILINE),EWPIERCE(ILINE),WORDS 65 FORMAT(F12.4,F10.1,3X,6A4,A2) C 65 FORMAT(F12.4,F10.1,3X,3A8,A2) CALL STRINGY1(STRING,XCELL,YCELL) C CALL BCDY(7,WORDS,26,8H(6A4,A2),.07,XCELL,YCELL) CCRAY CALL BCDY(4,WORDS,26,8H(3A8,A2),.07,XCELL,YCELL) CALL JUMP TO (XWL,-.03) CALL LINE TO (XWL,0.) CALL JUMP TO (XWL,YTOP) CALL LINE TO (XCELL-.0625,YTOP+.08) !.04 70 CONTINUE 80 CONTINUE RETURN END 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