Subroutine Merge(Data) c c *********************************************************************** c * * c * Subroutine Merge - To merge groups of column data together. * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) c Dimension Icol(40) c Write(7,100) 27 100 Format(/1X,1A1,'#6 MERGE DATA COLUMNS TOGETHER'/) c c See if there is room to merge: c If (Ncols .EQ. Ncolmx) Then Write(7,125) 7 125 Format(' No more room for additional columns - routine ', $ 'aborted',1A1) Return End If c c Select the method of merging columns c Write(7,150) 150 Format(' Do you wish to:'// $ ' 1 Merge groups of columns together'/ $ ' 2 Insert a second column into a first column'/ $ ' 3 Stop'// $ ' Enter 1, 2, or 3: ',$) Call Instrg('123Ss',5,Imerge) c If (Imerge .GE. 3) Return c 10 Continue c c Prompt the user for the columns to merge c Write(7,200) 200 Format(' Enter the column numbers to merge (or "S" to stop): ') Call Inpt(X,Nmerge,Iflag,2) If (Iflag .EQ. 1) Return c c To merge, you must give at least two columns c If (Nmerge .LT. 2) Then Write(7,225) 7 225 Format(' ERROR - You must input at least two columns! ',1A1) Go To 10 End If c c Allow only two columns for insertion merging c If (Nmerge .NE. 2 .AND. Imerge .EQ. 2) Then Write(7,250) 7 250 Format( ' ERROR - You can use only two columns at a time', $ ' with insertion merging',1A1) Go To 10 End If c c See if the column numbers are good, and see if there c are too many points c Number = 0 Do 20 I=1,Nmerge Icol(I) = X(I) Number = Number + Npoint(Icol(I)) If (Icol(I) .LT. 1 .OR. Icol(I) .GT. Ncols) Then Write(7,300) 7 300 Format(' Column number out of range. Try again ',1A1) Go To 10 End If 20 Continue c If (Number .GT. Nptmax) Then Write(7,325) 7 325 Format(' Too many points in the resultant column. Routine', $ ' aborted',1A1) Return End If c Write(7,350) 350 Format(' Selected columns:'/) c c List the column numbers c Do 30 I=1,Nmerge Call Name(Titl,Icol(I),Title,Ttllen) Write(7,400) Icol(I),(Titl(J),J=1,Ttllen(Icol(I))) 400 Format(' Column',I4,': ',A1) 30 Continue c c See if the user likes them c Write(7,450) 450 Format(/' Are the column numbers correct? (y/n) ',$) Call Instrg('YyNn',4,Iflag) If (Iflag .GT. 2) Go To 10 c c Get the title to store the data as c Write(7,500) 500 Format(' Enter the title for the resultant data column:') Call Point(Ititle,Ncols+1,Ttllen) Call Linedt(Title(Ititle),Ttllen(Ncols+1),70,0) c c Start to merge the columns c Call Point(Ipoint,Ncols+1,Npoint) c If (Imerge .EQ. 1) Then c c Merging a group of columns: c Do 50 I=1,Nmerge Call Point(Iloc,Icol(I),Npoint) Do 40 J=1,Npoint(Icol(I)) Data(Ipoint) = Data(Iloc+J-1) Ipoint = Ipoint + 1 40 Continue 50 Continue c Ncols = Ncols + 1 Npoint(Ncols) = Number Else c c Merging with insertion: c Write(7,650) 650 Format(' Enter the point number in the first column to ', $ 'insert the second column after:') Call Inchek(0,Npoint(Icol(1)),Insert) Call Point(Iloc,Icol(1),Npoint) c c The first part of the first column: c Do 60 I=1,Insert Data(Ipoint) = Data(Iloc+I-1) Ipoint = Ipoint + 1 60 Continue c c The second column: c Call Point(Iloc2,Icol(2),Npoint) Do 70 I=1,Npoint(Icol(2)) Data(Ipoint) = Data(Iloc2+I-1) Ipoint = Ipoint + 1 70 Continue c c The remainder of the first column: c Do 80 I=Insert+1,Npoint(Icol(1)) Data(Ipoint) = Data(Iloc+I-1) Ipoint = Ipoint + 1 80 Continue Ncols = Ncols + 1 Npoint(Ncols) = Npoint(Icol(1)) + Npoint(Icol(2)) End If c Idflag = 1 Return End Subroutine Sorter(Data) c c *********************************************************************** c * * c * Subroutine Sorter - To sort groups of data columns in * c * ascending or decending order * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) Dimension Icol(80) c c Get the data column numbers to sort c Write(7,100) 27 100 Format(/1X,1A1,'#6 Data Column Sorting Routine'/) c 10 Continue c Write(7,125) 125 Format(' Enter the data columns numbers to sort, with the first'/ $ ' column the column to sort by:') Call Inpt(X,Nc,Iflag,2) If (Nc .EQ. 0) Return Do 20 I=1,Nc Icol(I) = X(I) c c See if the column number is in range c If (Icol(I) .LT. 1 .OR. Icol(I) .GT. Ncols) Then Write(7,150) 150 Format(' ERROR - a column number is out of range - try', $ ' again') Go To 10 End If c If (Npoint(Icol(I)) .NE. Npoint(Icol(1))) Then Write(7,200) Icol(1),Icol(I) 200 Format(' ERROR - The number of points in columns ',I3, $ ' and ',I3,' do not match!') Go To 10 End If 20 Continue c c List the column numbers c Write(7,250) 250 Format(' Selected columns:'/) Do 30 I=1,Nc Call Name(Titl,Icol(I),Title,Ttllen) Write(7,300) Icol(I),(Titl(J),J=1,Ttllen(Icol(I))) 300 Format(' Column',I4,': ',A1) 30 Continue c c See if the user likes them c Write(7,350) 350 Format(/' Are the column numbers correct? (y/n) ',$) Call Instrg('YyNn',4,Iflag) If (Iflag .GT. 2) Go To 10 c c Find out which direction to sort c Write(7,400) 400 Format(/' Select sorting direction:'//' 1) Increasing'/ $ ' 2) Decreasing'/' 3) Stop'//' Enter 1-3: ',$) c Call Instrg('123Ss',5,Ichose) If (Ichose .GE. 3) Return Call Getvec(Data,Npoint,Icol(1),X,Npts) c c Get the sorting index c Do 40 I=1,Npts Y(I) = I c c To get descending order, make the column values negative c If (Ichose .EQ. 2) X(I) = -X(I) c 40 Continue c c Sort the first column to get the sort index (Y): c Call Sort(X,Y,Npts) c c Now, sort all of the columns c Do 60 I=1,Nc Call Getvec(Data,Npoint,Icol(I),X,Npts) Call Point(Ipoint,Icol(I),Npoint) Do 50 J=1,Npts L = Y(J) Data(Ipoint-1+J) = X(L) 50 Continue 60 Continue Idflag = 1 Return End Subroutine DEFLT c c *********************************************************************** c * * c * Subroutine Deflt - To set the plot default values for * c * things that will be changed little * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Clegnd' Include 'Clabls' Include 'Caxis' Include 'Cdefl' Include 'Cgrid' c Grdcmj = 1 ! Set grid colors to black Grdcmr = 1 c Axcolr = 1 ! Set axis, labels, and legend colors to black Atxclr = 1 Lacolr = 1 Lecolr = 1 c Thikmj = 0.01 ! Set the grid thicknesses Thikmr = 0.005 c Axthik = 0.01 ! Set the axis & curve thickness Cvthik = 0.01 c Axchst = 1 ! Set the Axis, label, and legend character set Lachst = 1 Lechst = 1 c Spchar = 2 ! Set the character spacing to proportional c Axtypx = 1 ! Set the axes to normal Axtypy = 1 c Ticdir = 1 ! Set the axes ticks to inward c Labcrd = -1 ! Set the label and legend coordinate systems c Xnumbr = 1 ! Set the axis pointer to the primary axes Ynumbr = 1 Xtop = 1 c Locleg = 1 ! Set the legend location to upper left Boxleg = 1 ! Set the box perimeter to off c Return End Subroutine GETTAB(Iflag) c c *********************************************************************** c * * c * Subroutine GETTAB - To read the current table presentation * c * from a file. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Byte Filnam(15) c c Get the file name to read the data c If (Iflag .EQ. 0) Then Write(7,100) 27,27,27 100 Format(1X,A1,'[H',1A1,'[J'/1X,1A1,'#6 RECALL TABLE PRESENTAT', $ 'ION ROUTINE'//' Enter the file name containing 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 End If c c If (Iflag .EQ. 0) Then Open(Unit=12,NAME=Filnam,TYPE='OLD',ERR=98,ReadOnly) Itflag = 1 Else Open(Unit=12,NAME='PLTPRG.TBL',TYPE='OLD',ERR=96,ReadOnly) Itflag = 0 End If c c Read number of points/column, number of characters/title c Read(12,*,END=99,ERR=99) Ntab,Iprtln If (Iprtln .EQ. 0) Iprtln = 58 Read(12,*,END=99,ERR=99) (Nspac(I),I=1,Ntab-2) L = 0 I = 1 Do 20 K=1,Ntab Read(12,*,END=99,ERR=99) Tabcol(I),Tcolen(I),Ndeci(I), $ Icom(I),Isci(I),Round(I) Do 10 J=1,Tcolen(I) L = L + 1 Call Point(Istart,L,Tablen) Read(12,250,END=99,ERR=99) Tablen(L),(Table(Kk),Kk=Istart, $ Istart+Tablen(L)-1) 250 Format(Q,132A1) 10 Continue c c Do not add table column if data column does not exist c If (K .GT. 1 .AND. Tabcol(I) .GT. Ncols) Then L = L - Tcolen(I) Do 15 J=K,Ntab-2 Nspac(J-1) = Nspac(J) 15 Continue Else I = I + 1 End If c 20 Continue Ntab = I - 1 c Close(Unit=12,ERR=99) c 96 Continue Return c 97 Continue Write(7,290) 290 Format(' ERROR - Bad Filename - Routine aborted') Return c c Error returns c 98 Continue Write(7,300) 300 Format(' WARNING - Error encountered in opening file - ', $ 'routine aborted') Return 99 Continue c Iflag = 2 c Write(7,350) 350 Format(' WARNING - Error encountered in reading data - ', $ 'routine aborted') Close(Unit=12,ERR=101) 101 Continue Return c End