PROGRAM PLOTobsim c revised 23jan93 C TAPE7 IS CALCULATED SPECTRUM C TAPE55 READ BY OBSERV C TAPE56 READ BY OBSERV1 C TAPE57 READ BY OBSERV2 C TAPE58 READ BY OBSENGV C TAPE59 READ BY OBSHALL C TAPE60 READ BY OBSKPNO C TAPE61 READ BY OBSKPK C TAPE62 READ BY OBSSACP C TAPE63 READ BY OBSHAWA C TAPE64 READ BY OBSNRL C TAPE65 READ BY OBSPROC C TAPE66 READ BY OBSSIR C TAPE67 READ BY OBSARC C TAPE68 READ BY OBSSUNF C TAPE69 READ BY OBSSOIR C TAPE71 READ BY OBSFTS2 C TAPE72 READ BY OBSFTS2 C TAPE73 READ BY OBSFTS C TAPE74 READ BY OBSJUNG C TAPE76 READ BY LABEL5 AFCRL LINE LIST C TAPE77 READ BY LABEL9 PIERCE AND BRECKENRIDGE C TAPE93 IS TEMPORARY STORAGE FOR LABEL DATA C C IFLABL=N LINES ARE LABELLED. A NUMBER N ENDING IN THE DIGIT I C PRODUCES A CALL TO SUBROUTINE LABELI C =1 NORMAL LABELS FOR CALCULATED SPECTRUM, 25/INCH, TWO ROWS C =11 NORMAL LABELS FOR CALCULATED SPECTRUM, 12.5/INCH, ONE ROW C =21 C =31 NORMAL LABELS FOR CALCULATED SPECTRUM, 12.5/INCH, C LOWER ROW ATOMS, UPPER ROW MOLECULES C =2 C =3 C =4 C =5 LABEL AFCRL TERRESTRIAL LINES 25/INCH, TWO ROWS C =15 LABEL AFCRL TERRESTRIAL LINES 12.5/INCH, ONE ROW C =6 C =7 NORMAL LABELS FOR CALCULATED OPACITY SPECTRUM, 25/INCH C =8 C =9 LABEL PIERCE AND BRECKENRIDGE LINES C IFLABL=0 NO LABELS C IFABSO=0 THE PLOT IS IN RESIDUAL INTENSITY OR FLUX C IFABSO=1 THE PLOT IS IN ABSOLUTE UNITS C IFCONT=1 AND IFABSO=1 THE CONTINUUM IS PLOTTED C IFCONT=0 NO CONTINUUM C IFCONT=2 CONTINUUM USED FOR MAXIMUM BUT NOT PLOTTED C IFCONT=3 ONLY CONTINUUM IS PLOTTED C IFGRID=1 A BACKGROUND GRID IS PLOTTED IF XSCALE= 2. C IFDLINE=1 SPECTRUM LINES ARE DOUBLE WEIGHT C IFLOG=1 PLOT IS LOG WITH CYCLES CYCLES C IFLOG=0 PLOT IS LINEAR C JUST1=0 ALL PANELS ARE PLOTTED C JUST1 GREATER THAN 0 A TABLE OF SWITCHES FOR EACH PANEL IS READ C NOWAVE=1 DO NOT PUT WAVELENGTH IN BANNER AT ENDS OF PANELS C NOWAVE=0 PUT WAVELENGTH IN BANNER AT ENDS OF PANELS C IFNEWW CHANGE TO NEW STARTING AND STOPPING WAVELENGTHS AS READ IN C NOCALC=0 CALCULATIONS ARE TO BE READ C NOCALC=1 NO CALCULATIONS ARE TO BE READ REQUIRES IFNEWW=1 C IFDUM1 C IFNOAX=1 AXES ARE NOT LABELLED C IFNOAX=-1 AXES ARE LABELLED. Y TWICE 0 TO 1 AND .9 TO 1 C IFMU=0 PLOT FIRST ANGLE OR FLUX C IFMU=1 TO 20 PLOT ANGLE IFMU C NOPRNT=0 PRINT ALL LINE DATA C NOPRNT=1 NO PRINTING OF LINE DATA C NOPRNT=2 PRINT LINE DATA ONLY FOR LINES THAT ARE LABELLED C IFKPNO.GT.0 PLOT KITT PEAK PRELIMINARY SOLAR ATLAS C IFKPK.GT.0 PLOT KOHL, PARKINSON, AND KURUCZ SOLAR ATLAS C IFSACP.GT.0 PLOT SAC PEAK SOLAR FLUX ATLAS C IFHAWA.GT.0 PLOT HAWAII SOLAR ATLAS C IFNRL.GT.0 PLOT NRL SOLAR ATLAS C IFPROC.GT.0 PLOT GRIFFIN PROCYON ATLAS C IFDUM2 C IFSIR.GT.0 PLOT FURENLID SIRIUS ATLAS C IFARC.GT.0 PLOT GRIFFIN ARCTURUS ATLAS C IFSUNF.GT.0 PLOT FURENLID AND KURUCZ SOLAR FLUX ATLAS C IFSOIR.GT.0 PLOT INFRARED FTS SOLAR ATLAS C IFHALL.GT.0 PLOT HALL INFRARED SUNSPOT ATLAS C IFENGV.GT.0 PLOT ENGVOLD SUNSPOT ATLAS C IFOPAC=N INPUT CALCULATED SPECTRUM IS MASS ABSORPTION COEFFICIENT C OUTPUT FROM SYNTHE. USE ASYNTH(N). PLOT MUST USUALLY BE LOG. C IFFTS.GT.0 PLOT AN FTS SPECTRUM FROM KITT PEAK C IFFTS2.GT.0 PLOT THE RATIO OF TWO FTS SPECTRA FROM KITT PEAK C IFJUNG.GT.0 PLOT JUNGFRAUJOCH SOLAR ATLAS C YSCALE IS THE HEIGHT OF THE PLOT IN MULTIPLES OF 3.125 C DEFAULT=1. FOR XSCALE.GT.0 AND XSCALE.LT.1 C DEFAULT=2. FOR XSCALE.GT.1 C OTHERWISE YTOP=6.25 C XSCALE=1. 10 IN/NM C XSCALE=2. 20 IN/NM C XSCALE=4. 40 IN/NM C XSCALE=8. 80 IN/NM C WEAK IS 1.-RESIDUAL INTENSITY OF THE WEAKEST LINES TO BE LABELED C IF WEAK = 0 ALL LINES ARE LABELED C PANEL IS MAXIMUM LENGTH OF EACH PLOT PANEL C AN ADDITIONAL .1NM IS ADDED FOR OVERLAP BETWEEN PANELS C CYCLES IS NUMBER OF CYCLES IF PLOT IS LOG C OFFSET IS THE NUMBER OF INCHES BY WHICH THE PLOT IS DISPLACED C VERTICALLY C RMIN IS THE RESIDUAL INTENSITY AT THE BOTTOM OF THE PLOT C RMAX IS THE RESIDUAL INTENSITY AT THE TOP OF THE PLOT. DEFAULT 1. C TOP FIXES THE VALUE OF THE TOP OF THE PLOT IF IFABSO = 1 C IF TOP=0. THE TOP IS SET TO THE MAXIMUM VAUE IN EACH PANEL C WNEW1 IS A NEW STARTING WAVELENGTH C WNEW2 IS A NEW STOPPING WAVELENGTH C TICKTOP IS THE SIZE AND DIRECTION OF TICK MARKS AT THE TOP OF THE PLOT C TICKBOT IS THE SIZE AND DIRECTION OF TICK MARKS AT THE BOTTOM OF THE PLOT C DEFAULT IS -0.15 AND +0.15 C SMOOTH IS A SMOOTHING PARAMETER TO BE TRANSMITTED TO OBS SUBROUTINES C IT WOULD GENERALLY BE THE FWHM IN POINT NUMBERS OF A GAUSSIAN C IF NEGATIVE IT IS THE CENTRAL WEIGHT FOR THREE POINT SMOOTHING C DOPOBS IS A DOPPLER SHIFT IN KM/S FOR THE OBSERVED SPECTRA C DOPCALC IS A DOPPLER SHIFT IN KM/S FOR THE CALCULATED SPECTRUM C DOPTERR IS A DOPPLER SHIFT IN KM/S FOR TERRESTRIAL SPECTRUM OR LABELS C SCALOBS IS A FACTOR BY WHICH AN OBSERVED SPECTRUM IS TO BE SCALED C ZEROOBS IS A ZERO LEVEL CORRECTION TO AN OBSERVED SPECTRUM C RMIN2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMIN2 C RMAX2 THE COMPUTED SPECTRUM IS PLOTTED TWICE, SECOND WITH RMAX2 C XOFFSET IS THE NUMBER OF INCHES THE PLOT IS DISPLACED IN X C SCALOB2 IF 0 = SCALOBS C IF NOT 0 SCALOBS IS THE SCALING FACTOR FOR THE BEGINNING AND C SCALOB2 IS THE SCALING FACTOR FOR THE END AND C INTERMEDIATE VALUES ARE LINEARLY INTERPOLATED C DUMMY7 COMMON /PARAMS/XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,IUERM, 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC 6 IFVAC,NOPRNT REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WAVE,WBEGDOP REAL*8 TITLE(74),XMU(20),WLEDGE(200),TEFF,GLOG COMMON /CELL/MAXCEL,IFCELL(40000) REAL*8 Q2(40) C REAL*4 MESSAGE(20,9),ASYNTH(64),TURBV,ALINEC(64) REAL*4 ASYNTH(64),TURBV,ALINEC(64) CHARACTER*79 MESSAGE(9) INTEGER VLO,VUP CCRAY REAL*8 WORDS(3) REAL*4 WORDS(6) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,EXTRA1,EXTRA2,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT(1),NELION) REAL*8 RATIOLG,SIGMA2,WLBEG,WLEND REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN REAL*8 LABEL,LABELP,OTHER1,OTHER2 COMMON/COLOR/COLOROBS CHARACTER*10 COLOROBS DIMENSION IFPANL(80) COMMON /HEADERDATA/USERID(2),FILENAME(2), 1 IDATE(3),ITIME(2),JOBID(2) REAL*8 USERID,FILENAME CHARACTER*9 HEADERDATA(5) CHARACTER*6 WW6,STRING6 CHARACTER*9 STRING9 DATA IFPANL/80*1/ C CALL FILEREP C CALL BEGTIME C CALL RDYOUTF(6,0) IUERM=0 READ(5,1001)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1,NOWAVE, 1NOCALC,IFDUM1 1001 FORMAT(10I8) WRITE(6,1002)IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,JUST1, 1NOWAVE,NOCALC,IFDUM1 1002 FORMAT(1X,10I8/' IFLABL IFABSO IFCONT IFGRID IFDLIN', 1' IFLOG JUST1 NOWAVE NOCALC IFDUM1') READ(5,1001) READ(5,1001)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, 1IFPROC,IFSIR WRITE(6,1003)IFNOAX,IFMU,NOPRNT,IFKPNO,IFKPK,IFSACP,IFHAWA,IFNRL, 1IFPROC,IFDUM2 1003 FORMAT(1X,10I8/' IFNOAX IFMU NOPRNT IFKPNO IFKPK' 1' IFSACP IFHAWA IFNRL IFPROC IFDUM2') READ(5,1001) READ(5,1001)IFSIR,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC,IFFTS, 1IFFTS2,IFJUNG WRITE(6,1004)IFSIR,IFARC,IFSUNF,IFSOIR,IFHALL,IFENGV,IFOPAC, 1IFFTS,IFFTS2,IFJUNG 1004 FORMAT(1X,10I8/' IFSIR IFARC IFSUNF IFSOIR IFHALL', 1' IFENGV IFOPAC IFFTS IFFTS2 IFJUNG') READ(5,1001) READ(5,1005)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX 1005 FORMAT(8F10.3) WRITE(6,1006)YSCALE,XSCALE,WEAK,PANEL,CYCLES,OFFSET,RMIN,RMAX 1006 FORMAT(1X,8F10.3/75H YSCALE XSCALE WEAK PANEL CYCLE 1S OFFSET RMIN RMAX) READ(5,1001) READ(5,1007)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC 1007 FORMAT(E10.3,7F10.3) WRITE(6,1008)TOP,WNEW1,WNEW2,TICKTOP,TICKBOT,SMOOTH,DOPOBS,DOPCALC 1008 FORMAT(1PE10.3,0P7F10.3/79H TOP WNEW1 WNEW2 TICKTOP 1 TICKBOT SMOOTH DOPOBS DOPCALC ) READ(5,1001) READ(5,1027)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1COLOROBS 1027 FORMAT(7F10.3,A10) WRITE(6,1028)DOPTERR,SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2, 1COLOROBS 1028 FORMAT(7F10.3,A10 1 /' DOPTERR SCALOBS ZEROOBS RMIN2 RMAX2 1 XOFFSET SCALOB2 COLOROBS' ) READ(5,1001) READ(5,1009)IFPANL 1009 FORMAT(80I1) WRITE(6,1010)IFPANL 1010 FORMAT(1X,80I1/81H 12345678901234567890123456789012345678901234567 1890123456789012345678901234567890) READ(5,1001) MU=IFMU IF(IFMU.EQ.0)MU=1 IF(JUST1.GT.0)GO TO 1020 DO 1019 IPANEL=1,80 1019 IFPANL(IPANEL)=1 1020 CONTINUE READ(5,2)MESSAGE 2 FORMAT(1X,A79) WRITE(6,2)MESSAGE 5 CONTINUE IF(RMAX.EQ.0.)RMAX=1. IFRMAX2=0 IF(RMIN2.NE.0.)IFRMAX2=1 IF(RMAX2.NE.0.)IFRMAX2=1 IF(RMAX2.EQ.0.)RMAX2=1. Y=YSCALE IF(XSCALE.EQ.0.)XSCALE=2. YSCALE=2. IF(XSCALE.LT.1.)YSCALE=1. IF(Y.GT.0.)YSCALE=Y IF(PANEL.EQ.0.)PANEL=5. IF(SCALOBS.EQ.0.)SCALOBS=1. IF(SCALOB2.EQ.0.)SCALOB2=SCALOBS C OPEN(UNIT=55,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') IF(NOCALC.EQ.1)GO TO 207 C OPEN(UNIT=7,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED') REWIND 7 IF(IFOPAC.NE.0)GO TO 205 READ(7)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF,NMU,XMU,NEDGE, 1WLEDGE NMU2=NMU+NMU MUNMU=MU+NMU WRITE(6,4)TEFF,GLOG,TITLE,WBEGIN,RESOLU,NWL,IFSURF 4 FORMAT(F10.1,F10.3,3X,74A1/F12.4,F10.1,2I10) IFVAC=1 IF(TITLE(74).EQ.1HA)IFVAC=0 C WBEGIN IS THE FIRST CALCULATED WAVELENGTH C WSTART IS THE FIRST PLOTTED WAVELENGTH WSTART=WBEGIN RATIO=1.+1./RESOLU WEND=WBEGIN*RATIO**(NWL-1) IWEND=WEND*10.+.5 WEND=FLOAT(IWEND)/10. IWSTART=WBEGIN*10.+.5 WSTART=FLOAT(IWSTART)/10. IF(WNEW1.EQ.0.)WNEW1=WSTART IF(WNEW2.EQ.0.)WNEW2=WEND GO TO 207 205 CONTINUE READ(7)WBEGIN,RESOLU,WLEND,NWL,NRHOX,LINOUT,TURBV,IFVAC READ(7) WRITE(6,214)WBEGIN,RESOLU,NWL,NRHOX,IFVAC 214 FORMAT(F10.3,F10.1,3I10) IWSTART=WBEGIN*10.+.5 WSTART=FLOAT(IWSTART)/10. RATIO=1.+1./RESOLU WEND=WBEGIN*RATIO**(NWL-1) IWEND=WEND*10.+.5 WEND=FLOAT(IWEND)/10. IF(WNEW1.EQ.0.)WNEW1=WBEGIN IF(WNEW2.EQ.0.)WNEW2=WEND 207 CONTINUE IF(IFLABL.GT.0.AND.NOCALC.EQ.0)THEN DO 2207 I=1,NWL 2207 READ(7) 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) if(ifdlin.eq.0)call weight(1) if(ifdlin.eq.1)call weight(2) END=0. NPANEL=(WNEW2-WNEW1+PANEL-.001)/PANEL IPAN1=0 DO 100 IPANEL=1,NPANEL W1=WNEW1+FLOAT(IPANEL-1)*PANEL W2= MIN (W1+PANEL+.1,WNEW2) C W2=AMIN1(W1+PANEL+.1,WNEW2) WRITE(6,2990)IPANEL,W1,W2 2990 FORMAT(6H PANEL,I3,2F10.3) IF(IFPANL(IPANEL).EQ.0)GO TO 100 IF(IPAN1.GT.0)CALL PAGE C IF(IPAN1.GT.0)CALL START AT (10.,0.) C CALL START AT (4.85,.5+OFFSET) c CALL START AT (1.0+XOFFSET,.5+OFFSET) CALL START AT (1.0+XOFFSET,.5+OFFSET) IPAN1=1 WW=W1 ENCODE(6,2993,WW6)WW 2993 FORMAT(F6.1) ENCODE(9,2991,HEADERDATA(1))USERID ENCODE(9,3992,HEADERDATA(2))JOBID 3992 FORMAT(A4,A4) ENCODE(9,3992,HEADERDATA(3))ITIME ENCODE(9,3993,HEADERDATA(4))IDATE 3993 FORMAT(A4,A4,A1) ENCODE(9,2991,HEADERDATA(5))FILENAME 2991 FORMAT(A8,A1) c canon is 0.5 higher than xerox THESE ARE CANON CANON=0. CANON=.5 c IF(NOWAVE.EQ.0)THEN c CALL STRINGX10(WW6,0.,14.20-OFFSET+CANON) c CALL STRINGX10(WW6,19.5,14.20-OFFSET+CANON) c CALL STRINGX(HEADERDATA(1),4.0,14.85-OFFSET+CANON) c CALL STRINGX(HEADERDATA(2),4.0,14.70-OFFSET+CANON) c CALL STRINGX(HEADERDATA(3),4.0,14.55-OFFSET+CANON) c CALL STRINGX(HEADERDATA(4),4.0,14.40-OFFSET+CANON) c CALL STRINGX(HEADERDATA(5),4.0,14.25-OFFSET+CANON) c ENDIF c CALL STRINGX(MESSAGE(1),6.,14.85-OFFSET+CANON) c CALL STRINGX(MESSAGE(2),6.,14.70-OFFSET+CANON) c CALL STRINGX(MESSAGE(3),6.,14.55-OFFSET+CANON) c CALL STRINGX(MESSAGE(4),6.,14.40-OFFSET+CANON) c CALL STRINGX(MESSAGE(5),6.,14.25-OFFSET+CANON) c CALL STRINGX(MESSAGE(6),12.,14.70-OFFSET+CANON) c CALL STRINGX(MESSAGE(7),12.,14.55-OFFSET+CANON) c CALL STRINGX(MESSAGE(8),12.,14.40-OFFSET+CANON) c CALL STRINGX(MESSAGE(9),12.,14.25-OFFSET+CANON) CALL STRINGX(MESSAGE(1),3.,10.20) CALL STRINGX(MESSAGE(2),3.,9.95) CALL STRINGX(MESSAGE(3),3.,9.70) CALL STRINGX(MESSAGE(4),3.,9.45) CALL STRINGX(MESSAGE(5),3.,9.20) CALL STRINGX(MESSAGE(6),9.,9.95) CALL STRINGX(MESSAGE(7),9.,9.70) CALL STRINGX(MESSAGE(8),9.,9.45) CALL STRINGX(MESSAGE(9),9.,9.20) CALL COLOR BLACK C C DRAW BOX END=(W2-W1)*10.*XSCALE CALL JUMP TO (0.,0.) CALL LINE TO (END,0.) YTOP=3.125*YSCALE CALL LINE TO (END,YTOP) CALL LINE TO (0.,YTOP) CALL LINE TO (0.,0.) C C X AXIS N=(W2-W1)*10.+1.5 IF(TICKTOP.EQ.0.)TICKTOP=-.15 IF(TICKBOT.EQ.0.)TICKBOT=.15 DO 11 I=1,N HALF=1. IF(XSCALE.LT.1..AND.MOD(I,5).NE.1)HALF=.5 IF(XSCALE.LT..05.AND.MOD(I,100).NE.1)HALF=.5 IF(XSCALE.LT..01.AND.MOD(I,500).NE.1)HALF=.5 IF(XSCALE.LT..05.AND.MOD(I,10).NE.1)GO TO 11 IF(XSCALE.LT..01.AND.MOD(I,100).NE.1)GO TO 11 X=FLOAT(I-1)*XSCALE CALL JUMP TO (X,0.) CALL LINE TO (X,TICKBOT*HALF) CALL JUMP TO (X,YTOP+TICKTOP*HALF) CALL LINE TO (X,YTOP) WAVE=W1+FLOAT(I-1)/10. IF(XSCALE.LT.1..AND.MOD(I,5).NE.1)GO TO 11 IF(XSCALE.LT..2.AND.MOD(I,10).NE.1)GO TO 11 IF(XSCALE.LT..05.AND.MOD(I,100).NE.1)GO TO 11 IF(XSCALE.LT..01.AND.MOD(I,500).NE.1)GO TO 11 IF(IFNOAX.NE.1.AND.XSCALE.GE..2)THEN WRITE(WW6,'(F6.1)')WAVE CALL STRINGX2(WW6,X-.4,-.3) ENDIF IF(IFNOAX.NE.1.AND.XSCALE.LT..2)THEN IWAVE=WAVE WRITE(WW6,'(I6)')IWAVE CALL STRINGX2(WW6,X-.6,-.3) ENDIF IF(IFGRID.EQ.0)GO TO 11 CALL JUMP TO (X,0.) CALL WEIGHT(12) CALL LINE TO (X,YTOP) CALL WEIGHT(1) 11 CONTINUE C IF(XSCALE.GT.10..AND.IFNOAX.NE.1)THEN N=END*.1+.05 DO 1611 I=1,N WAVE=W1+FLOAT(I)/XSCALE X=I*10 WRITE(STRING9,'(F9.4)')WAVE 1611 CALL STRINGX2(STRING9,X-.4,-.3) ENDIF C C Y AXIS if(rmin.eq.0.)then 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 endif IF(IFLOG.EQ.1)GO TO 14 ITWO=1 IF(YTOP.LT.1.99)ITWO=2 IF(IFNOAX.EQ.-1)THEN C DO 613 I=1,10,ITWO C Y=FLOAT(I-1)*YTOP/10. C R=(RMAX-RMIN)/10.*FLOAT(I-1)+RMIN C CALL WEIGHT(12) C ENCODE(6,2994,STRING6)R C 2994 FORMAT(F2.1) C CALL STRINGX2(STRING6,-.23,Y) CC CALL BCDX(1,R,2,6H(F2.1),.15,-.23,Y) C CALL WEIGHT(1) C ENCODE(6,2995,STRING6)R C 2995 FORMAT(F3.2) C 613 CALL STRINGX2(STRING6,-.6,Y) CC 613 CALL BCDX(1,R/10.+.9,3,6H(F3.2),.15,-.6,Y) C CALL WEIGHT(12) C ENCODE(6,1313,STRING6)RMAX C CALL STRINGX2(STRING6,-.9,Y-.05) C CALL WEIGHT(1) CALL WEIGHT(12) CALL STRINGX2(' 1@ @ .@ @ @ @ 00',-.88,YTOP*1.) CALL STRINGX2(' .@ @ @ @ 9',-.88,YTOP*.9) CALL STRINGX2(' .@ @ @ @ 8',-.88,YTOP*.8) CALL STRINGX2(' .@ @ @ @ 7',-.88,YTOP*.7) CALL STRINGX2(' .@ @ @ @ 6',-.88,YTOP*.6) CALL STRINGX2(' .@ @ @ @ 5',-.88,YTOP*.5) CALL STRINGX2(' .@ @ @ @ 4',-.88,YTOP*.4) CALL STRINGX2(' .@ @ @ @ 3',-.88,YTOP*.3) CALL STRINGX2(' .@ @ @ @ 2',-.88,YTOP*.2) CALL STRINGX2(' .@ @ @ @ 1',-.88,YTOP*.1) CALL STRINGX2(' .@ @ @ @ 0',-.88,YTOP*.0) CALL WEIGHT(1) CALL STRINGX2(' .@ @ @ @ 99 ',-.88,YTOP*.9) CALL STRINGX2(' .@ @ @ @ 98 ',-.88,YTOP*.8) CALL STRINGX2(' .@ @ @ @ 97 ',-.88,YTOP*.7) CALL STRINGX2(' .@ @ @ @ 96 ',-.88,YTOP*.6) CALL STRINGX2(' .@ @ @ @ 95 ',-.88,YTOP*.5) CALL STRINGX2(' .@ @ @ @ 94 ',-.88,YTOP*.4) CALL STRINGX2(' .@ @ @ @ 93 ',-.88,YTOP*.3) CALL STRINGX2(' .@ @ @ @ 92 ',-.88,YTOP*.2) CALL STRINGX2(' .@ @ @ @ 91 ',-.88,YTOP*.1) CALL STRINGX2(' .@ @ @ @ 90 ',-.88,YTOP*.0) GO TO 17 ENDIF DO 13 I=1,10,ITWO Y=FLOAT(I-1)*YTOP/10. R=(RMAX-RMIN)/10.*FLOAT(I-1)+RMIN CALL WEIGHT(1) IF(IFNOAX.EQ.1)GO TO 13 C IF(RMAX-RMIN.GE..5)ENCODE(6,1313,STRING6)R C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)R ENCODE(6,1313,STRING6)R IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)R IF(I.GT.1)Y=Y-.03 IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,Y) IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,Y) c IF(YSCALE.GT..5)CALL STRINGX(STRING6,-.9,Y) 13 CONTINUE IF(IFNOAX.EQ.1)GO TO 17 ENCODE(6,1313,STRING6)RMAX C IF(RMAX-RMIN.GE..5)ENCODE(6,1313,STRING6)RMAX 1313 FORMAT(F6.1) C IF(RMAX-RMIN.LT..5)ENCODE(6,1314,STRING6)RMAX IF(RMAX-RMIN.LT.1.)ENCODE(6,1314,STRING6)RMAX 1314 FORMAT(F6.2) IF(YSCALE.LE..5)CALL STRINGX(STRING6,-.5,YTOP-.08) IF(YSCALE.GT..5)CALL STRINGX2(STRING6,-.9,YTOP-.16) c IF(YSCALE.GT..5)CALL STRINGX(STRING6,-.9,YTOP-.16) GO TO 17 14 IF(IFABSO.EQ.1)GO TO 17 DO 15 I=1,11 Y=FLOAT(I-1)*YTOP/10. R=ALOG10(RMAX)-CYCLES+FLOAT(I-1)*CYCLES/10. IF(IFNOAX.EQ.1)GO TO 15 ENCODE(6,1314,STRING6)R CALL STRINGX2(STRING6,-0.9,Y) 15 CONTINUE 17 IF(IFGRID.EQ.0)GO TO 20 C IF(IFGRID.EQ.1)THEN IF(XSCALE.LT.1.)GO TO 20 C PLOT GRID XGRID=.1 IF(XSCALE.EQ.4.)XGRID=.08 IF(XSCALE.EQ.8.)XGRID=.08 NGRID=END/XGRID DO 18 I=1,NGRID X=FLOAT(I)*XGRID CALL JUMP TO (X,0.) CALL WEIGHT(1) C IF(MOD(I,10).EQ.0)CALL WEIGHT(12) C CALL LINE TO (X,YTOP) IF(MOD(I,10).EQ.0)CALL LINE TO (X,YTOP) IF(MOD(I,10).NE.0)CALL DOTLINE(X,0.,X,YTOP,'E0E0'X) 18 CONTINUE C DO 1118 I=1,NGRID*2.5 C X=NGRID/10. C X=FLOAT(I)/10./2.5 C CALL JUMP TO (X,0.) C CALL WEIGHT(1) C CALL LINE TO (X,-.07) C 1118 CONTINUE DO 19 I=1,49 Y=FLOAT(I)*YTOP/50. CALL JUMP TO (0.,Y) CALL WEIGHT(1) C IF(MOD(I,5).EQ.0)CALL WEIGHT(12) C CALL LINE TO (END,Y) IF(MOD(I,5).EQ.0)CALL LINE TO (END,Y) IF(MOD(I,5).NE.0)CALL DOTLINE(0.,Y,END,Y,'E0E0'X) 19 CONTINUE CALL WEIGHT(1) ENDIF C IF(IFGRID.EQ.2)THEN N=(W2-W1)*10.*10.+.5 DO 4019 I=1,N X=FLOAT(I)*XSCALE*.1 CALL JUMP TO (X,0.15) CALL LINE TO (X,YTOP-.15) 4019 CONTINUE DO 4020 I=1,10 Y=FLOAT(I)*YTOP*.1 CALL JUMP TO (0.,Y) CALL LINE TO (END,Y) 4020 CONTINUE ENDIF C IF(IFGRID.EQ.3)THEN DO 4030 I=1,50 Y=FLOAT(I)*YTOP*.02 CALL JUMP TO (0.,Y) CALL LINE TO (END,Y) 4030 CONTINUE ENDIF C 20 IF(NOCALC.EQ.0)THEN C IF(IFLOG.EQ.0)CALL STRINGY2('LIN',END+.4,.2) C IF(IFLOG.EQ.1)CALL STRINGY2('LOG',END+.4,.2) IF(IFABSO.EQ.0)CALL STRINGY2('RESIDUAL',END+.4,0.2) 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) ENCODE(9,3535,STRING9)HMAX CALL STRINGY2(STRING9,END+.6,YTOP-1.2) ENCODE(9,3535,STRING9)HMIN 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(IFSIR.GT.0)CALL OBSSIR(IFSIR) 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(1) IF(IFDLIN.EQ.1)CALL WEIGHT(2) WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) C IF(IFOPAC.GT.0)THEN READ(7) DO 233 IWL=N1,NWL READ(7)(ASYNTH(J),J=1,IFOPAC) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 233 IF(WAVE.GT.W2+.0001)GO TO 734 FREQ=2.99792458E17/WAVE HLAM=MAX(ASYNTH(IFOPAC),1.E-30) CONT=HMAX IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN)/(RMAX-RMIN)*YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* 1YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP IF(Y.LT.0.)Y=0. IF(Y.GT.YTOP)Y=YTOP X=(WAVE-W1)*10.*XSCALE IF(ISTART.EQ.0)CALL JUMP TO (X,Y) ISTART=1 CALL LINE TO (X,Y) 233 CONTINUE CALL WEIGHT(1) NSKIP=0 GO TO 735 ENDIF C XOLD=0. YOLD=0. DO 33 IWL=N1,NWL READ(7)(Q2(I),I=1,NMU2) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 33 IF(WAVE.GT.W2+.0001)GO TO 34 FREQ=2.997925E17/WAVE HLAM=Q2(MU)*FREQ/WAVE CONT=Q2(MUNMU)*FREQ/WAVE C KEEPS EMISSION BELOW CONTINUUM C IF(IFABSO.EQ.0.AND.HLAM.GT.CONT)HLAM=CONT IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN)/(RMAX-RMIN)*YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* 1YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP X=(WAVE-W1)*10.*XSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* 1(YTOP-YOLD) IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) ISTART=1 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 33 CONTINUE CALL WEIGHT(1) IF(IFRMAX2.EQ.0)GO TO 732 34 IF(IFRMAX2.EQ.0)GO TO 735 C XOLD=0. YOLD=0. REWIND 7 READ(7) IF(NSKIP.EQ.0)GO TO 731 DO 730 I=1,NSKIP 730 READ(7) 731 N1=NSKIP+1 ISTART=0 DO 733 IWL=N1,NWL READ(7)(Q2(I),I=1,NMU2) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 733 IF(WAVE.GT.W2+.0001)GO TO 734 FREQ=2.997925E17/WAVE HLAM=Q2(MU)*FREQ/WAVE CONT=Q2(MUNMU)*FREQ/WAVE IF(IFABSO.EQ.0.AND.HLAM.GT.CONT)HLAM=CONT IF(IFABSO.EQ.0.AND.IFLOG.EQ.0)Y=(HLAM/CONT-RMIN2)/(RMAX2-RMIN2)* 1YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.0)Y=HLAM/HMAX*YTOP IF(IFABSO.EQ.0.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM/CONT)-RMINL)/CYCLES* 1YTOP IF(IFABSO.EQ.1.AND.IFLOG.EQ.1)Y=(ALOG10(HLAM)-HMINL)/CYCLES*YTOP X=(WAVE-W1)*10.*XSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* 1(YTOP-YOLD) IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) ISTART=1 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 733 CONTINUE 732 CALL WEIGHT(1) NSKIP=0 GO TO 735 734 NSKIP=NWL-IWL CALL WEIGHT(1) 735 CONTINUE C 35 IF(IFABSO.EQ.0)CALL BCDX(1,CONT,9,8H(1PE9.3),.15,END+.5,YTOP-.05) C IF(IFABSO.EQ.0)CALL BCDY(1,CONT,9,8H(1PE9.3),.15,-.05,YTOP+.25) C IF(IFABSO.EQ.1)CALL BCDX(1,HMAX,9,8H(1PE9.3),.15,END+.5,YTOP-.05) C IF(IFABSO.EQ.1)CALL BCDY(1,HMAX,9,8H(1PE9.3),.15,-.05,YTOP+.25) IF(IFABSO.EQ.0)ENCODE(9,3535,STRING9)CONT IF(IFABSO.EQ.1)ENCODE(9,3535,STRING9)HMAX 3535 FORMAT(1PE9.3) CALL STRINGY2(STRING9,END+.4,YTOP-1.2) CALL STRINGY2(STRING9,-.15,YTOP+.25) IF(IFABSO.EQ.0)GO TO 50 IF(IFCONT.EQ.0)GO TO 50 IF(IFOPAC.GT.0)GO TO 50 C PLOT CONTINUUM REWIND 7 READ(7) NSKIP= LOG(W1/WBEGIN)/ LOG(RATIO)-2. C NSKIP=ALOG(W1/WBEGIN)/ALOG(RATIO)-2. NSKIP=MAX0(NSKIP,0) IF(NSKIP.EQ.0)GO TO 37 DO 36 I=1,NSKIP 36 READ(7) 37 N1=NSKIP+1 ISTART=0 CALL WEIGHT(1) IF(IFDLIN.EQ.1)CALL WEIGHT(2) WBEGDOP=WBEGIN*(1.D0+DOPCALC/299792.458D0) XOLD=X YOLD=Y DO 43 IWL=N1,NWL READ(7)(Q2(I),I=1,NMU2) WAVE=WBEGDOP*RATIO**(IWL-1) IF(WAVE.LT.W1)GO TO 43 IF(WAVE.GT.W2+.0001)GO TO 44 FREQ=2.997925E17/WAVE CONT=Q2(MUNMU)*FREQ/WAVE IF(IFLOG.EQ.0)Y=CONT/HMAX*YTOP IF(IFLOG.EQ.1)Y=(ALOG10(CONT)-HMINL)/CYCLES*YTOP X=(WAVE-W1)*10.*XSCALE XNEW=X YNEW=Y IF(Y.LT.0.)YNEW=0. IF(Y.GT.YTOP)YNEW=YTOP IF(Y*YOLD.LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)*(0.-YOLD) IF((Y-YTOP)*(YOLD-YTOP).LT.0.)XNEW=XOLD+(X-XOLD)/(Y-YOLD)* 1(YTOP-YOLD) IF(ISTART.EQ.0)CALL JUMP TO (XNEW,YNEW) ISTART=1 CALL LINE TO (XNEW,YNEW) XOLD=X YOLD=Y 43 CONTINUE CALL WEIGHT(1) NSKIP=0 GO TO 50 44 NSKIP=NWL-IWL CALL WEIGHT(1) 50 IF(IFLABL.EQ.0)GO TO 100 IF(NOCALC.EQ.1)GO TO 336 PRINT 1111,NWL,NSKIP 1111 FORMAT(2I10) C IF(NSKIP.EQ.0)GO TO 336 C DO 335 I=1,NSKIP C 335 READ(7) 336 CONTINUE REWIND 93 ILABL=MOD(IFLABL,10) IF(ILABL.EQ.1)CALL LABEL1 IF(ILABL.EQ.2)CALL LABEL2 IF(ILABL.EQ.3)CALL LABEL3 IF(ILABL.EQ.4)CALL LABEL4 IF(ILABL.EQ.5)CALL LABEL5 IF(ILABL.EQ.6)CALL LABEL6 IF(ILABL.EQ.7)CALL LABEL7(IFOPAC) IF(ILABL.EQ.8)CALL LABEL8 IF(ILABL.EQ.9)CALL LABEL9 100 CONTINUE CALL FIN(70) C CALL ENDTIME CALL EXIT END SUBROUTINE OBSERV C PLOTS OBSERVED DATA IN X,Y FORM 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 COMMON /PARAMS/XSCALE, 1 RMIN,WEAK,TOP,PANEL,CYCLES,WBEGIN,WEND,W1,W2,YTOP, 2 HMAX,HMIN,YSCALE,OFFSET,RMAX, 3 WNEW1,WNEW2,SMOOTH,DOPOBS,DOPCALC,DOPTERR, 4 SCALOBS,ZEROOBS,RMIN2,RMAX2,XOFFSET,SCALOB2,IUERM, 5 IFLABL,IFABSO,IFCONT,IFGRID,IFDLIN,IFLOG,IFMU,NOCALC 6 IFVAC,NOPRNT COMMON/COLOR/COLOROBS CHARACTER*10 COLOROBS REAL*8 WBEGIN,WEND,W1,W2,RESOLU,RATIO,WNEW1,WNEW2,WAVEL REAL*8 WI,W,WCUT,WRM,DOPOBS8 REAL*4 WRM4(100) DIMENSION WCUT(7) dimension ss(460000) equivalence (si(1),ss(10001)) dimension wtsmoo(10000) DIMENSION WRM(100) CCRAY COMMON /WISI/WI(100000),SI(100000) COMMON /WISI/WI(450000),SI(450000) 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/ DOPOBS8=DOPOBS IFSUNF=0 IF(IREAD.EQ.1)GO TO 9 IREAD=1 OPEN(UNIT=55,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(55,END=5)W,S C REMOVE GRAVITATIONAL RED SHIFT c W=W*(1.D0-0.636D0/299792.458D0) W=W*(1.D0+DOPOBS8/299792.458D0) c w=w+dopobs 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 4 CONTINUE 5 CONTINUE IF(IUERM.EQ.0)GO TO 9 OPEN(UNIT=56,SHARED,TYPE='OLD') READ(56,6)NORD 6 FORMAT(I5) C TYPE*,NORD DO 44 I=1,100 READ(56,66,END=97)XRM,YRM,ZRM 66 FORMAT(1X,F10.4,1X,F15.4,1X,F10.4) C TYPE*,XRM,YRM,ZRM WRM(I)=(XRM*0.1)*(1.D0+DOPOBS8/299792.458D0) WRM(I)=(WRM(I)-W1)*XSCALE*10. C TYPE*, I,WRM(I) 44 CONTINUE 97 NPTI=I-1 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(2) if (ifsunf.eq.0.and.ifdlin.eq.0) call weight(1) IF(IFSUNF.EQ.2.OR.IFSUNF.EQ.12)CALL WEIGHT(1) ISTART=0 CALL COLOR BLACK IF(COLOROBS.EQ.'RED ')CALL COLOR RED IF(COLOROBS.EQ.'BLUE ')CALL COLOR BLUE IF(IFABSO.EQ.0)GO TO 144 C FIND MAX AND MIN HMAX=0. HMIN=1.E30 DO 145 I=1,NIN HMAX=AMAX1(HMAX,SI(I)) HMIN=AMIN1(HMIN,SI(I)) 145 CONTINUE IF(TOP.GT.0.)HMAX=TOP 144 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. IF(IFABSO.EQ.1)SI(I)=SI(I)/HMAX 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) C TYPE*, IUERM IF(IUERM.EQ.0)GO TO 14 DO 339 IRM=1,NPTI WRM4(IRM)=WRM(IRM) C TYPE*,WRM4(IRM),X IF(ABS(WRM4(IRM)-X).LE.0.001)CALL X AT(WRM4(IRM),Y) 339 CONTINUE 14 CONTINUE 15 CONTINUE if(ifdlin.eq.0)CALL WEIGHT(1) if(ifdlin.eq.1)call weight(2) IF(IFSUNF.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 OBSERV1 RETURN END SUBROUTINE OBSERV2 RETURN END SUBROUTINE OBSKPNO(IFKPNO) RETURN END SUBROUTINE OBSJUNG(IFJUNG) RETURN END SUBROUTINE OBSKPK(IFKPK) C HARVARD ROCKET SPECTRA KOHL,PARKINSON,KURUCZ RETURN END SUBROUTINE OBSSACP(IFSACP) C SAC PEAK SOLAR ATLAS BY BECKERS, BRIDGES, AND GILLIAM RETURN END SUBROUTINE OBSHAWA(IFHAWA) C HAWAII ROCKET SPECTRA ALLEN, MCALLISTER, AND JEFFRIES RETURN END SUBROUTINE OBSNRL(IFNRL) RETURN END SUBROUTINE OBSPROC(IFPROC) RETURN END SUBROUTINE OBSARC(IFARC) RETURN END SUBROUTINE OBSSUNF(IFSUNF) C PLOTS KURUCZ, FURENLID, BRAULT, AND TESTERMAN SOLAR FLUX ATLAS RETURN END SUBROUTINE OBSSOIR(IFSOIR) C PLOTS DELBOUILLE, ROLAND, BRAULT, AND TESTERMAN INFRARED SOLAR ATLAS RETURN END SUBROUTINE OBSHALL(IFHALL) C PLOTS HALL INFRARED SUNSPOT ATLAS RETURN END SUBROUTINE OBSENGV(IFENGV) C PLOTS ENGVOLD SUNSPOT ATLAS RETURN END SUBROUTINE OBSFTS(IFFTS) C PLOTS A SPECTRUM FROM THE FTS AT KITT PEAK RETURN END SUBROUTINE OBSFTS2(IFFTS2) C PLOTS THE RATIO OF TWO SPECTRA FROM THE FTS AT KITT PEAK RETURN END SUBROUTINE OBSSIR(IFSIR) RETURN END SUBROUTINE LABEL1 C LABELS COMPUTED SPECTRUM RETURN END SUBROUTINE LABEL2 RETURN END SUBROUTINE LABEL3 RETURN END SUBROUTINE LABEL4 RETURN END SUBROUTINE LABEL5 C LABELS ATMOSPHERIC LINES FROM AFCRL LINE LIST RETURN END SUBROUTINE NAMEMOL(MOLNAME,MOLCODE) C IDENTIFIES ISOTOPE CODES FOR AFCRL LINE LIST RETURN END SUBROUTINE LABEL6 RETURN END SUBROUTINE LABEL7(IFOPAC) RETURN END SUBROUTINE LABEL8 RETURN END SUBROUTINE LABEL9 C PIERCE AND BRECKENRIDGE LINE LIST FOR SOLAR CENTRAL INTENSITY RETURN END