Subroutine WRTFIL(Data) c c *********************************************************************** c * * c * Subroutine WRTFIL - To write the datafiles for PLTPRG * c * * c * Input Values: (from common blocks) * c * * c * Data - Array (virtual) containing the program data * c * Ncols - Number of data columns in file * c * Npoint - Array containing the number of points per column * c * Title - Character string containing the column titles * c * Ttllen - Array containing the lengths of the column titles * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Virtual Data(1) Integer*4 Isave Integer Tlen(Ncolmx),Npt(Ncolmx),Choice Character*60 File_Name Equivalence(Y(1),Tlen(1)) c Isave = 0 Ivers = 1 c c If there is no data, return c If (Ncols .EQ. 0) Then Write(6,125) 125 Format(' ERROR - No data in program - Routine Aborted ') Return End If c c Get the file name to store the data c Write(6,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J'/1X,1A1,'#6 SAVE DATA ROUTINE'// $' Enter the file name to store the data '$) Read(5,150,END=97,ERR=97) File_name 150 Format(A) c c Check the file name syntax c Call Chknam(File_Name,Iflag) If (Iflag .EQ. 1) Return c Write(6,200) 200 Format(' Do you want to save all of the data? (y/n) '$) Call Instrg('YyNn',4,Choice) If (Choice .GT. 2) Then c c Save certain data? - yes, list the columns for the user to choose c Call Liscol c c Input the data columns to save c 10 Continue Write(6,210) 210 Format(' Do you wish to save a range [first,last] of', $ ' columns ',$) Call Instrg('YyNn',4,Ifl) If (Ifl .GT. 2) Then Write(6,250) 250 Format(' Enter the data columns to save. (Enter "S"', $ ' to stop)') Call INPT(X,Numbr,Iflag,1) If (Numbr .EQ. 0) Return c c Check for bad column numbers c Else Write(6,260) 260 Format(' Enter the first and last column numbers to save') Call Inpt(X,Numbr,Iflag,0) If ((Iflag .NE. 0 .AND. Numbr .NE. 2) .OR. Numbr .EQ. 0) $ Return If (Numbr .NE. 2) Go To 10 Istart = X(1) Iend = X(2) If (Istart .LT. 1 .OR. Iend .LT. Istart .OR. Iend .GT. $ Ncols) Go To 10 Do 12 I=Istart,Iend X(I-Istart+1) = I 12 Continue Numbr = Iend - Istart + 1 End If c Iflag = Numbr Do 15 I=1,Numbr In = X(I) If (In .LT. 1 .OR. In .GT. Ncols) Then Write(6,275) In 275 Format(' Invalid Column Number - ',I6) Iflag = Iflag - 1 X(I) = 1E20 End If 15 Continue Numbr = Iflag c Do 17 I=1,Numbr Tlen(I) = Ttllen(Int(X(I)+0.1)) Npt(I) = Npoint(Int(X(I)+0.1)) c Isave = Isave + Tlen(I) + Npt(I) * 18 17 Continue Else c c Save all of the data c Do 20 I=1,Ncols X(I) = I Tlen(I) = Ttllen(I) Npt(I) = Npoint(I) c Isave = Isave + Tlen(I) + Npt(I) * 18 20 Continue Numbr = Ncols End If c c Check to see if it is a good file name, and if there is c enough room for the data (Isave is the number of blocks needed c Isave = (Isave + Numbr*12 + 90)/512 + 1 c Call Filchk(File_Name,Isave,Iflag) c c If there is an error with the file name/size/etc, return c If (Iflag .EQ. 1) Return c Open(Unit=12,NAME=File_Name,TYPE='NEW',ERR=98)!, c $ Initialsize=Isave) c Write(12,300,ERR=99) Ivers,Numbr 300 Format(16I5) c c Save number of points/column c Write(12,300,ERR=99) (Npt(I),I=1,Numbr) c c Save the column titles c Do 30 I=1,Numbr In = X(I) Call Name(Titl,In,Title,Ttllen) Write(12,400,ERR=99) (Titl(J),J=1,Ttllen(In)) 400 Format(A1) 30 Continue c c Save the data c Do 40 I=1,Numbr In = X(I) Call Point(Ipoint,In,Npoint) Write(12,450,ERR=99) (Data(J),J=Ipoint,Npoint(In)+ $ Ipoint-1) 450 Format(4G17.9) 40 Continue Close(Unit=12) Return c c Error returns c 97 Continue Write(6,460) 460 Format(' ERROR - Bad file name - routine aborted') Return c 98 Continue Write(6,475) 'opening file' 475 Format(' WARNING - Error encountered in ',A12,' - ', $ 'routine aborted') Return 99 Continue c Write(6,475) 'writing data' Close(Unit=12) Return End Subroutine LISCOL c c *********************************************************************** c * * c * Subroutine LISCOL - To list out the current data columns * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Write(6,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',1A1,'#6 current data column titles:'/ $/' # Pts TITLE'/) Do 10 I=1,Ncols Call Name(Titl,I,Title,Ttllen) Write(6,300) I,Npoint(I),(Titl(J),J=1,Ttllen(I)) 300 Format(1X,I3,1X,I4,4X,A1) 10 Continue Return End Subroutine Plcdat(Data,Iflag) c c *********************************************************************** c * * c * Subroutine Plcdat - To check the plot data prior to plotting * c * it. This routine looks to see if the curve and axis data * c * are reasonable. * c * * c * Output values: * c * * c * Iflag - Flag to indicate if there is an error in the plot * c * data (Iflag = 0, for no error, = 1 for an error). * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Caxis' Include 'Cgrid' Include 'Cplot' Include 'Clabls' Include 'Ctxblk' Include 'Clegnd' Include 'Cdefl' c Character*9 Axnam(4) Dimension Xloc(60) Virtual Data(1) c Data Axnam/' Primary ','Secondary',' Third ',' Fourth '/ Equivalence (Xloc(1),Y(1)) c Iflag = 0 c c See if the curve data is good c If (Ncurve .GT. 0) Then Do 10 I=1,Ncurve c c Check to see if the number of points in X & Y agree c If (Npoint(Xcurve(I)) .NE. Npoint(Ycurve(I))) Then Write(6,100) I 100 Format(' Error - number of points in X, Y pair for ', $ 'curve ',I2,' do '/' not match.') Iflag = 1 End If c c See if there are enough points for the curve fits c If (Npoint(Xcurve(I)) .LT. 2 .AND. Crvfit(I) .GT. 1) Then Write(6,150) I 150 Format(' Error - There are too few points for the ', $ 'curve fit type for curve ',I2,'.') Iflag = 1 End If c c Check for bad data for Logarithmic axes c If (Axtypx .EQ. 2) Then Call Getvec(Data,Npoint,Xcurve(I),X,Npt) Do 3 K=1,Npt If (X(K) .LE. 0.0) Then Write(6,105) 'X',I 105 Format(' ERROR - Bad data in ',1A1,' column of', $ ' curve number ',I2,' (log axis)') Iflag = 1 Go To 4 End If 3 Continue 4 Continue End If c If (Axtypy .EQ. 2) Then Call Getvec(Data,Npoint,Ycurve(I),X,Npt) Do 5 K=1,Npt If (X(K) .LE. 0.0) Then Write(6,105) 'Y',I Iflag = 1 Go To 6 End If 5 Continue 6 Continue End If c c Check the juncture column for least squares splines c If ((Crvfit(I) .EQ. 8 .OR. Crvfit(I) .EQ. 7) .AND. $ Npoint(Cvcol(I)) .LE. 2) Then Write(6,110) 'few',I 110 Format(' Error - There are too ',A,' points in the ', $ 'least squares juncture column'/' for curve ',I2) Iflag = 1 End If If ((Crvfit(I) .EQ. 8 .OR. Crvfit(I) .EQ. 7) .AND. $ Npoint(Cvcol(I)) .GT. 60) Then Write(6,110) 'many',I Iflag = 1 End If c If ((Crvfit(I) .EQ. 8 .OR. Crvfit(I) .EQ. 7) .AND. $ (Npoint(Cvcol(I)) .GT. 2 .AND. Npoint(Cvcol(I)) $ .LE. 60)) Then c c Make certain that there are datapoints between the junction points c Call Getvec(Data,Npoint,Xcurve(I),X,Npt) Call Sort(X,Y,Npt) Call Getvec(Data,Npoint,Cvcol(I),Xloc,Nxloc) Call Sort(Xloc,Y(100),Nxloc) c Do 15 Ii=1,Nxloc-1 Istart = -1 Iend = Npt Do 12 J=1,Npt If (Xloc(Ii) .LE. X(J) .AND. Istart .EQ. -1) $ Istart = J If (Xloc(Ii+1) .LT. X(J)) Then Iend = J - 1 Go To 13 End If 12 Continue 13 Continue Istart = Max0(1,Istart) Ntot = Iend - Istart + 1 If (Ntot .EQ. 0) Then Write(6,395) Xloc(Ii),Xloc(Ii+1),I 395 Format(' ERROR - There are no datapoints between'/ $ ' the junction points X= ',G12.5, $ ' and X= ',G12.5/' For least squares spline' $ ' fitted curve no. ',I2'.') Iflag = 1 Go To 10 End If 15 Continue End If 10 Continue End If c c Check the axis data c Do 20 I = 1, Xnumbr If (Axtypx .EQ. 2 .AND. Xmin(I) .LE. 0.0) Then Write(6,185) Axnam(I),'X' 185 Format( ' ERROR - The ',A,1X,1A1,' axis minumum is', $ ' less than or equal to zero') Iflag = 1 End If If (Axtypx .EQ. 2 .AND. Xmax(I) .GT. 2.E9) Then Write(6,190) Axnam(I),'X' 190 Format(' ERROR - The ',A,1X,1A1,' axis maxumum is too', $ ' large') Iflag = 1 End If If (Axtypx .GT. 1 .AND. Xmin(I) .GT. 0.0 .AND. Xmax(I) $ .GT. 0.0) Then Ratio = Alog10(Xmax(I)) - Alog10(Xmin(I)) If (Ratio .GT. 13.96) Then Write(6,195) Axnam(I),'X' 195 Format(' ERROR - The ',A,1X,1A1,' axis difference', $ ' between the minimum and'/' maximum is too', $ ' large') Iflag = 1 End If End If c If (Xmin(I) .GE. Xmax(I)) Then Write(6,200) Axnam(I),'X' 200 Format(' ERROR - ',1A9,1X,1A1,' axis data is bad') Write(6,210) 210 Format(' (The axis minimum is equal to or greater than', $ ' the maximum)'/) Iflag = 1 If (Xmin(I) .EQ. Xmax(I)) Then If (Xinc(I) .EQ. 0.0) Write(6,250) Else If (Axtypx .EQ. 1) Then If (Xinc(I)/(Xmax(I)-Xmin(I)) .GT. -0.005) Write(6,250) End If c Else If ((Xinc(I) .EQ. 0.0 .OR. Xinc(I)/(Xmax(I)-Xmin(I)) $ .LT. 0.005) .AND. Axtypx .EQ. 1) Then Write(6,200) Axnam(I),'X' Write(6,250) 250 Format(' (Bad increment value - negative or too small)'/) Iflag = 1 End If 20 Continue c Do 30 I=1,Ynumbr c If (Axtypy .EQ. 2 .AND. Ymin(I) .LE. 0.0) Then Write(6,185) Axnam(I),'Y' Iflag = 1 End If c If (Axtypy .EQ. 2 .AND. Ymax(I) .GT. 2.0E9) Then Write(6,190) Axnam(I),'Y' Iflag = 1 End If If (Axtypy .GT. 1 .AND. Ymin(I) .GT. 0.0 .AND. Ymax(I) $ .GT. 0.0) Then Ratio = Alog10(Ymax(I)) - Alog10(Ymin(I)) If (Ratio .GT. 13.96) Then Write(6,195) Axnam(I),'Y' Iflag = 1 End If End If c If (Ymin(I) .GE. Ymax(I)) Then Write(6,200) Axnam(I),'Y' Write(6,210) Iflag = 1 If (Ymin(I) .EQ. Ymax(I)) Then If (Yinc(I) .EQ. 0.0) Write(6,250) Else If (Axtypy .EQ. 1) Then If (Yinc(I)/(Ymax(I)-Ymin(I)) .GT. -0.005) Write(6,250) End If c Else If ((Yinc(I) .EQ. 0.0 .OR. Yinc(I)/(Ymax(I)-Ymin(I)) $ .LT. 0.005) .AND. Axtypy .EQ. 1) Then Write(6,200) Axnam(I),'Y' Write(6,250) Iflag = 1 End If 30 Continue c c Check the axis lengths c If (Xlen .LT. 0.1 .OR. Ylen .LT. 0.1) Then Write(6,300) 300 Format(' ERROR - Axis lengths are too small') Iflag = 1 End If c c See if the labels are way out of place c Do 40 I=1,Nlab If (Sizlab(I) .EQ. 0) Go To 40 If (Labcrd .EQ. 0) Then Ypt = (Ylabel(I) - Ymin(1)) / (Ymax(1)-Ymin(1)) Xpt = (Xlabel(I) - Xmin(1)) / (Xmax(1)-Xmin(1)) Else Xpt = Xlabel(I) Ypt = Ylabel(I) End If If (Abs(Xpt) .GT. 12 .OR. Abs(Ypt) .GT. 12) Then Write(6,350) I 350 Format(' ERROR - Label number ',I2,' is way off the plot') Iflag = 1 End If 40 Continue c c Check the text blocks; c Do 50 I=1,Ntxbl If (Labcrd .EQ. 0) Then Ypt = (Txtbly(I) - Ymin(1)) / (Ymax(1)-Ymin(1)) Xpt = (Txtblx(I) - Xmin(1)) / (Xmax(1)-Xmin(1)) Else Xpt = Txtblx(I) Ypt = Txtbly(I) End If If (Abs(Xpt) .GT. 12 .OR. Abs(Ypt) .GT. 12) Then Write(6,400) I 400 Format(' ERROR - Text block number ',I2, $ ' is way off the plot') Iflag = 1 End If 50 Continue c c Check the legend location c If (Sizleg .GT. 0 .AND. Nleg .GT. 1) Then If (Labcrd .EQ. 0) Then Ypt = (Yleg - Ymin(1)) / (Ymax(1)-Ymin(1)) Xpt = (Xleg - Xmin(1)) / (Xmax(1)-Xmin(1)) Else Xpt = Xleg Ypt = Yleg End If If (Abs(Xpt) .GT. 12 .OR. Abs(Ypt) .GT. 12) Then Write(6,450) 450 Format(' ERROR - The legend is way off the plot') Iflag = 1 End If End If c c Tell the user if there was a problem, no c plot will be drawn c If (Iflag .EQ. 1) Then Write(6,500) 27,27,7,7,7 500 Format(/1X,1A1,'[1;5mROUTINE ABORTED !!!',1A1,'[0m',3A1/) End If c Return End Subroutine LISRNG(Text,Ichars,Istart,Iend) c c *********************************************************************** c * * c * Subroutine LISRNG - To list out the current data columns * c * over a given range * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Byte Text(Ichars) c If (Istart .EQ. 0) Then Write(6,100) 100 Format(' Enter the column number range [first, last] to', $ ' print out: ',$) Call Indata(2,'II',Ifirst,Ilast) Ifirst = Max0(1,Ifirst) Ilast = Min0(Ncols,Ilast) Else Ifirst = Istart Ilast = Iend End If c Write(6,200) 27,(Text(I),I=1,Ichars) 200 Format(//1X,1A1,'#6 ',A1,' DATA COLUMN TITLES:'/ $/' # Pts TITLE'/) Do 10 I=Ifirst,Ilast Call Name(Titl,I,Title,Ttllen) Write(6,300) I,Npoint(I),(Titl(J),J=1,Ttllen(I)) 300 Format(1X,I3,1X,I4,4X,A1) 10 Continue Return End