Subroutine INPUT(Data) c c *********************************************************************** c * * c * SUBROUTINE INPUT - To input data from the keyboard into * c * PLTPRG. Routine uses a free format input. To stop * c * inputting data, enter 'S'. If no data is input, the program * c * will not add in that data column. More than one value can * c * be entered per line. * c * * c * The data can be entered two ways; as X-Y pairs, or in * c * a column manner. The column manner means that only the * c * X or Y values are entered at one time. This technique * c * allows the user to enter only one X axis dataset, while * c * entering many sets of Y data. * c * * c * Output Values: * c * * c * Data - Virtual array containining all of the column's * c * data - new columns added in * c * Ncols - Number of total data columns in the program - * c * incremented by this subroutine * c * Npoint - Array containing the number of points in each of * c * the data columns - new columns added in * c * Title - Character string containing all of the column * c * titles - new column titles added in * c * Ttllen - Array containing the lengths of each column title * c * in "TITLE" - new column title lengths added in * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) c Integer*4 Ich(9) c Data Ich/' (1)',' (2)',' (3)',' (4)',' (5)',' (6)',' (7)', $ ' (X)',' (Y)'/ c c Get the last point in the array DATA c Call Point(Ipoint,Ncols+1,Npoint) c c Clear the screen c Write(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J'//1X,1A1,'#6 INPUT DATA ROUTINE') c c Prompt the user for the type of input c Write(7,150) 150 Format(/' Do you want to:'//' 1) Enter data as a single column'/ $ ' 2) Enter data as X-Y Pairs'/' 3) Enter up to 7 columns'/ $ ' 4) Single column, only inputting an initial,'/ $ ' final, and increment value'// $ ' Enter 1, 2, 3, or 4: '$) Call Inchek(1,4,Jflag) c If (Ncols .EQ. Ncolmx .OR. (Jflag .EQ. 2 .AND. Ncols .EQ. $ Ncolmx-1)) Go To 95 If (Jflag .NE. 3) Then c c Get the title for single column or X-Y pair: c Write(7,250) 250 Format(/' Input the data title: ') Call Point(Ititle,Ncols+1,Ttllen) Call Linedt(Title(Ititle),Ttllen(Ncols+1),70,0) c If (Jflag .EQ. 2) Then c c Store the X-Y pair column titles: c Call Name(Titl,Ncols+1,Title,Ttllen) Ncol1 = Ncols Nadd = 2 Nchars = Ttllen(Ncols+1) Do 4 I=1,2 Call Point(Ititle,Ncol1+1,Ttllen) c c Save the title, and update the pointers c Call Rep(Title,Ititle-1,Ititle,0,Titl,Nchars) Ttllen(Ncol1+1) = Nchars + 4 Ncol1 = Ncol1 + 1 Call Rep(Title,Ititle+Nchars-1,Ititle+Nchars,0, $ Ich(7+I),4) 4 Continue End If Else c c Get the multiple column titles c Write(7,360) 360 Format(' Enter the number of columns to be input ', $ '(maximum 7): ',$) Call Inchek(1,7,Nadd) If (Nadd+Ncols .GT. Ncolmx) Go To 95 Write(7,380) 380 Format(/' Do you want to enter:'//' 1) One global title'/ $ ' 2) Individual titles for each column'// $ ' Enter 1 or 2: ',$) Call Inchek(1,2,Kflag) Ncol1 = Ncols If (Kflag .EQ. 1) Then Write(7,385) 385 Format(' Enter the global column title ') Call Linedt(Titl,Nchars,80,0) c c Store the title, appending 1-7 to the end of the global title c Do 5 I=1,Nadd Call Point(Ititle,Ncol1+1,Ttllen) Call Rep(Title,Ititle-1,Ititle,0,Titl,Nchars) Ttllen(Ncol1+1) = Nchars+4 Ncol1 = Ncol1 + 1 Call Rep(Title,Ititle+Nchars-1,Ititle+Nchars,0,Ich(I),4) 5 Continue Else c c Individual column titles c Do 7 I=1,Nadd Call Point(Ititle,Ncol1+1,Ttllen) Write(7,390) I 390 Format(' Enter the title for column number',I3,':') Call Linedt(Title(Ititle),Nchars,70,0) Ttllen(Ncol1+1) = Nchars Ncol1 = Ncol1 + 1 7 Continue End If End If c If (Jflag .LT. 4) Write(7,395) 395 Format(1x/' Input the data - enter "S" to stop') Loop = 1 c c Read the data using subroutine INPT c 10 Continue If (Jflag .EQ. 1) Then c c ******* Data entered in single column format ******* c Write(7,400) Loop 400 Format(' Point No. ',I4,' Value = ? '$) Call Inpt(X,Numbr,Iflag,0) c c See if array DATA is overfilled c Icheck = Last-I-K+2 If ( Icheck .GT. Numbr) Icheck = Numbr If (Icheck .LE. 0) Go To 30 c c Store the data in array DATA c Do 20 J=Loop,Loop+Icheck-1 Data(J+Ipoint-1) = X(J-Loop+1) 20 Continue Loop = Loop + Numbr c c Go back for more data, unless Iflag is nonzero. c If ((Loop+Ipoint) .GT. Last .OR. Iflag .NE. 0) Go To 30 c Else If (Jflag .EQ. 2 .OR. Jflag .EQ. 3) Then c c ********** Multiple data columns and X-Y pairs ********** c 25 Continue If (Jflag .EQ. 1) Then Write(7,450) Loop 450 Format(' X-Y Pair No. :',I4,' Values ? '$) Else Write(7,460) Loop 460 Format(' Point no:',I4,' Values? ',$) End If c Call Inpt(X,Numbr,Iflag,0) If (Numbr .EQ. Nadd) Then c c Correctly entered data: c Do 27 I = 1,Nadd Data((Loop-1)*Nadd+Ipoint-1+I) = X(I) 27 Continue Loop = Loop +1 If ((Loop*Nadd+Ipoint) .GT. Last .OR. Iflag .NE. 0) $ Go To 30 Else If (Numbr .EQ. 0) Then c c Stop the data input routine c Go To 30 Else Write(7,500) 7 500 Format(1X,1A1,' Incorrect number of values entered. Please', $ ' re-enter the data.') Go To 25 End If Else Go To 30 End If Go To 10 30 Continue c If (Jflag .EQ. 4) Then c c First, last, increment column c 40 Continue Write(7,510) 510 Format(' Input the first, last, and increment values for ', $ 'this column') Call Indata(3,'RRR',Amin,Amax,Ainc) If (Ainc .GT. 0.0) Loop = (Amax - Amin) / Ainc + 1 If (Loop .GT. Nptmax .OR. Ainc .EQ. 0.0) Then Write(7,520) 520 Format(' ERROR - Increment value is too small. Try again') Go To 40 Else If (Loop .LT. 0) Then Loop = - Loop Ainc = - Ainc End If c c See if we have too many points c Call Point(Ipoint,Ncols+1,Npoint) Loop = Min0(Last-Ipoint-1,Loop) If (Loop .LT. 1) Return c c Load in the values into DATA c Do 50 I=1,Loop Data(Ipoint-1+I) = Amin + (I-1) * Ainc 50 Continue Data(Ipoint+Loop-1) = Amax Loop = Loop + 1 c End If c If (Loop .NE. 1) Then c c Set flag showing that DATA has been changed c Idflag = 1 c c Update the data pointers c If (Jflag .EQ. 1 .OR. Jflag .EQ. 4) Then c c Single column is entered c Ncols = Ncols + 1 Npoint(Ncols) = Loop - 1 Nadd = 1 Else c c Multiple columns or X-Y pairs are entered. Note that the c new data was stored as A(1), B(1), C(1), .. A(2), B(2), C(2),.. c A(N), B(N), C(N).. while we need to convert it to A(1), c A(2), ... A(N), B(1), B(2), ... B(N), C(1), C(2), ... C(N)... c Do 60 I=1,Nadd Npoint(Ncols+I) = Loop - 1 60 Continue Loop = Loop - 1 Ncols = Ncols + Nadd Nad = Nadd Do 85 K = 2,Nadd c c Get the last column data and save it in array X c Do 65 I=1,Loop X(I) = Data(Ipoint + Nad*I - 1) 65 Continue J = 0 Nad = Nad - 1 c c Squeeze data, removing the last column data c Do 70 I=1,Nad*Loop J = J + 1 If (((I-1)/(Nad))*(Nad) .EQ. I-1 .AND. I .GT. 1) $ J = J+1 Data(I+Ipoint-1) = Data (J+Ipoint-1) 70 Continue Itop = Nad * Loop + Ipoint c c Restore the data saved in X at the end of data c Do 80 I = 1,Loop Data (Itop + I - 1) = X(I) 80 Continue 85 Continue c End If c c Write out the column data c Write(7,530) 27,27 530 Format(/5X,1A1,'[1;7mAdded columns:',1A1,'[0m'// $ ' Col. #Pts Title'/) Do 90 I=1,Nadd L = Ncols - Nadd + I Call Name(Titl,L,Title,Ttllen) Write(7,540) L,Npoint(L),(Titl(K), $ K=1,Ttllen(L)) 540 Format(I4,I6,4X,A1) 90 Continue Else c c If user never entered any values, return without updating c pointers c Write(7,550) 550 Format(' Column contains no values - so column is not stored') End If Return 95 Continue Write(7,600) Ncolmx 600 Format(' ERROR - a maximum of',I4,' columns is allowed'/) Return End Subroutine WRTBIN(Data) c c *********************************************************************** c * * c * Subroutine WRTBIN - 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) Byte Filnam(15) Integer*4 Isave Integer Tlen(Ncolmx),Npt(Ncolmx),Tstart(Ncolmx),Dstart(Ncolmx), $ Choice Equivalence (Y(1),Tlen(1))!,(Y(76),Npt(1)),(Y(151),Tstart(1)), c $ (Y(226),Dstart(1)) c Isave = 0 c c If there is no data, return c If (Ncols .EQ. 0) Then Write(7,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(7,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J'/1X,1A1,'#6 SAVE DATA IN BINARY', $ ' DATAFILES ROUTINE'// $ ' Enter the file name to store the data '$) Read(5,150,END=97,ERR=97) Filnam 150 Format(15A1) c c Check the file name syntax c Call Chknam(Filnam,Iflag) If (Iflag .EQ. 1) Return c Write(7,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 Write(7,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 Iflag = Numbr Do 15 I=1,Numbr In = X(I) If (In .LT. 1 .OR. In .GT. Ncols) Then Write(7,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 II = X(I) Tlen(I) = Ttllen(II) Npt(I) = Npoint(II) Call Point(Tstart(I),II,Ttllen) Call Point(Dstart(I),II,Npoint) Tstart(I) = Tstart(I) - 1 Dstart(I) = Dstart(I) - 1 Isave = Isave + Tlen(I) + Npt(I) * 4 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) Call Point(Tstart(I),I,Ttllen) Call Point(Dstart(I),I,Npoint) Tstart(I) = Tstart(I) - 1 Dstart(I) = Dstart(I) - 1 Isave = Isave + Tlen(I) + Npt(I) * 4 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*6 + 40)/512 + 1 c Call Filchk(Filnam,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=Filnam,TYPE='NEW',ERR=98,INITIALSIZE=Isave, $ Form='UNFORMATTED') c Write(12,END=99,ERR=99) Numbr c c Save number of points/column c Write(12,END=99,ERR=99) (Npt(I),I=1,Numbr) c c Save the length of each column title c Write(12,END=99,ERR=99) (Tlen(I),I=1,Numbr) c c Save the column titles c Write(12,END=99,ERR=99) ((Title(Tstart(I)+J),J=1,Tlen(I)), $ I=1,Numbr) c c Save the data c Write(12,END=99,ERR=99) ((Data(Dstart(I)+J),J=1,Npt(I)), $ I=1,Numbr) c Close(Unit=12) Return c c Error returns c 97 Continue Write(7,460) 460 Format(' ERROR - Bad file name - routine aborted') Return c 98 Continue Write(7,475) 'opening file' 475 Format(' WARNING - Error encountered in ',A12,' - ', $ 'routine aborted') Return 99 Continue c Write(7,475) 'writing data' Close(Unit=12) Return End