Subroutine Tabopt(Data) c c *********************************************************************** c * * c * Subroutine Tabopt - To select the table options * c * It writes out the main table options, and calls the * c * corresponding table subroutine. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Virtual Data(1) c Write(6,100) 27,27 100 Format(1X,A1,'[H',A1,'[J') 10 Continue c Write(6,200) 27 200 Format(1X,1A1,'#6 PLTPRG DATA TABLE OPTIONS:'// $ ' C (C)reate Table'/ $ ' M (M)odify Table'/ $ ' P (P)rint Table'/ $ ' A S(A)ve Table'/ $ ' R (R)ecall Table'/ $ ' S (S)top'//' Enter C, M, P, A, R, or S ',$) Call Instrg('CcMmPpAaRrSs',12,Ichose) Ichose = (Ichose + 1)/2 Izero = 0 c If (Ichose .EQ. 1) Then Call Tabmak(Data) Else If (Ichose .EQ. 2) Then Call Modtab(Data) Else If (Ichose .EQ. 3) Then Call Tabprt(Data) Else If (Ichose .EQ. 4) Then Call Savtab(Izero) Else If (Ichose .EQ. 5) Then Call Gettab(Izero) Else Return End If c Go To 10 End Subroutine Tabmak(Data) c c *********************************************************************** c * * c * Subroutine TABMAK - To create tables of column data. This * c * subroutine queries the user for the column numbers to use, * c * the headers (titles) for each column, etc. to build a * c * proper table. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Virtual Data(1) c c See if a table already exists c If (Ntab .NE. 0) Then Write(6,125) 125 Format(/' Table presentation exists - OK to destroy? (y/n) ', $ $) Call Instrg('YyNn',4,Iflag) If (Iflag .GT. 2) Return End If c c Set flag showing that the table has been changed c Itflag = 1 c c Set the printer to 55 lines/page c Iprtln = 55 c c Write the header, and get the table title c Write(6,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',1A1,'#6 DATA TABLE CREATION', $ ' ROUTINE'//' Enter the table title (enter a backslash ', $ '"\" to stop)') Ntab = 0 Call Tabin(Iflag) c c Start loop for inputting the column names c (Ntab incremented by 1 in Tabin) c 10 Continue c Call Tabin(Iflag) c c Loop back for the next column; c If (Iflag .EQ. 0) Go To 10 c c Get the number of spaces needed for each column c Call Tabspc(Data) c Return End Subroutine Tabcmp(Data,Isfig,Ihedln) c c *********************************************************************** c * * c * Subroutine TABCMP - To compute the number of spaces required * c * for each column to print out its numbers, and the number of * c * spaces required for the header of each column. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' c Virtual Data(1) c Dimension Isfig(1),Ihedln(1) c c Compute the number of spaces for the numbers; c Do 30 I = 2,Ntab c c Get the numbers in the I th table column c Call Getvec(Data,Npoint,Tabcol(I),X,Npt) Isfig(I) = 0 Do 10 J = 1,Npt c c Compute the number of digits to the right of the decimal c If (X(J) .GE. 1.0) Then Is = Int(Log10(X(J))) + 1 If (Icom(I) .EQ. 1) Is = Is + Is/3 Else If (X(J) .GE. 0.0) Then Is = 1 Else If (X(J) .GT. -1.0) Then Is = 2 Else Is = Int(Log10(-X(J))) + 2 If (Icom(I) .EQ. 1) Is = Is + (Is-1)/3 End If Isfig(I) = Max0(Is,Isfig(I)) 10 Continue c c Make room for scientific notation c If (Isci(I) .GT. 0) Isfig(I) = Isfig(I) + 7 If (Isci(I) .LT. 0) Isfig(I) = Isfig(I) + 8 c c Add in the number of decimal places to print c If (Ndeci(I) .GT. 0) Isfig(I) = Isfig(I) + 1 Isfig(I) = Isfig(I) + Ndeci(I) c c Compute maximum header lengths c Ihedln(I) = 0 Call Point(L,I,Tcolen) Do 20 J = 1,Tcolen(I) Ihedln(I) = Max0(Ihedln(I),Tablen(L+J-1)) 20 Continue 30 Continue c Return End Subroutine Tabwid(Data,Nspac,Ntab,Maxwid) c c *********************************************************************** c * * c * Subroutine Tabwid - To compute the width of the table. * c * This subroutine sets a minimum of two spaces between each * c * column or column headers. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c c Virtual Data(1) c Dimension Isfig(20),Ihedln(20),Nspac(1) c c Get the amount of spaces needed for the numbers and headers c Call Tabcmp(Data,Isfig,Ihedln) c c Set the number of spaces between the columns/headers c to two: c Maxwid = 0 Do 10 I=2,Ntab-1 If (Isfig(I) + Isfig(I+1) .LT. Ihedln(I) + Ihedln(I+1)) Then Nspac(I-1) = 2+(1+Ihedln(I)+Ihedln(I+1)-Isfig(I)- $ Isfig(I+1))/2 Else Nspac(I-1) = 2 End If Maxwid = Nspac(I-1) + Maxwid + Isfig(I) 10 Continue c Maxwid = Maxwid + Isfig(Ntab) c c Add in the effects of wide headers to the computation c of the maximum table width c If (Ihedln(2) .GT. Isfig(2)) Maxwid = Maxwid + ((Ihedln(2)- $ Isfig(2))/2) If (Ihedln(Ntab) .GT. Isfig(Ntab)) Maxwid = Maxwid + $ ((Ihedln(Ntab) - Isfig(Ntab) + 1)/2) c Return End Subroutine Modtab(Data) c c *********************************************************************** c * * c * Subroutine Modtab - To modify a given table presentation * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Virtual Data(1) Character*3 Nocom(2) Data Nocom /'No ','Yes'/ Dimension Ns(20) c 10 Continue c c Print table presentation modification menu c Write(6,100) 27,27,27 100 Format(1X,1A1,'[H',1A1,'[J',1A1,'#6 MODIFY TABLE PRESENTATION'// $ ' A (A)dd columns to table'/ $ ' I (I)nsert columns to table'/ $ ' C (C)hange column parameters'/ $ ' D (D)elete table columns'/ $ ' L (L)ist the current column parameters'/ $ ' P Modify s(P)aces between columns'/ $ ' N (N)umber of lines printed per page'/ c $ ' R (R)e-order the columns in the table'/ $ ' S (S)top'//' Enter A, C, D, L, P, N, or S ',$) c Call Instrg('AaIiCcDdLlPpNnSs',16,Ichose) Ichose = (Ichose + 1)/2 c c Modify options: c If (Ichose .EQ. 1) Then c c Add columns c If (Ntab .GE. 20) Go To 10 15 Continue Call Tabin(Iflag) If (Iflag .EQ. 0) Then Itflag = 1 If (Ntab .GE. 3) Then Call Tabwid(Data,Ns,Ntab,Mw) Nspac(Ntab-2) = Ns(Ntab-2) End If Go To 15 End If c Else If (Ichose .EQ. 2) Then c c Insert table columns c Call Tabins c Else If (Ichose .EQ. 3) Then c c Change column data c 20 Continue c If (Ntab .EQ. 0) Go To 10 Write(6,200) 200 Format(' Enter the table column number to change, or "s" to', $ ' stop'/' (Enter 0 to change the table header) ',$) Call Inpt(X,N,Iflag,2) If (Iflag .EQ. 1 .OR. N .NE. 1) Go To 10 Ix = X(1) + 1.1 If (Ix .GT. Ntab .OR. Ix .LT. 1) Then Write(6,210) 27,27 210 Format(' Bad ',1A1,'[4mcolumn',1A1,'[0m number - try again') Go To 20 End If c c Print out change column menu: c 25 Continue If (Ix .EQ. 1) Then Write(6,225) 225 Format(/' Old table title:'//) Else Write(6,250) 250 Format(/' (H)eader:'//) End If Call Point(K,Ix,Tcolen) Len = 1 Do 30 I=1,Tcolen(Ix) Call Point(Istart,K+I-1,Tablen) If (Tablen(K+I-1) .GT. 0) Then If (Len+Tablen(I+K-1)+2 .GT. 80) Then Len = 1 Write(6,290) 290 Format(1X) End If Write(6,300,ERR=30) 27,(Table(J),J=Istart,Istart+ $ Tablen(K+I-1)-1) Len = Len + Tablen(I+K-1) + 2 End If 300 Format(X,1A1,'[1A{',A1,'}') 30 Continue If (Ix .EQ. 1) Then Call Tabdel(1,0) Else c If (Tabcol(Ix) .LE. Ncols) Then Call Point(K,Tabcol(Ix),Ttllen) Write(6,350) Tabcol(Ix),(Title(J),J=K,K+Ttllen( $ Tabcol(Ix))-1) 350 Format(/' (N)umber of data column = ',I5/5X, $ ' (title is: ',A1,' )'/) Else Write(6,355) Tabcol(Ix),27,7,27 355 Format(/' (N)umber of data column = ',I5/1X,1A1, $ '[1;5;7m*** COLUMN NUMBER OUT OF RANGE ***', $ 2A1,'[0m'/) End If Write(6,360) Ndeci(Ix),Nocom(Icom(Ix)+1),Isci(Ix),Round(Ix) 360 Format( ' (D)ecimal places:',I5/' (C)ommas? ',1A3/ $ ' (E)xponent for Scientific Notation = ',I3/ $ ' (R)oundoff value = ',F10.5/ $ ' (S)top'// $ ' Enter H, N, D, C, E, R, or S ',$) c c Get the option to change from the user: c Call Instrg('HhNnDdCcEeRrSs',14,Ich) Ich = (Ich + 1)/2 c If (Ich .LE. 6) Itflag = 1 c If (Ich .EQ. 1) Then !**** New Header Call Tabdel(Ix,0) Else If (Ich .EQ. 2) Then !**** New column number Write(6,450) 450 Format(' Enter the new column number ',$) Call Inchek(1,Ncols,Tabcol(Ix)) Else If (Ich .EQ. 3) Then !**** Change the no. of decis Write(6,500) 500 Format(' Enter the number of decimal places to print '$) Call Inchek(0,9,Ndeci(Ix)) Else If (Ich .EQ. 4) Then !**** Add/del commas Icom(Ix) = 1 - Icom(Ix) Else If (Ich .EQ. 5) Then !**** Scientific notation Write(6,550) 550 Format(' Enter the exponent for the scientific notation', $ ' (enter 0 for none) ',$) Call Inchek(-9,9,Isci(Ix)) Else If (Ich .EQ. 6) Then !**** Roundoff value Write(6,575) 575 Format(' Enter the value to round the values to ',$) Call Indata(1,'R',Round(Ix)) Else !**** Stop making changes Go To 10 End If End If If (Ix .GT. 1) Go To 25 c Else If (Ichose .EQ. 4) Then c c Delete table columns c If (Ntab .LT. 2) Go To 10 Write(6,600) 600 Format(' Enter the table column number to delete ',$) Call Inchek(1,Ntab-1,Ix) Itflag = 1 Call Tabdel(Ix+1,1) Else If (Ichose .EQ. 5) Then c c List the current information c Kk = 1 Do 50 I=1,Ntab If (I .EQ. 1) Then Write(6,650) 27 650 Format(1X,1A1,'[24B'/' Table title:'//) Else If (I .EQ. 2) Write(6,675) 675 Format(2X) Write(6,700) I-1 700 Format(' Header for table column ',I2//) End If Len = 1 Do 40 L=1,Tcolen(I) Call Point(Istart,Kk,Tablen) If (Tablen(KK) .GT. 0) Then If (Len + Tablen(Kk) + 2 .GT. 80) Then Len = 1 Write(6,290) End If Write(6,725,ERR=77) 27,(Table(J),J=Istart, $ Istart+Tablen(Kk)-1) Len = Len + Tablen(Kk) + 2 End If 725 Format(X,1A1,'[1A{',A1,'}') 77 Kk = Kk + 1 40 Continue If (I .GT. 1) Then If (Tabcol(I) .LE. Ncols) Then Call Point(K,Tabcol(I),Ttllen) Write(6,750) Tabcol(I),(Title(J),J=K,K+Ttllen( $ Tabcol(I))-1) 750 Format(' ** Number of data column = ',I5/ $ ' ** title is ',A1) Else Write(6,760) Tabcol(I),27,7,27 760 Format(' ** Number of data column = ',I5/1X,1A1, $ '[1;5;7m*** COLUMN NUMBER OUT OF RANGE ***', $ 2A1,'[0m') End If c Write(6,770) Ndeci(I),Nocom(1+Icom(I)),Isci(I),Round(I) 770 Format(' ** Decimal places:',I2,', Commas? ',1A3, $ ', Sci. exponent =',I3,', Rounded to ', $ F10.5/) End If 50 Continue Call Spause Else If (Ichose .EQ. 6) Then c c To change current spacing between columns. c First, get the table width: c If (Ntab .LT. 3) Go To 10 Call Tabwid(Data,Ns,Ntab,Maxwid) c Write(6,800) Maxwid 800 Format(' Currently, the table takes up ',I3,' spaces'/) c c Print out the current number of spaces between columns: c Write(6,850) (I,I+1,Nspac(I),I=1,Ntab-2) 850 Format(' Current number of spaces between each column:'// $ $ (' Between columns',I4,' and',I4,': ',I2,' spaces'/)/ $ ' Do you wish to:'/ $ ' 1) Change the number of spaces'/ $ ' 2) Get the default spacing values'/ $ ' 3) Stop'//' Enter 1-3 ',$) c Call Inchek(1,3,J) c If (J .LE. 2) Itflag = 1 c If (J .EQ. 1) Then c c See if we want to get new default spacing values c c c Get the new number of spaces from the user c Do 60 I=1,Ntab-2 Write(6,900) I,I+1 900 Format(' Enter the number of spaces between ', $ 'columns',I4,' and',I4,': '$) Call Inchek(1,50,N) If (N .NE. Nspac(I)) Then Maxwid = N - Nspac(I) + Maxwid Write(6,800) Maxwid End If Nspac(I) = N 60 Continue Call Spause Else If (J .EQ. 2) Then Call Tabwid(Data,Nspac,Ntab,Mw) End If Else If (Ichose .EQ. 7) Then Write(6,950) Iprtln 950 Format(' Enter the number of lines/page (currently is',I4, $ ') ',$) Call Inchek(1,150,Iprtln) Else Return End If Go To 10 End