diff options
Diffstat (limited to 'synthe/plotobsimcol.for')
| -rw-r--r-- | synthe/plotobsimcol.for | 1129 |
1 files changed, 1129 insertions, 0 deletions
diff --git a/synthe/plotobsimcol.for b/synthe/plotobsimcol.for new file mode 100644 index 0000000..461d787 --- /dev/null +++ b/synthe/plotobsimcol.for @@ -0,0 +1,1129 @@ + 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 |