C 06/02/85 15:36:45 06/02/85 15:35:02 $380300.MJS SUBROUTINE DODPA c REAL*8 $$$DT(6) /'$$DATE$$','06/02/85','15:35:02', c | ' DODPA',' FORTRAN','MJS '/ RETURN END BLOCK DATA COMMON /CDATA/ ILEN0,DATA COMMON /ARRAY/ PLTOFF,YDS,YDL,YPL,DATL,DATS,PLTL,IVAR,IPAN,IVARA, 1 ICOLOR,IANG,LERB,LDS,LSUB,LMULT,LDIV,LABS,LLOG,LYALT COMMON /MORRAY/ SCAL,SCALO,IADD COMMON /MORLST/ TGAPH,XSTDEL,XST,XDEL,X0,XABSMX,ILXAX,IXAX, 1 IYRF,IDAYF,IHRF,IMINF,IYRL,IDAYL,IHRL,IMINL,NYRL,NDAYL, 2 LAXIS,LOGXAX,ALTXAX,LAU,LCONT INTEGER IADD(26) REAL SCAL(26) REAL SCALO(26) REAL PLTL(26) REAL PLTOFF(26) REAL DATL(26) REAL DATS(26) LOGICAL LERB(26) LOGICAL LLOG(26) LOGICAL LDS(26) LOGICAL LDIV(26) LOGICAL LMULT(26) LOGICAL LSUB(26) LOGICAL LABS(26) LOGICAL LYALT(26) INTEGER*2 IANG(26) REAL*8 TGAPH LOGICAL ALTXAX LOGICAL LOGXAX REAL X0 , XDEL INTEGER ICOLOR(26) INTEGER IPAN(26) INTEGER IVAR(26) INTEGER IVARA(26) REAL YDL(26),YDS(26),YPL(26) INTEGER IYRF, IDAYF , IHRF , IMINF INTEGER IYRL , IDAYL , IHRL , IMINL INTEGER NYRL , NDAYL INTEGER IXAX INTEGER ILXAX LOGICAL LAXIS(8) LOGICAL LCONT REAL XST(8) , XSTDEL(8) LOGICAL LAU REAL XABSMX INTEGER ILEN0 REAL DATA(10000) COMMON /CGAP/ ILGAP, LGAP INTEGER ILGAP LOGICAL LGAP(3000) data ILGAP /3000/ data IADD /26*-1/ data SCAL /0.,.005,1.,.02,.05,.05,.075,.005556, + -0.277778E-2,.1,.8,.01,2*.5,12*0.0/ data SCALO /0.,-1.,+0.5,9*0.,2*-1.5,12*0./ data PLTL /0.,3.5,2.5,3*1.5,2.,1.25, + 2.,1.5,2.5,1.5,0.,2.5,2. A ,11*0./ data PLTOFF /26*0./ data DATL /0.,1200.,200.,100.,25.,25.,50.,100.,360.,20., + 12.,100.,2*2.E7,12*0./ data DATS /2*0.,0.001, 0.0, 2*-25.,0.,-100.,-360.,2*0.0, + -100.,2*5.0E+2,12*0./ data TGAPH /1.D0/ data ALTXAX /.FALSE./ data LOGXAX /.FALSE./ data X0 /0./, XDEL /0./ data LERB /26 * .FALSE./ data LLOG /2*.FALSE.,.TRUE.,9*.FALSE.,2*.TRUE., + 12*.FALSE./ data LDS /10*.FALSE.,.TRUE.,15*.FALSE. / data LDIV /26*.FALSE./ data LMULT /26*.FALSE./ data LSUB /26*.FALSE./ data LABS /26*.FALSE./ data LYALT /26*.FALSE./ data IANG /4*0,4,2,2*0,3,17*0/ data ICOLOR /26*1/ data IPAN /-1,1,2,3,4,5,6,7,8,9,10,11,13,00,-2,11*0/ data IVAR /-1,24,23,40,2*26,14,16,15,8,10,9, + 11,12,-2,11*0/ data IVARA /10*0,40,15*0/ DATA YDS /0.,200.,.05,0.,-10.,-10.,0.,-90.,-180.,2*0.0,-50., A 2*1.E3,12*0./ DATA YDL /0.,800.,5.,50.,2*10.,5.,90.,180.,10.,8.,50.,2*1.E7, A12*0./ DATA YPL /0.,3.,2.,3*1.,1.5,.75,1.5,1.,2.,1.,2*2., 12*0./ data IYRF/0/, IDAYF /0/, IHRF /0/, IMINF /0/ data IYRL /2000/, IDAYL /0/, IHRL /0/, IMINL /0/ data NYRL /2000/, NDAYL /400/ data IXAX /0/ data ILXAX /20/ data LAXIS /8*.FALSE./ data LCONT /.TRUE./ data XST /8*0.0/, XSTDEL /8*0.0/ data LAU /.TRUE./ data XABSMX /1.E+30/ data ILEN0 /10000/ data DATA /10000*0./ END SUBROUTINE AXISPT(YREF,IPANK) C PLOT ADDITIONAL AXISES REAL TIC INTEGER NST , N(8) C NST MAXIMUM NUMBER OF SECONDARY TICK MARKS C XST POSITION IN INCHES OF TICK MARKS REAL DXST REAL XST0(6) REAL XST(20,6) REAL XSTL(20,6) c REAL*8 TH(8) REAL T0(8) , DT0(8),X12 REAL XSTM(1),XSTDM(1) LOGICAL LAXIS(8) REAL*8 TN, TL REAL DH(8), DHL(8) data TIC /0.1/ data NST /20/, N /8*0/ C NST MAXIMUM NUMBER OF SECONDARY TICK MARKS C XST POSITION IN INCHES OF TICK MARKS data DXST /0.5/ data XST0 /6*-1.0/ data XST /120*0./ data XSTL /120*0./ data T0 /8*0./, DT0 /8*0./ data TL / 1.d+70 / data DH /8*-1./, DHL /8*-2./ C DH DATA VALUE HERE C DHL DATA VALUE HERE LAST TIME C TH TIME HERE POSITION C THL TIME HERE POSITION LAST TIME C T0 VALUE OF LABEL POINTER C INCREMENT IN VALUE OF LABEL C XSTL VALUE OF SECONDARY TICK MARKS II = -IPANK-2 NS = N(II+2) IF (NS .LE. 0) RETURN CALL PLOT( 0., YREF, 3) DO 1000 I=1,NS X0 = XST(I,II) CALL PLOT(X0,YREF,2) NN = 3.-ALOG10(XSTL(I,II)) CALL NUMBER( X0-0.1, YREF-0.3, 0.1, XSTL(I,II), 0., NN) CALL PLOT(X0,YREF-TIC,3) CALL PLOT(X0,YREF,2) 1000 CONTINUE CALL PLOT(X12,YREF,2) N(II+2) = 0 RETURN ENTRY AXISST(XSTM, XSTDM, X12A) C COLLECT INITIAL DATA X12 = X12A DO 2600 I=1,8 T0(I) = XSTM(I) DT0(I) = XSTDM(I) 2600 CONTINUE RETURN ENTRY AXISD(IP , DAT) IPANK = -IP C PICK UP DATA POINT DHL(IPANK) = DH(IPANK) DH(IPANK) = DAT RETURN ENTRY AXIST(TIMN, TN, TIM0, LAXIS, VAR) C COMPUTE WHERE TIC MARK IS C IPAN = -3 RESERVED FOR TIME AXIS 4001 FORMAT('0AXIST',1P3D20.10,8L2/(8E14.5)) DHL(3) = DH(3) DH(3) = TN IF (TIM0 .LT. -1.E+30) GO TO 3500 DO 3000 I=3,8 IF (.NOT.LAXIS(I)) GO TO 3000 IF (T0(I) .GT. DH(I)) GO TO 3000 2700 IF (T0(I) + DT0(I) .GE. DH(I)) GO TO 2800 T0(I) = T0(I) + DT0(I) GO TO 2700 2800 CONTINUE IF (N(I) .GE. NST) GO TO 3000 N(I) = N(I) + 1 NI = N(I) XST(NI,I-2) = (T0(I)-DH(I))/(DHL(I)-DH(I))*(TIM0-TIMN) + TIMN XSTL(NI,I-2) = T0(I) IF (I .EQ. 3) XSTL(NI,1) = AMOD(T0(3), 366.) T0(I) = T0(I) + DT0(I) IF (ABS(XST(NI,I-2)-XST0(I-2) ) .GE. DXST) GO TO 2900 N(I) = NI-1 GO TO 3000 2900 XST0(I-2) = XST(NI,I-2) 3000 CONTINUE TL = TN RETURN 3500 TL = TN DO 4000 I=3,8 IF ( .NOT.LAXIS(I)) GO TO 4000 DHL(I) = DH(I) 3400 IF (T0(I) .GE. DH(I)) GO TO 4000 T0(I) = T0(I) + DT0(I) GO TO 3400 4000 CONTINUE RETURN END SUBROUTINE XAXALT(YREF,X0,XMAX,F,XLAB,IK,LOGXAX) C PLOT ALTERNATE X-AXES LOGICAL LOGXAX REAL*8 XLAB(2) INTEGER N INTEGER I2 LOGICAL*4 FIRST, FW(5) data N /11/ data I2 /1/ data FIRST /.TRUE./, FW /5*.TRUE./ XMID = 0.5*F*(XMAX-X0) - 2. IF (LOGXAX) XMID = 0.5*F*ALOG10(XMAX/X0)-2. IF ( IK .NE. -1 ) GO TO 50 C LABEL THE FRAME CALL SYMBOL( XMID, YREF-1., 0.25, XLAB, 0., 16) IF (FIRST) CALL HACK(FW) FIRST = .FALSE. CALL SYMBOL(2.*XMID+3., YREF-1.4, 0.07, FW, 0., 8) 50 CONTINUE C SET UP SCALE FOR LINEAR X-AXIS IF (.NOT. LOGXAX) GO TO 60 N = XMAX/X0 + 1.1 IF (N .LE. 1) N=2 53 IF (N .LE. 20) GO TO 55 N = N/10 GO TO 53 55 DXX = X0 56 IF (N .GT. 3) GO TO 70 N = 2*N DXX = DXX/2. GO TO 56 60 CONTINUE C SET UP SCALE FOR LOGARITHMIC X-AXIS XL = XMAX-X0 ALXL=ALOG10(XL) + 10. NP = ALXL ALA= 10.**(NP-10) N = XL/ALA + 0.2 IF (N .EQ. 1) N = 10 63 IF (N .GT. 4) GO TO 66 N = N*2 GO TO 63 66 DXX = XL/N N = N + 1 70 CONTINUE C CALCULATE TIC-MARKS XX = X0 X = 0. TIC = 0.1 CALL PLOT(X,YREF-TIC,3) DO 100 I=1,N CALL PLOT(X,YREF,2) XX = DXX*(I-1) + X0 IF (XX .GT. XMAX*1.01) GO TO 100 X = (XX-X0)*F IF (LOGXAX) X=F*ALOG10(XX/X0) CALL PLOT(X,YREF,2) WRITE (6,1001) X,XX,I,F,X0,DXX,XMAX,LOGXAX 1001 FORMAT(1P2E12.3,I5, 4E15.5,L4) CALL PLOT(X,YREF-TIC,2) IF (MOD(I,I2) .NE. 0) GO TO 100 CALL NUMBER(-0.3+X,YREF-0.3,0.12,XX, 0.,2) CALL PLOT(X,YREF-TIC,3) 100 CONTINUE RETURN END SUBROUTINE FRAME ( NDAY, NYEAR,YREF) COMMON /PSTUFF/ F, X12, SCNAME, IDSRN, NUMDAY,NOROT,TPTYPE character*8 DLAB character*4 voy1, voy2, scname LOGICAL*4 LVARIN LOGICAL LLOG LOGICAL*4 FW(5) c REAL SQROOT/ZFFEDED00/ DATA VOY1 /'VOY1'/, VOY2 /'VOY2'/ DAY=FLOAT(NDAY) YEAR=FLOAT(NYEAR) CALL HACK (FW) C C C**********WRITE TITLE AT BOTTOM OF PAGE*************************** IF (SCNAME .EQ. VOY1) CALL SYMBOL(.5,YREF-.5,.2,'VOYAGER 1',0.,9) IF (SCNAME .EQ. VOY2) CALL SYMBOL(.5,YREF-.5,.2,'VOYAGER 2',0.,9) CALL SYMBOL(2.5,YREF-.5,.14,'DOY',0.,3) CALL NUMBER(3.,YREF-.5,.14,DAY,0.,-1) C PUT AN EQUAL SIGN CALL SYMBOL (3.375,YREF-.5,.14,126,0.,-1) CALL DATE(NDAY,NYEAR,MDAYS,MONNAM,MONNUM) C IF ( IDSRN.NE.0 ) WRITE ( IDSRN, 1000) MONNUM, MDAYS, NYEAR, NDAY 1000 FORMAT(' DATE OF PLOT FROM SUBROUTINE DATE',2I4,I5,I4) TDAY=FLOAT(MDAYS) CALL SYMBOL(3.6,YREF-0.5,0.15,MONNAM,0.0,4) CALL NUMBER (4.1,YREF-0.5,.15,TDAY,0.,-1) CALL SYMBOL (4.4,YREF-0.5,.15,1H,,0.,1) CALL NUMBER (4.6,YREF-0.5,.15,YEAR,0.,0) CALL SYMBOL(X12-2.,YREF-0.5,.14 ,3HMIT,0.0,3) CALL SYMBOL(X12-1.,YREF-0.5,.07,FW,0.0,8) RETURN C C ENTRY XLAB(YREF) C*********MAKE X-AXIS WITH TICS CALL PLOT(0.0,YREF,3) DO 9 J=1,25 XREF=0.5*F*FLOAT(J-1) CALL PLOT(XREF,YREF,2) CALL PLOT(XREF,YREF-0.1,2) CALL PLOT(XREF,YREF,2) 9 CONTINUE C**********LABEL THE X-AXIS CALL SYMBOL(24.*.5*F-.15,YREF-.2,.1,4H2400,0.,4) CALL SYMBOL(18.*.5*F-.15,YREF-.2,.1,4H1800,0.,4) CALL SYMBOL(12.*.5*F-.15,YREF-.2,.1,4H1200,0.,4) CALL SYMBOL(06.*.5*F-.15,YREF-.2,.1,4H0600,0.,4) CALL SYMBOL(00.*.5*F-.15,YREF-.2,.1,4H0000,0.,4) RETURN ENTRY LABP (IVAR,IVARA,IR,YREF,YDL,YDS,SC0,SC,LLOG,DLAB,LVARIN, A ICOLOR) IF (.NOT. LVARIN) GO TO 50 ZVAR = FLOAT (IVAR) ZVARA = FLOAT (IVARA) CALL NEWPEN(ICOLOR) IF ((IR .EQ. 0) .AND. (IVAR .GT. 0)) A CALL NUMBER (9.7,YREF,.07,ZVAR,0.,-1) IF (IVARA .NE. 0) CALL NUMBER (9.72,YREF,.05,ZVARA,0.,-1) IF (IR .GE. 1) CALL NUMBER (9.7,YREF+.09,.07,ZVAR,0.,-1) 50 IF (IR .LT. 1) RETURN CALL NEWPEN(1) CALL LYAX(YDL,YDS,YREF+SC0,SC,X12,0.1,LLOG) IF (LLOG) GO TO 100 YL = AMAX1(AMIN1(0.,YDL),YDS) YA = SC*YL + YREF + SC0 GO TO 200 100 YL = AMAX1(AMIN1(1.,YDL),YDS) YA = YREF + SC0 +SC*ALOG10(YL) 200 CALL PLOT(X12,YA,3) CALL PLOT(0.0,YA,2) CALL LYAX(YDL,YDS,YREF+SC0,SC,0.,-0.1,LLOG) IF (IR .GT. 13) GO TO 2014 IF (IR .LT. 4) GO TO (2001,2002,2003), IR CALL LABP2( IR, YREF) RETURN C 2001 CONTINUE C********DO Y-AXIS FOR VELOCITY C*********ANNOTATE Y-AXIS FOR VELOCITY Y = YREF + 3. CALL SYMBOL ( -.65, YREF+.5, .21, 'SPEED', 90., 5) CALL SYMBOL ( -.65, YREF+1.4, .14, '(KM/S)', 90., 6) RETURN C C 2002 CONTINUE Y = YREF-.5 CALL SYMBOL(-.65,Y+.5,.21,'DENSITY',90.,7) CALL SYMBOL(-.65,Y+1.76,.14,'(NO./CC)',90.,8) RETURN C C 2003 CONTINUE C*********THERMAL SPEED****************************** Y=YREF C THE NEXT CARD DOES 3 BACKSPACES AND THREE UNDERLINES AFTER 2KT. CALL SYMBOL(-.70,Y+.12,.14,'2KT000___',90.,9) CALL SYMBOL(-.52,Y+.24,.14,'M',90.,1) C THE NEXT CARD DOES A SQUARE ROOT SIGN AND A OVERLINE CALL SYMBOL(-.52, Y ,.30,SQROOT,90.,2) CALL SYMBOL(-.65,Y+.5,.14,'(KM/S)',90.,6) RETURN C 2014 IF (IR .LE. 33) GO TO 300 WRITE (6,299) IR 299 FORMAT (' STOP 10. IR=',I4,', SHOULD BE .LE. 33') STOP 10 300 CALL SYMBOL (-0.65,YREF,0.21,DLAB,90.,8) RETURN C END SUBROUTINE LABP2(II,YREF) COMMON /PSTUFF/ F, X12, SCNAME, IDSRN, NUMDAY, NOROT,TPTYPE GO TO (2000,2000,2000,2004,2005,2006,2007,2008,2009,2010, + 2011,2012,2013,2014,2015), II 2000 RETURN C 2004 CONTINUE C********E-W******** Y = YREF + 0.5 CALL SYMBOL (-0.25,Y-0.2,0.15,5HE W, 90.,5) CALL SYMBOL (-.65 ,Y-.5 ,.21 , 'FLOW ',90.,7) RETURN C C 2005 CONTINUE C********N-S******** Y = YREF+0.5 CALL SYMBOL(-0.25,Y-0.2,0.15,5HN S,90.,5) Y = Y - 1.4 CALL SYMBOL (-.65,Y+0.76,.17,10H(ECLIPTIC),90.,10) RETURN C C MAGNETIC FIELD MAGNITUDE 2006 CONTINUE CALL SYMBOL(-.65,YREF,.14,'B MAG.',90.,6) CALL SYMBOL(-.65,YREF+.84,.14,'(GAMMA)',90.,7) RETURN C C MAGNETIC FIELD LATITUDE 2007 CONTINUE CALL SYMBOL(-.65,YREF+0.5-.375,.14,'B LAT.',90.,6) C THE NEXT CARDS LABEL THE SCALE OF THE PLOT RETURN C C MAGNETIC FIELD AZIMUTH 2008 CONTINUE CALL SYMBOL(-.65,YREF+0.5-.49,.14,'B AZIMUTH',90.,9) C THE NEXT CARDS LABEL THE SCALE OF THE PLOT RETURN C C ALPHA/PROTON DENSITY 2009 CONTINUE CALL SYMBOL ( -.65, YREF , .21, 'N00a00/N0P ', 90., 15) RETURN C C RATIO OF ALPHA TO PROTON TEMPERATURES 2010 CONTINUE C THE NEXT CARD LABELS THE PLOT CALL SYMBOL(-.65,YREF,.21,'T0a0/T0p',90.,8) RETURN C C VELOCITY DIFFERENCE FOR ALPHA - PROTON 2011 CONTINUE CALL SYMBOL ( -.65, YREF+0.5-.72, .14, 'V00a00-V0P', 90., 10) CALL SYMBOL ( -.65, YREF+0.5 , .14, '(KM/S)', 90., 6) RETURN C C ALPHA THERMAL SPEED 2012 CONTINUE Y = YREF C THE NEXT CARD DOES 3 BACKSPACES AND THREE UNDERLINES AFTER 2KT. CALL SYMBOL(-.70,Y+.12,.14,'2KT000___',90.,9) CALL SYMBOL(-.52,Y+.24,.14,'M',90.,1) C THE NEXT CARD DOES A SQUARE ROOT SIGN AND A OVERLINE CALL SYMBOL(-.52, Y ,.30,' ',90.,2) CALL SYMBOL(-.65,Y+.5,.14,'(KM/S)',90.,6) RETURN C C ELECTRON TEMPERATURE 2013 CONTINUE CALL SYMBOL ( -.65, YREF + .50, .21, 'T0e', 90., 3) CALL SYMBOL ( -.65, YREF +1.04, .14, '(~K)', 90., 4) RETURN C C AVERAGE DISTANCE ENTRY AVEDIS( X, yyY, TDIS, J ) IF ( J.LE.0 ) RETURN Z = FLOAT(J) AVDS = TDIS / Z CALL NUMBER( X, yyY, .28, AVDS, 0., 1 ) CALL SYMBOL( X + .96, yyY, .28, 'AU', 0., 2 ) RETURN C C 2014 CONTINUE 2015 CONTINUE RETURN END SUBROUTINE PTCRV2(T,A,LAST,LGAP,PLTOF,II) C C THIS SUBROUTINE DOES THE ACTUAL PLOTTING OF DATA C DIMENSION T(LAST),A(LAST) LOGICAL LGAP(2000) LOGICAL LS REAL*8 TD character*4 scname COMMON /PSTUFF/ F, X12, SCNAME, IDSRN, NUMDAY,NOROT,TPTYPE INTEGER SIGN INTEGER*4 DEF REAL BOT , TOP data LS /.TRUE./ data SIGN /1/ data BOT /-2./, TOP /100./ IF(LAST.EQ.1)GO TO 9 LASTM1=LAST-1 LL = LAST+2 10 DO 12 J=1,LASTM1 J1=J IF(A(J).GE.BOT.AND.A(J).LE.TOP)GO TO 14 12 CONTINUE 9 IF(A(LAST).GE.BOT.AND.A(LAST).LE.TOP)CALL SYMBOL(T(LAST),A(LAST), 10.05,SIGN,0.0,-1) RETURN 14 CALL PLOT(T(J1),A(J1),3) DO 70 J=J1,LASTM1 DEF=1 IF(A(J).GE.BOT.AND.A(J).LE.TOP)DEF=DEF+1 IF(A(J+1).GE.BOT.AND.A(J+1).LE.TOP)DEF=DEF+2 IF (LS) GO TO (20,30,40,50),DEF GO TO (70,70,70,50), DEF C*****NEITHER VALUE DEFINED--FORGET IT. 20 GO TO 70 C*****A(J) DEFINED, A(J+1) UNDEFINED. 30 CALL SYMBOL(T(J),A(J),0.05,SIGN,0.0,-1) GO TO 70 C*****A(J) UNDEFINED, A(J+1) DEFINED. 40 CALL SYMBOL(T(J+1),A(J+1),0.05,SIGN,0.0,-1) GO TO 70 C*****BOTH VALUES DEFINED. 50 IF (LGAP(J+1)) GO TO 60 51 CONTINUE CALL PLOT(T(J+1),A(J+1),2) IF (II .EQ. 0) GO TO 70 CALL PLOT(T(J+1),A(J+1+II),2) CALL PLOT(T(J+1),A(J+2*II+1),2) CALL PLOT(T(J+1),A(J+1),2) GO TO 70 60 CONTINUE IF (J.EQ.J1) CALL SYMBOL(T(J),A(J),0.05,SIGN,0.0,-1) 63 CALL SYMBOL(T(J+1),A(J+1),0.05,SIGN,0.0,-1) 70 CONTINUE RETURN ENTRY GAP(TD) LS = .TRUE. IF (TD .LT. 0.) LS = .FALSE. RETURN END SUBROUTINE FRAMEC COMMON /NDYCOM/ NYRF,NDAYF,NEXD character*4 scname COMMON /PSTUFF/ F, X12, SCNAME, IDSRN, NUMDAY,NOROT,TPTYPE character*4 VOY1,VOY2,IMP7,IMP8 LOGICAL*4 FW(5) data VOY1/'VOY1'/,VOY2/'VOY2'/,IMP7/'IMP7'/,IMP8/'IMP8'/ C SELECT HEIGHT OF LETTERS, H, AND CORRESPONDING WITH OF LETTER + S DATA H/0.14/, WIDLET /0.12/ C THIS SUBROUTINE PROVIDES LABELING FOR THE TIME AXES FRO N-DAY PLO CALL HACK(FW) RETURN C THE ENTRY POINTS PROVIDE LABELS FOR THE MONTH OR DOY AXES C ENTRY DAYLAB(YREF) C THIS ENTRY LABELS THE BOTTOM AXIS WITH MONTH YEAR DAY OF MONTH C FIND NAME OF INITIAL MONTH AND PLOT IT CALL DATE (NDAYF, NYRF, MDAY, MNAME, MNUM) CALL SYMBOL (0.,YREF-.5,H,MNAME,0.,3) C WRITE YEAR FNYRF = FLOAT (NYRF) CALL NUMBER(4*WIDLET, YREF-.5, H, FNYRF, 0., -1) C FIND NUMBER OF DOY FOR THE LAST DAY OF THE YEAR NDYYR = 365+(3-MOD(NYRF,4))/3 NYEAR = NYRF NEXTYR = NYRF + 1 NN = NUMDAY/12 NN = MAX0(1,NN) DO 30 I=1,NUMDAY,NN NDAY=NDAYF+I-1 IF(NDAY.LE.NDYYR) GO TO 20 NDAY = NDAY - NDYYR NYEAR = NEXTYR 20 CALL DATE (NDAY, NYEAR, MDAY, MNAME, MNUM) C CENTER DAY OF MONTH X=(FLOAT(I)-.5)*F-WIDLET/2. IF (MDAY.GE.10) X=X-WIDLET/2. FMDAY = FLOAT (MDAY) CALL NUMBER(X,YREF-.25,H,FMDAY,0.,-1) 30 CONTINUE CALL SYMBOL (X12-8.*WIDLET,YREF-.5,H,MNAME,0.,3) FNYEAR=FLOAT(NYEAR) CALL NUMBER(X12-4*WIDLET,YREF-.5,H,FNYEAR,0.,-1) C WRITE SC NAME 69 IF(SCNAME.NE. IMP8) GO TO 70 CALL SYMBOL( .63,YREF-1.,2*H,'IMP 8',0.,5) GO TO 78 70 IF(SCNAME.NE. IMP7) GO TO 72 CALL SYMBOL( .63,YREF-1.,2*H,'IMP 7',0.,5) GO TO 78 72 IF(SCNAME.NE. VOY1) GO TO 73 CALL SYMBOL( .63,YREF-1.,2*H,'VOYAGER 1',0.,9) GO TO 78 73 IF(SCNAME.NE. VOY2) GO TO 74 CALL SYMBOL( .63,YREF-1.,2*H,'VOYAGER 2',0.,9) GO TO 78 74 CONTINUE 78 CONTINUE CALL SYMBOL (5.,YREF-1.,H,'PRELIMINARY ONE-HOUR AVERAGES',0.,29) CALL SYMBOL ( 3.4, YREF-1., H,'MIT', 0., 3) CALL SYMBOL ( 3.9 , YREF-1., H/2., FW, 0., 8) C*********************************************************************** C WRITE SOLAR ROTATION IF DESIRED C*********************************************************************** 79 CONTINUE FF = F NUM = NUMDAY 93 IF (NUM .LT. 41) GO TO 133 NUM = NUM/2 FF = FF*2. GO TO 93 133 CONTINUE NSKIP = (2*NUMDAY)/NUM CALL XAX(X12,YREF,-FF,NUM,-.1) RETURN ENTRY DOYLAB(YREF) FF = F NUM = NUMDAY 90 IF (NUM .LT. 41) GO TO 100 NUM = NUM/2 FF = FF*2. GO TO 90 100 CONTINUE NSKIP = (2*NUMDAY)/NUM CALL XAX(0.,YREF,FF,NUM,-.1) DO 80 I=1,NUMDAY,NSKIP IDOY=NDAYF+(I-1) IF(IDOY.GT.NDYYR) IDOY=IDOY-NDYYR X=(FLOAT(I)-.5)*F-WIDLET/2. IF(IDOY.GT.10) X=X-WIDLET/2. IF(IDOY.GT.100) X=X-WIDLET/2. CALL NUMBER(X,YREF-0.35,H,FLOAT(IDOY),0.,-1) 80 CONTINUE RETURN END SUBROUTINE XAX(XREF,YREF,DELX,NUMBRK,TIC) C CTHIS SUBROUTINE MAKES A X-AXIS WITH TICS C XREF AND YREF IS THE LOCATION OF THE BEGINNING OF THE AXIS(WITHOUT TI C DELX IS THE DELTA X BETWEEN TICS C NUMBRK IS THE NUMBER OF U-SHAPED BRACKETS, DELX WIDE WITH TICS AT ENDS C TIC IS THE SIZE AND DIRECTION OF TICS. - MEANS TIC TO THE LEFT C A NEGATIVE VALUE FOR DELX MAKES THE AXIS FROM + TO - DIRECTION C CALL PLOT (XREF, YREF+TIC,3) X=XREF DO 100 J=1,NUMBRK CALL PLOT(X,YREF,2) X=X+DELX CALL PLOT( X, YREF,2) CALL PLOT (X,YREF+TIC,2) 100 CONTINUE RETURN END SUBROUTINE LYAX(YMAX,YMIN,YB,SC,X,DX,LLOG) REAL ARLOG(10) LOGICAL LLOG REAL AMULT(10) data AMULT /4*1.,2.5,2.,1.,2.,3.,5./ DATA ARLOG /0.0,0.30103,0.47712,0.60206,0.69897,0.77815, A 0.8451,0.90309,0.95424,1./ IF (LLOG) GO TO 1000 C LINEAR AXIS INT = (ALOG10(YMAX)) IF (YMAX .LT. 1) INT = INT + 1 BINT = 10.**INT I = (YMAX-AMAX1(YMIN,0.))/BINT + 0.1 BINT = BINT*AMULT(I) CALL PLOT(X,SC*YMIN+YB,3) Y = YMIN IMOD = .4/(SC*BINT) IMOD = MAX0(1,IMOD) IF (YMIN .LT. 0.) GO TO 200 GO TO 300 200 DY = YMAX*SC IDIV = DY/.25+.25 IDIV = MAX0(IDIV,2) BINT = YMAX/FLOAT(IDIV) IMOD = 2 300 CONTINUE DO 900 ID=1,22 IF (Y .LT. YMIN) GO TO 900 IF (Y .GT. YMAX) GO TO 905 YA = SC*Y + YB CALL PLOT(X,YA,2) CALL PLOT(X+DX,YA,2) IF (DX .GT. 0.) GO TO 800 IF (MOD(ID-1,IMOD) .NE. 0) GO TO 800 CALL PLOT(X+2.*DX,YA,2) IF (ABS(ABS(Y)-AINT(ABS(Y)+0.5) ) .GT. 0.1) GO TO 800 XA = X-.5 IF (Y .LT. 0) XA = X - .65 CALL NUMBER (XA,YA+.02,.18,Y,0.,-1) CALL PLOT(X+2.*DX,YA,3) 800 CONTINUE CALL PLOT(X,YA,2) 900 Y = Y + BINT 905 YA = YB + SC*YMAX CALL PLOT(X,YA,2) RETURN 1000 CONTINUE C LOG AXIS CY = ALOG10(YMAX/YMIN) ICY = CY + 1. ALYMIN = ALOG10(YMIN) EXP = AINT(ALYMIN) IF (YMIN .LT. 1.) EXP = EXP-1 YB1 = YB - SC*EXP IEXP = EXP EXP10 = 10.**IEXP YBP = YB + SC*ALYMIN YT = YB + SC*(CY+ALYMIN) YBPS = AMAX1(AMIN1(YB,YT),YBP) CALL PLOT(X,YBPS,3) I2 = IEXP + ICY YMIN1 = YMIN*0.999 YMAX1 = YMAX*1.0001 DO 1500 IY=IEXP,I2 DO 1400 ID=1,9 Y = FLOAT(ID)*EXP10 IF (Y .GT. YMAX1) GO TO 1600 IF (Y .LT. YMIN1) GO TO 1400 YA = SC*(FLOAT(IY) + ARLOG(ID)) + YB CALL PLOT(X,YA,2) IF (ID .EQ. 5) CALL PLOT(X+1.5*DX,YA,2) IF (ID .GT. 1) GO TO 1300 CALL PLOT(X+2.*DX,YA,2) IF (DX .GT. 0.) GO TO 1300 CALL SYMBOL(X-0.6,YA,0.18,'10',0.0,2) ACY = IY CALL NUMBER (X-.3,YA+0.14,0.12,ACY,0.,-1) CALL PLOT(X+DX,YA,3) 1300 CALL PLOT(X+DX,YA,2) CALL PLOT(X,YA,2) 1400 CONTINUE EXP10 = EXP10*10. 1500 CONTINUE 1600 CALL PLOT(X,YT,2) RETURN END SUBROUTINE LINCOL (X,Y,F,JEND,TAPE) C C THIS SUBROUTINE DRAWS A TWO COLOR-LINE AT THE TOP OF AN HOURLY- C AVERAGE N-DAYPLOT. THE LINE IS RED IF THE DATA IS FROM A C SUMMARY TAPE AND BLACK IF IT'S FROM AN EDR TAPE. C LCOL MUST BE SET TO TRUE IN THE NAMELIST &SCALE. C REAL*4 Y,F,X,XF character*4 TAPE(2000) character*4 EDR , SGAP , SUM INTEGER K,JEND data EDR /'EDR'/, SGAP /'SGAP'/, SUM/'SUM '/ XF = X FHR = F/24.0 CALL PLOT (X,Y,3) DO 100 K=1,JEND X = X + FHR IF (TAPE(K) .NE. SGAP) GO TO 98 CALL PLOT (X,Y,3) GO TO 100 98 IF (TAPE(K) .EQ. SUM) CALL NEWPEN(4) IF (TAPE(K) .EQ. EDR) CALL NEWPEN(1) CALL PLOT (X,Y,2) 100 CONTINUE X = 0.0 CALL NEWPEN(1) RETURN END