Subroutine MAKEPL c c *********************************************************************** c * * c * Subroutine MAKEPL - To make up a plot. This subroutine * c * enables the user to set a plot size, axes, curves, labels, * c * grids, and a legend. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cplot' Include 'Clabls' Include 'Caxis' Include 'Ctxblk' Include 'Cgrid' Include 'Cdefl' Include 'Cflags' c Write(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',1X,1A1,'#6 PLOT SETUP ROUTINE'//) c c See if there a previous plot and ask if it is ok to c destroy this previous data c If (Xmin(1) .LT. Xmax(1) .AND. Xlen .GT. 0.0) Then Write(7,200) 200 Format(' Previous plot presentation exists - OK to destroy?', $ ' (y/n) '$) Call Instrg('YyNn',4,Ichose) If (Ichose .GT. 2) Return End If Ntxbl = 0 c c Set flag to show plot has been modified c Ipflag = 1 c c Set the plot defaults c Call Deflt c c Get the axes and grid data c Call Axin c c Set the size of the plot symbols to the default size c Symbsz = 1.0 c c List the user's choices of curve fit, symbols, line type, c and color on the screen. c Call Displc c Ncurve = -1 c c Get the curve data to plot from the user c 10 Continue Ncurve = Ncurve + 1 c Call Curvin(Ncurve+1,Iflag) c If (Iflag .EQ. 0) Go To 10 c c Re-set the terminal screen (altered by Displc) c Call Sreset(0) c c Get the label data from the user c Call Labin c c Get the Legend data from the user c Call Legin(0) c Return End Subroutine MODPLT c c *********************************************************************** c * * c * Subroutine MODPLT - To Modify the current plot parameters. * c * This routine mainly calls the subroutines to modify the * c * plot parameters. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Clegnd' Include 'Caxis' Include 'Clabls' Include 'Ctxblk' Include 'Cflags' c c See what plot parameters are to be changed c 20 Continue Write(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',2X,1A1,'#6 PLOT MODIFICATION ', $ 'ROUTINE') Write(7,200) 200 Format(/' Modify:'//' A (A)xis data'/' C (C)urve data'/ $ ' L (L)abel data'/' E L(E)gend data'/' T (T)ext blocks'/ $ ' D (D)efault values'/ $ ' R (R)eset the default values'/ $ ' S (S)top'//' Enter A, C, L, E, T, D, R, or S: ', $) Call Instrg('AaCcLlEeTtDdRrSs',16,Ichose) Ichose = (1+Ichose)/2 c If (Ichose .EQ. 1) Then c c Change axis data c Call Modax c Else If (Ichose .EQ. 2) Then c c Change curve data c Call Modcrv c Else If (Ichose .EQ. 3) Then c c Change label data c Call Modlab c Else If (Ichose .EQ. 4) Then c c Change legend data c Call Modleg c Else If (Ichose .EQ. 5) Then c c Modify text blocks c 30 Continue Call Modtxt(Ich) If (Ich .EQ. 1) Then Call Adtxbl Else If (Ich .EQ. 2) Then Call Chgtxt Else If (Ich .LT. 1) Then N = 0 Call Deltxt(-Ich,X,N) Else Go To 20 End If Go To 30 Else If (Ichose .EQ. 6) Then c c Change the plot default values c Call Mddflt c Else If (Ichose .EQ. 7) Then c c Reset the default values c Write(7,250) 250 Format(' Do you really want to reset the default values?', $ ' (y/n) ',$) Call Instrg('YyNn',4,Ich) If (Ich .LT. 3) Then c Ipflag = 1 c c Save things you really don't want to reset c L1 = Labcrd L2 = Xnumbr L3 = Ynumbr L4 = Locleg L5 = Xtop c Call Deflt c Labcrd = L1 Xnumbr = L2 Ynumbr = L3 Locleg = L4 Xtop = L5 End If c Else c c **** Finished **** c Return c End If c c Clear the screen and loop back to see if the user c wants to change anything else c Write(7,300) 27,27 300 Format(1X,1A1,'[H',1A1,'[J') Go To 20 End Subroutine Lacord(Labcrd) c c *********************************************************************** c * * c * Subroutine LACORD - To get from the user, the label and * c * legend coordinate system. There are two choices - the * c * first assumes that the labels and legend coordinates are * c * given in the same coordinate system as the primary X and Y * c * axes. The second sets the lower left corner of the area * c * defined by the plot axes as 0,0 and the upper right as 1,1. * c * The first method is refered to as the local coordinate * c * system; the second as the global coordinate system. * c * * c * Example: Say you had a plot with the X axis minimum and * c * maximum of 10,60, and the Y axis minimum and maximum of * c * 0,15. To locate a label at the center of the plot using the * c * first (local) system, the x and y coordinates would be * c * 35 , 7.5, while using the second (global) system, the x and * c * y coordinates would be 0.5 , 0.5. * c * * c * It should be noted that the second (globand method is the * c * preferred one because the relative location of the labels * c * and legend on the plot won't change if the user changes * c * the x and/or y axis minimum and maximum values. * c * * c * Output value: * c * * c * Labcrd - Flag to indicate whether the label and legend * c * coordinate system is local (labcrd = 0) or * c * global (Labcrd = 1) * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c If (Labcrd .EQ. -1) Then Write(7,125) 125 Format(/' Label coordinate system... Are the label coordinates', $ ' in the same coordinate'/' system as the primary X and', $ ' Y axes? (y/n) ',$) Call Instrg('YyNn',4,Labcrd) Labcrd = (Labcrd - 1) / 2 If (Labcrd .EQ. 1) Write(7,140) 140 Format(/' Labels are then assumed to lie in a coordinate', $ ' system having'/' the lower left corner as 0,0; and', $ ' the upper right corner as 1,1.'/) End If Return End Subroutine Getleg(Ileg,Iflag) c c *********************************************************************** c * * c * Subroutine GETLEG - To get the Legend labels from the * c * user. * c * * c * Input values: * c * * c * Ileg - Label number + 1 to input (Ileg = 1 is the legend * c * title) * c * * c * Output values: * c * * c * Iflag - Flag indicating whether user wants to add more * c * labels to the legend (Iflag = 0) * c * Lableg - Character string holding the legend labels * c * Lcolor - Array conta ing the color of the lines and symbols * c * defined in the legend * c * Linleg - Array containing the line types defined in legend * c * Lleg - Lengths of the text strings stored in "LABLEG" * c * Symleg - Array containing the symbol types defined in legend * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Clegnd' Include 'Cplot' c Character*9 Colr(8) c Data Colr/'Black ','Red ','Dk. Green','Blue ', $ 'Orange ','Purple ','Lt. Green','Brown '/ c Iflag = 0 c If (Ileg .GT. 1) Then c c For entering legend labels; c K = Ileg - 1 Write(7,100) K 100 Format(/' Enter the text for legend label ',I2,' (return', $ ' to stop)') c If (Ncurve .GE. K .AND. Legtit .GT. 0) Then c c Display the corresponding curve column titles c Call Point(Ix,Xcurve(K),Ttllen) Call Point(Iy,Ycurve(K),Ttllen) Write(7,110) Xcurve(K),(Title(J),J=Ix, $ Ttllen(Xcurve(K))+Ix-1),Ycurve(K), $ (Title(L),L=Iy,Ttllen(Ycurve(K))+Iy-1) 110 Format(' (Corresponding curve is:'/' X (column',I4,'): ', $ A1/' Y (Column',I4,'): ', $ A1' )'/) End If Else c c For entering the legend title; c Write(7,150) 150 Format(/' Enter the text for the legend title (return for no', $ ' title)') End If c Call Point(K1,Ileg,Lleg) Call Linedt(Titl,J,80,0) c c If no more labels (label of zero length), return c If (J .EQ. 0 .AND. Ileg .GT. 1) Then Iflag = 1 Return End If c c Save the legend label c Call Point(Kk,Nleg+1,Lleg) Call Point(K1,Ileg,Lleg) Call Rep(Lableg,Kk,K1,Lleg(Ileg),Titl,J) Lleg(Ileg) = J If (Ileg .EQ. 1) Return c c Input the proceeding symbol type c Write(7,300) 300 Format(/' Do you want a SYMBOL preceeding this', $ ' Label? (y/n) ',$) If (Ncurve .GE. K .AND. Legtit .NE. 0) Then c c Display the corresponding curve symbol c Write(7,310) 310 Format('+') If (Cvsymb(K) .EQ. 0) Then Write(7,320) K 320 Format(' (Curve',I3,' has no symbol) ',$) Else Write(7,340) K,Cvsymb(K) 340 Format(' (Curve',I3,' has symbol no. ',I2,') ',$) End If End If c Call Instrg('YyNn',4,Ichose) c c Get the symbol number (same numbers as used for the curves) c If (Ichose .LT. 3) Then Write(7,400) 400 Format(' Enter the symbol number ',$) Call Inchek(1,11,Symleg(Ileg)) Else Symleg(Ileg) = 0 End If c c Input the Line pattern type c Write(7,500) 500 Format(/' Do you want a LINE preceeding this label? ', $ '(y/n) ',$) If (Ncurve .GE. K .AND. Legtit .NE. 0) Then c c Display line type of corresponding curve c Write(7,310) If (Cvline(K) .EQ. 0) Then Write(7,520) K 520 Format(' (Curve',I3,' has no line) ',$) Else Write(7,530) K, Cvline(K) 530 Format(' (Curve',I3,' has line pattern ',I2,') ',$) End If End If c Call Instrg('YyNn',4,Ichose) If (Ichose .LT. 3) Then Write(7,600) 600 Format(' Enter the line pattern number ',$) Call Inchek(1,10,Linleg(Ileg)) Else Linleg(Ileg) = 0 End If c c Get the legend line and symbol color c Lcolor(Ileg) = 1 ! Default color is black c If (Linleg(Ileg) .GT. 0 .OR. Symleg(Ileg) .GT. 0) Then Write(7,700) 700 Format(' Do you want the line and/or symbol a special', $ ' color? (y/n) ',$) c c Display the corresponding curve color c If (Ncurve .GE. K .AND. Legtit .NE. 0) Then Write(7,310) Write(7,710) K,Colr(Color(K)) 710 Format(' (Curve',I3,' is ',A9,') ',$) End If c Call Instrg('YyNn',4,Ich) If (Ich .LT. 3) Then Write(7,800) (I,Colr(I),I=1,8) 800 Format(' Colors are:'//8(I2,')',2X,A9/)/' Enter 1-8: ',$) Call Inchek(1,8,Lcolor(Ileg)) End If End If c Return End Subroutine CURVIN(Ncurv,Iflag) c c *********************************************************************** c * * c * Subroutine CURVIN - To Input the curves to plot * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cplot' Include 'Caxis' Include 'Cflags' c c See if we have too many curves (Ncurve = 20) c If (Ncurv .GT. 20) Then Iflag = 1 Return End If c c Enter the columns making up the curves to plot c 10 Continue Write(7,100) 27,Ncurv c 100 Format(1X,1A1,'[24;1f'/' Enter the X and Y column numbers for', $ ' curve number ',I3/' (Enter "S" to stop) ',$) c Call Inpt(X,N,Iflag,2) If ( Iflag .EQ. 0) Then c c Print out the column titles, and see if the user likes c them c Xcurve(Ncurv) = X(1) Ycurve(Ncurv) = X(2) Call Colchk(Xcurve(Ncurv),Ycurve(Ncurv),Iflag,7) c c If Iflag is 1, then there was an error in the column numbers. c Go back and get new column choices. c If (Iflag .EQ. 1) Go To 10 c c See if the user likes the column choices c Write(7,150) 150 Format(' Are the column numbers correct? (y/n) ',$) Call Instrg('NnYy',4,Iflg) If (Iflg .LE. 2) Go To 10 c c Write the names of the columns at the top of the screen c Ipflag = 1 c Call Name(Titl,Xcurve(Ncurv),Title,Ttllen) Nchars = Ttllen(Xcurve(Ncurv)) Write(7,300) 27,Xcurve(Ncurv),(Titl(I),I=1,Nchars),27 300 Format(1X,1A1,'[H'/' X (column ',I3,') title: ',A1, $ 1A1,'[K') Call Name(Titl,Ycurve(Ncurv),Title,Ttllen) Nchars = Ttllen(Ycurve(Ncurv)) Write(7,350) Ycurve(Ncurv),(Titl(I),I=1,Nchars),27,27,27 350 Format(' Y (column ',I3,') title: ',A1,A1,'[K'/ $ 1X,1A1,'[K',1A1,'[24;1f') c c Get the curve options c 30 Continue Write(7,500) 500 Format(////' Enter the line pattern, symbol pattern, curve ', $ 'color, and curve fit') 40 Continue Call Indata(4,'IIII',Cvline(Ncurv),Cvsymb(Ncurv),Color(Ncurv), $ Crvfit(Ncurv)) c c Check the selected curve options c If (Cvline(Ncurv) .LT. 1 .OR. Cvline(Ncurv) .GT. 10 .OR. $ Cvsymb(Ncurv) .LT. 0 .OR. Cvsymb(Ncurv) .GT. 11 .OR. $ Color(Ncurv) .LT. 1 .OR. Color(Ncurve) .GT. 8 .OR. $ Crvfit(Ncurv) .LT. 0 .OR. Crvfit(Ncurv) .GT. 8) Then Write(7,727) 727 Format(' Error - the values are out of range - Try Again') Go To 40 End If c c If the curve fit is least squares, get the order of the fit c If (Crvfit(Ncurv) .EQ. 2) Then Write(7,730) 730 Format(' Enter the order of the polynomial fit ', $ '(cubic = 3) '$) Call Inchek(1,20,I) Crvfit(Ncurv) = - I End If c c Least squares cubic spline fit; c If (Crvfit(Ncurv) .EQ. 7 .OR. Crvfit(Ncurv) .EQ. 8) Then 50 Continue Write(7,735) 735 Format(' Enter the column no. containing the juncture', $ ' points ',$) c Call Inchek(1,Ncols,Cvcol(Ncurv)) Call Inpt(X,N,Ifl,2) If (Ifl .EQ. 1) Go To 30 If (N .NE. 1 .OR. X(1) .LT. 1 .OR. X(1) .GT. Ncols) Go To 50 Cvcol(Ncurve) = X(1) Call Name(Titl,Cvcol(Ncurv),Title,Ttllen) Write(7,737) (Titl(I),I=1,Ttllen(Cvcol(Ncurv))) 737 Format(' The column title is:'/1X,A1/ $ ' Is the column correct? (y/n) ',$) Call Instrg('YyNn',4,I) If (I .GT. 2) Go To 50 Write(7,739) 27,27,Cvcol(Ncurv),(Titl(I),I=1, $ Ttllen(Cvcol(Ncurv))),27,27 739 Format(1X,1A1,'7',1A1,'[H'///' Junct. Col #',I3,3X, $ A1,'[K',1A1,'8',$) End If c c Get the axes that the curves correspond to c Xcvaxi(Ncurv) = 1 Ycvaxi(Ncurv) = 1 If (Xnumbr .EQ. 2 .OR. Ynumbr .EQ. 2) Then Write(7,740) 740 Format(' Select the corresponding axes:') If (Xnumbr .EQ. 2) Then 55 Write(7,750) 'X','X' 750 Format(' Enter 1 for the primary ',A1,' axis, 2 for the', $ ' secondary ',A1,' axis: ',$) Call Inchek(1,2,Xcvaxi(Ncurv)) End If If (Ynumbr .EQ. 2) Then 60 Write(7,750) 'Y','Y' Call Inchek(1,2,Ycvaxi(Ncurv)) End If End If 70 Continue c c See if the user likes the current curve c Write(7,800) 800 Format(' Is the curve data correct? (y/n) ',$) Call Instrg('NnYy',4,Iflg) If (Iflg .LE. 2) Go To 10 End If Return c End Subroutine Liscrv c *********************************************************************** c * * c * Subroutine Liscrv - To list out the curve parameters * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cplot' c Character*12 Strin(4) Data Strin/' ','2nd X Axis ','2nd Y Axis ', $ '2nd X,Y Axis'/ c c *********** Print out the curve data for all curves *********** c Write(7,100) 27,27 100 Format(1X,1A1,'[H',1A1,'[J') Nline = 0 Do 10 Ii=1,Ncurve Nline = Nline + 4 Icurve = Ii Write(7,150) Ii 150 Format(1X,30('*'),' Curve ',I2,2X,30('*')) Call Name(Titl,Xcurve(Ii),Title,Ttllen) Write(7,200) Xcurve(Ii),(Titl(I),I=1,Ttllen(Xcurve(Ii))) 200 Format(' X (Col ',I3, $ ') Title: ',A1,A1,'[K') Call Name(Titl,Ycurve(Ii),Title,Ttllen) Write(7,250) Ycurve(Ii),(Titl(I),I=1,Ttllen(Ycurve(Ii))) 250 Format(' Y (Col ',I3,') Title: ', $ A1,A1,'[K') If (Crvfit(Ii) .EQ. 7 .OR. Crvfit(Ii) .EQ. 8) Then Call Name(Titl,Cvcol(Ii),Title,Ttllen) Write(7,300) Cvcol(Ii),(Titl(I),I=1, $ Ttllen(Cvcol(Ii))) 300 Format(' Spline Juncture (Col ',I3,') Title: ', $ A1,A1,'[K') Nline = Nline + 1 End If c Istrin = Xcvaxi(Icurve) + 2 * Ycvaxi(Icurve) - 2 If (Crvfit(Ii) .GE. 0) Then Write(7,350) Cvline(Ii),Cvsymb(Ii),Color(Ii), $ Crvfit(Ii),Strin(Istrin) 350 Format(' Current line type =',I2,', Symbol =', $ I3,', Color =',I2,', Curve Fit =',I2,2X,A12) Else Write(7,400) Cvline(Ii),Cvsymb(Ii),Color(Ii), $ -Crvfit(Ii),Strin(Istrin) 400 Format(' Current line type =',I2,', Symbol =',I3, $ ', Color =',I2,', LSQ Fit Order =',I2,2X,A12) End If c c Pause the program if all the curves have been listed, c or the screen is full c If (Nline .GE. 20 .OR. Ii .EQ. Ncurve) Then Call Spause Nline = 0 End If c 10 Continue Return End