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