Subroutine MODCRV c c *********************************************************************** c * * c * Subroutine MODCRV - To modify the curve parameters of the * c * plot presentation data. This includes adding, changing, and * c * deleting curves, and changing the size of the plot symbols. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cplot' Include 'Cflags' c Character*12 Strin(4) Data Strin/' ','2nd X Axis ','2nd Y Axis ', $ '2nd X,Y Axis'/ c c Clear the screen, and print the header c Write(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',3X,1A1,'#6CURVE DATA MODIFICATION', $ ' ROUTINE') 10 Continue c c Get the curve modification option from the user c Write(7,150) Symbsz 150 Format(' Options:'//' A - (A)dd new curves'/' C - (C)hange ' $ 'existing curves'/' L - (L)ist curves'/' D - (D)elete curves'/ $ ' H - C(H)ange symbol size (current value is ',G12.5,')'/ $ ' S - (S)top'//' Enter A, C, L, D, H, or S ',$) Call Instrg('AaCcLlDdHhSs',12,Ichose) Ichose = (1+Ichose)/2 c c Options: c If (Ichose .EQ. 1) Then !***** ADD CURVES ***** c Call Displc 20 Continue N = Ncurve + 1 c Call Curvin(N,Iflag) c If (Iflag .EQ. 0) Then Ncurve = Ncurve + 1 Go To 20 End If c c Reset the screen and scroll region (modifed by Displc) c Call Sreset(0) c Else If (Ichose .EQ. 2) Then !***** CHANGE CURVE DATA ***** c If (Ncurve .LE. 0) Go To 10 c c Changing curve data - see if the user wants the curve c option menu displayed c Write(7,225) 225 Format(' Display the curve options menu? ',$) Call Instrg('YyNn',4,Ichose) c If (Ichose .LT. 3) Call Displc c 25 Continue c If (Ichose .GE. 3) Write(7,235) 27,27,27,27 235 Format(1X,1A1,'[H',1A1,'[J',1A1,'[10;24r',1A1,'[24;1f') c c Get the curve number to change c Write(7,250) 250 Format(' Enter the curve number to change (Enter "S" to stop)' $ ': '$) Call Inpt(X,I,Iflag,2) If (Iflag .EQ. 1) Go To 27 Icurve = X(1) If (I .NE. 1 .OR. Icurve .LT. 1 .OR. Icurve .GT. Ncurve) Then Write(7,275) 275 Format(' Error - Try Again') Go To 25 End If c c Print out the current curve data for this curve c 26 Continue Istrin = Xcvaxi(Icurve) + 2 * Ycvaxi(Icurve) - 2 If (Crvfit(Icurve) .GE. 0) Then Write(7,400) 27,Cvline(Icurve),Cvsymb(Icurve), $ Color(Icurve),Crvfit(Icurve),Strin(Istrin) 400 Format(1X,1A1,'[1;1f Original line type =',I2,', Symbol =', $ I3,', Color =',I2,', Curve Fit =',I2,2X,A12) Else Write(7,425) 27,Cvline(Icurve),Cvsymb(Icurve), $ Color(Icurve),-Crvfit(Icurve),Strin(Istrin) 425 Format(1X,1A1,'[1;1f Original line type =',I2,', Symbol =', $ I3,', Color =',I2,', LSQ Fit Order =',I2,2X,A12) End If c Call Name(Titl,Xcurve(Icurve),Title,Ttllen) Write(7,300) Xcurve(Icurve),(Titl(I),I=1, $ Ttllen(Xcurve(Icurve))),27 300 Format(' X (Col ',I3, $ ') Title: ',A1,A1,'[K') Call Name(Titl,Ycurve(Icurve),Title,Ttllen) Write(7,350) Ycurve(Icurve),(Titl(I),I=1, $ Ttllen(Ycurve(Icurve))),27 350 Format(' Y (Col ',I3,') Title: ', $ A1,A1,'[K') c c Write out the spline juncture columns c If (Crvfit(Icurve) .EQ. 7 .OR. Crvfit(Icurve) .EQ. 8) Then Call Name(Titl,Cvcol(Icurve),Title,Ttllen) Write(7,360) Cvcol(Icurve),(Titl(I),I=1, $ Ttllen(Cvcol(Icurve))),27 360 Format(' Spline Juncture (Col ',I3,') Title: ', $ A1,A1,'[K') Else Write(7,365) 27 365 Format(1X,1A1'[K') End If c c Get the new data from the user c Call Cvchng(Icurve,Iflag) c If (Iflag .EQ. 1) Go To 25 Ipflag = 1 Go To 26 27 Continue Call Sreset(Ichose/3) c Else If (Ichose .EQ. 3) Then c c *********** Print out the curve data for all curves *********** c Call Liscrv c Else If (Ichose .EQ. 4) Then c c Delete the "Bad" curves c If (Ncurve .LT. 1) Go To 10 Write(7,450) 450 Format(' Enter the curve number(s) to delete ',$) Call Inpt(X,Ii,Iflag,0) If (Iflag .EQ. 1) Go To 10 Do 40 I=1,Ii Icurve = X(I) If (Icurve .LT. 1 .OR. Icurve .GT. Ncurve) Then Write(7,500) 500 Format(' Input value is out of range - no curves ', $ 'deleted') Go To 10 End If 40 Continue c Call Dcurve(X,Y,Ii) c Else If (Ichose .EQ. 5) Then c c Get the new plot symbol size c 70 Continue Write(7,600) 600 Format(/' Enter the new symbol size ( standard size = 1.0) ', $ $) Call Indata(1,'R',Symbsz) Ipflag = 1 Else c c Return to the calling routine c Return c End If c c Go back to see if any other curve modifications are needed c Go To 10 End Subroutine DISPLC c c *********************************************************************** c * * c * Subroutine DISPLC - To display the curve parameter selection * c * table, and to set up the screen scrolling. The curve * c * parameter selection table is DEC REGIS graphics, and it is * c * stored in a file DP:PLTPRG.TAB. This file is just copied * c * to the terminal, and was created by program CRVSHW.FOR. * c * Also, this routine sets the scrolling region to just the * c * last few lines on the screen. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c c List the user's possible choices of curve fit, symbols, c line type (pattern), and color on the screen (from PLTPRG.TAB). c Include 'Cmain' Include 'Cflags' c Byte Line(132) Equivalence (Line(1),X(1)) c Open(Unit=12,NAME='CRV:',TYPE='OLD',ReadOnly,ERR=3) Go To 5 3 Continue Close(Unit=12) Open(Unit=12,Name='DP:PLTPRG.NON',Type='OLD',ReadOnly, $ ERR=30) c c Strip the header information out of the file c 5 Continue Read(12,150) Tttype 150 Format(A4) If (Tttype .EQ. 'VT24' .AND. Termid .EQ. 'XXXX') Then Call Termv(3,Iflag) If (Iflag .EQ. 0) Then Termid = 'NONE' Else Termid = 'VT24' End If End If If (Tttype .EQ. 'VT24' .AND. Termid .EQ. 'NONE') $ Go To 3 Read(12,*) Nfin,Iroll,Iset Do 10 I=1,Nfin Read(12,100,END=30,ERR=30) Nchars,(Line(J),J=1,Nchars) 10 Continue c Call Hiefon 20 Read(12,100,END=30,ERR=30) Nchars,(Line(I),I=1,Nchars) 100 Format(Q,132A1) If (Iset .EQ. 0) Then Write(7,200) (Line(I),I=1,Nchars) 200 Format(1X,A1) Else Write(7,250) (Line(I),I=1,Nchars) 250 Format('+',A1,$) End If Go To 20 30 Continue Close(Unit=12) Call Hiefof c c Set the screen scrolling, and write the screen header c Ir = 24 - Iroll Isp = Log10(Ir*1.0) + 1 Write(7,300) 27,Ir,27,27,27,27 300 Format(1X,1A1,'[',I,';24r',1A1,'[1;1f',30X,A1,'[7mCURVE', $ ' PARAMETER SELECTION',1A1,'[0m',1A1,'[24;1f') Return End Subroutine Cvchng(Icurve,Iflag) c c *********************************************************************** c * * c * Subroutine Cvchng - To change the curve parameters. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cplot' Include 'Caxis' c Character*9 Colr(8),Symb(12) c Data Colr/'Black ','Red ','Dk. Green','Blue ', $ 'Orange ','Purple ','Lt. Green','Brown '/ Data Symb/'None ','Triangle ','Square ','Diamond ', $ 'Hexagon ','X shape ','Cross ','Circle ', $ 'Dot ','Star ','Hourglass','Down Tri.'/ c 10 Continue Iflag = 0 c Write(7,100) 27,Icurve 100 Format(1X,1A1,'[24;1H'/' Curve change options for curve number', $ I3/' D (D)ata columns | L (L)ine type'/ $ ' F curve (F)it | Y s(Y)mbol type'/ $ ' C (C)olor of the line | A (A)xis to use'/ $ ' Enter D, L, F, Y, C, A, or S (to stop) ',$) c Call Instrg('DdCcLlFfYyAaSs',14,Ic) Ic = (1 + Ic) / 2 If (Ic .EQ. 1) Then c c Change the data column numbers: c 20 Continue Write(7,150) 150 Format(' Enter the X and Y column numbers ',$) Call Indata(2,'II',Xcurve(Icurve),Ycurve(Icurve)) c Call Colchk(Xcurve(Icurve),Ycurve(Icurve),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 Else If (Ic .EQ. 2) Then c c Change the curve color c Write(7,225) (I,Colr(I),I=1,8) 225 Format(/' Select colors:'/2(4(I5,5X,1A9)/) $ ' Enter 1-8 ',$) Call Inchek(1,8,Color(Icurve)) Else If (Ic .EQ. 3) Then c c Change the line type (Solid, dashed, etc) c Write(7,250) 250 Format(' Enter the line type number: ',$) Call Inchek(1,10,Cvline(Icurve)) Else If (Ic .EQ. 4) Then 25 Continue c c Change the curve fit to use c Write(7,300) 300 Format(/ $ ' Avaliable curve fits: 4) Parametric Spline', $ ' (Type A)'/ $ ' 0) No Curve Drawn 5) Parametric Spline', $ ' (Type B)'/ $ ' 1) Straight Lines 6) Parametric Spline', $ ' (Type C)'/ $ ' 2) Least Squares Fit 7) Least Squares Spline', $ ' (type A)'/ $ ' 3) Cubic Spline Fit 8) Least Squares Spline', $ ' (type B)'/ $ ' Enter the curve fit number (0-8) ',$) Call Inchek(0,8,Crvfit(Icurve)) If (Crvfit(Icurve) .EQ. 2) Then c c If Least Squares are picked, get the order of the c polynomial c Write(7,350) 350 Format(' Enter the order of the least squares fit', $ ' (3 = cubic) ',$) Call Inchek(1,20,I) Crvfit(Icurve) = -I Else If (Crvfit(Icurve) .EQ. 7 .OR. Crvfit(Icurve) .EQ. 8) Then 37 Continue Write(7,360) 360 Format(' Enter the number of the column containing the', $ ' juncture points ',$) c Call Inchek(1,Ncols,Cvcol(Icurve)) Call Inpt(X,N,Ifl,2) If (Ifl .EQ. 1) Go To 25 If (N .NE. 1) Go To 37 If (X(1) .LT. 1 .OR. X(1) .GT. Ncols) Go To 37 Cvcol(Icurve) = X(1) Call Name(Titl,Cvcol(Icurve),Title,Ttllen) Write(7,370) (Titl(I),I=1,Ttllen(Cvcol(Icurve))) 370 Format(' Column title is :'/1X,A1/ $ ' Is it correct? (y/n) ',$) Call Instrg('YyNn',4,Ich) If (Ich .GT. 2) Go To 37 End If c Else If (Ic .EQ. 5) Then c c Get the new symbol type to use c Write(7,400) (I-1,Symb(I),I=1,12) 400 Format(/' Select the new symbol to use:'/ $ 3(4(I3,2X,1A9,6X)/) $ ' Enter the symbol number to use ',$) Call Inchek(0,11,Cvsymb(Icurve)) Else If (Ic .EQ. 6) Then c c Get the axis that the curve is to be plotted using c If (Xnumbr .GT. 1) Then Write(7,450) 'X','X' 450 Format(' Enter 1 for the primary ',A1,' axis, 2 for the', $ ' secondary ',A1,' axis ',$) Call Inchek(1,2,Xcvaxi(Icurve)) End If If (Ynumbr .GT. 1) Then Write(7,450) 'Y','Y' Call Inchek(1,2,Ycvaxi(Icurve)) End If c c No secondary X and Y axes - inform the user c If (Xnumbr+Ynumbr .EQ. 2) Write(7,500) 500 Format(' There are no secondary X or Y axes - change ', $ 'ignored') Else Iflag = 1 End If Return End Subroutine Dcurve(X,Y,Ndel) c c *********************************************************************** c * * c * Subroutine Dcurve - To delete curves from the plot * c * presentation. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cplot' Include 'Cflags' c Dimension X(1),Y(1) c Ipflag = 1 c Call Sort(X,Y,Ndel) c c Delete the curve parameters data from the c various pointer arrays c Do 20 J=1,Ndel Icurve = X(Ndel+1-J) Ncurve = Ncurve - 1 If (Icurve .LE. Ncurve) Then Do 10 I=Icurve,Ncurve Xcurve(I) = Xcurve(I+1) Ycurve(I) = Ycurve(I+1) Cvline(I) = Cvline(I+1) Cvsymb(I) = Cvsymb(I+1) Color(I) = Color(I+1) Crvfit(I) = Crvfit(I+1) Xcvaxi(I) = Xcvaxi(I+1) Ycvaxi(I) = Ycvaxi(I+1) Cvcol(I) = Cvcol(I+1) 10 Continue End If 20 Continue Return End Subroutine Sreset(Iflag) c c *********************************************************************** c * * c * Subroutine Sreset - To reset the screen when finished with * c * Curve menu display. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Byte Line(132) Equivalence (Line(1),X(1)) c If (Iflag .GT. 0) Go To 30 c Open(Unit=12,Name='CRV:',Type='OLD',Readonly,ERR=5) Go To 10 5 Continue Close(Unit=12) Open(Unit=12,Name='DP:PLTPRG.NON',Type='OLD',ReadOnly,ERR=30) 10 Continue Read(12,100) Tttype 100 Format(A4) If (Tttype .EQ. 'VT24' .AND. Termid .EQ. 'NONE') $ Go To 5 Read(12,*) Nlines,Iscrol,Iset If (Nlines .EQ. 0) Go To 30 c Call Hiefon Do 20 J=1,Nlines Read(12,200) Nchars,(Line(I),I=1,Nchars) 200 Format(Q,132A1) Write(7,300) (Line(I),I=1,Nchars) 300 Format(1X,A1) 20 Continue Call Hiefof 30 Continue Close(Unit=12) c c Reset the scroll region when done (modified by Displc) c Write(7,400) 27,27 400 Format(1X,1A1,'[1;24r',1A1,'[24;1f') Return End