Subroutine Tabins c c *********************************************************************** c * * c * Subroutine Tabins - To insert columns into the table * c * presentation. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Dimension Ns(20) c Itflag = 1 c Write(7,100) 100 Format(' Enter the table column number to insert after ',$) Call Inchek(0,Ntab-1,Icol) Icol = Icol + 2 c c Get the new table column parameters c 10 Continue c Write(7,200) Icol-1 200 Format(' Enter the data column number for table column ', $ I2,3X,$) Call Inchek(1,Ncols,Inscol) Call Name(Titl,Inscol,Title,Ttllen) Write(7,300) (Titl(I),I=1,Ttllen(Inscol)) 300 Format(' Data column title is:'/1X,A1/ $ ' Is it ok? (y/n) ',$) Call Instrg('YyNn',4,Ich) If (Ich .GT. 2) Go To 10 c c Make room for the new table column parameters c Do 20 I=Ntab+1,Icol+1,-1 Tcolen(I) = Tcolen(I-1) Tabcol(I) = Tabcol(I-1) Ndeci(I) = Ndeci(I-1) Icom(I) = Icom(I-1) Isci(I) = Isci(I-1) Round(I) = Round(I-1) Nspac(I-1)= Nspac(I-2) 20 Continue Tabcol(Icol) = Inscol Tcolen(Icol) = 0 Isci(Icol) = 0 Round(Icol) = 0.0 Icom(Icol) = 0 c Ntab = Ntab + 1 c c Get the column header c Call Tabdel(Icol,0) c Write(7,400) 400 Format(' Enter the number of decimal places to show ',$) Call Inchek(0,9,Ndeci(Icol)) c c Compute the "default" column spacing c If (Ntab .GE. 3) Then Call Tabwid(Data,Ns,Ntab,Mw) If (Icol .GT. 2) Nspac(Icol-2) = Ns(Icol-2) If (Icol .GT. 1) Nspac(Icol-1) = Ns(Icol-1) End If c Return End Subroutine Tabdel(Icol,Iflag) c c *********************************************************************** c * * c * Subroutine Tabdel - To Delete out the table labels, etc * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Dimension Itvec(20) c c Set the flag to show the table changed c Itflag = 1 c Call Point(K,Icol,Tcolen) c c Get length of labels to change/delete c Len = 0 Do 10 I=1,Tcolen(Icol) Len = Len + Tablen(K+I-1) 10 Continue c Call Point(Istart,K,Tablen) Call Point(Ik,Ntab+1,Tcolen) Call Point(Iend,Ik,Tablen) Iend = Iend - 1 Ik = Ik - 1 c c Purge out current text and text lengths c Do 20 I=Istart+Len,Iend Table(I-Len) = Table(I) 20 Continue c Iend = Iend - Len c Do 30 I=K+Tcolen(Icol),Ik Tablen(I-Tcolen(Icol)) = Tablen(I) 30 Continue Ik = Ik - Tcolen(Icol) c If (Iflag .EQ. 0) Then c c Change current text c Write(7,100) 100 Format(' Enter the new title (Enter "\" to stop)') Tcolen(Icol) = 0 40 Continue Call Linedt(Titl,Nchars,80,0) If (Titl(1) .EQ. '\') Return c Iflag1 = 0 c Do 50 I=Ik,K+Tcolen(Icol),-1 Tablen(I+1) = Tablen(I) 50 Continue c c See if there is a backslash c Do 60 I=1,Nchars If (Titl(I) .NE. '\' .AND. Iflag1 .EQ. 0) Then Tablen(K+Tcolen(Icol)) = I Else Iflag1 = 1 End If 60 Continue c Nchars = Tablen(K+Tcolen(Icol)) c c Make room for new text c Do 70 I=Iend,Istart,-1 Table(I+Nchars) = Table(I) 70 Continue Iend = Iend + Nchars c c Save new text c Do 80 I=Istart,Istart+Nchars-1 Table(I) = Titl(I-Istart+1) 80 Continue Istart = Istart + Nchars c Tcolen(Icol) = Tcolen(Icol) + 1 c Ik = Ik + 1 If (Iflag1 .EQ. 1) Return Go To 40 Else c c If a table column is deleted, update pointers c Do 90 I=Icol+1,Ntab Tcolen(I-1) = Tcolen(I) Icom(I-1) = Icom(I) Ndeci(I-1) = Ndeci(I) Isci(I-1) = Isci(I) Tabcol(I-1) = Tabcol(I) 90 Continue Ntab = Ntab - 1 End If Return End Subroutine Getusr(Fname,Detcom) c c *********************************************************************** c * * c * Subroutine Getusr - To get the user's name from the * c * operating system. This returns the scratch file name, * c * and a detaching command * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Fname(12),Detcom(17),Nam(30),Fn(3),Com(10) c Data Fn/'W','P',':'/ Data Com/'D','P',':','P','L','T','D','E','T',' '/ c c Get the user's name c Call GTUNAM(Nam) c c Initialize the filename & detach command c Fnlen = 3 Detlen = 10 c Do 10 I=1,Fnlen Fname(I) = Fn(I) 10 Continue c Do 20 I=1,Detlen Detcom(I) = Com(I) 20 Continue c c Load the user's name into the file name and detach command c Do 30 I=1,6 Fname(I+Fnlen) = Nam(I) Detcom(I+Detlen) = Nam(I) 30 Continue c Detcom(Detlen+7) = 0 c Return End Subroutine Stdet(Detcom,Ierr) c Byte Detcom(1) c Call STDTJB(Detcom,Ijob,Ierr) Return End Subroutine MDDFLT c c *********************************************************************** c * * c * Subroutine Mddflt - To modify the plot default values * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' Include 'Cdefl' Include 'Cgrid' c Character*9 Colr(8) Character*7 Tdr(3) Character*10 Axt(2) Character*12 Sp(2) Character*14 Charst(9) Data Tdr/'Inward ','Outward','No Tick'/ Data Axt/'Normal ','Logrithmic'/ Data Colr/'Black ','Red ','Dk. Green','Blue ', $ 'Orange ','Purple ','Lt. Green','Brown '/ Data Sp/'Uniform ','Proportional'/ Data Charst/'Hardware ','Simplex Roman ','Duplex Roman ', $ 'Complex Roman ','Triplex Roman ','Complex Italic', $ 'Triplex Italic','Complex Script','Gothic English'/ c 10 Continue Write(7,100) 27,27,27,27,Axthik,Tdr(Ticdir),Axt(Axtypx), $ Axt(Axtypy),Cvthik,Thikmj,Thikmr,Colr(Grdcmj),Colr(Grdcmr), $ Sp(Spchar),Charst(Axchst+1),Charst(Lachst+1),Charst(Lechst+1), $ Colr(Axcolr),Colr(Atxclr),Colr(Lacolr),Colr(Lecolr) 100 Format(1X,1A1,'[H',1A1,'[J',1X,1A1,'[5m SECONDARY PARAMETERS', $ ' MENU',1A1,'[0m'// $ ' 1) Axis Thickness: ',F13.5/' 2) Axis tick direction: ',2X, $ A7/' 3) X axis type: ',10X,A10/' 4) Y axis type: ',10X,A10// $ ' 5) Curve line thickness: ',F14.5// $ ' 6) Major grid line thickness: ',F9.5/ $ ' 7) Minor grid line thickness: ',F9.5/ $ ' 8) Major grid line color: ',6X,A9/ $ ' 9) Minor grid line color: ',6X,A9// $ ' 10) Text character spacing: ',3X,A12/ $ ' 11) Axis character set no.: ',3X,A14/ $ ' 12) Label character set no.: ',2X,A14/ $ ' 13) Legend character set no.: ',1X,A14/' 14) Axis color:', $ 16X,A9/' 15) Axis text color:',11X,A9/ $ ' 16) Label color:',15X,A9/' 17) Legend color:',14X,A9// $ ' Enter the value to change (enter S to stop) ',$) 20 Continue Call Inpt(X,N,Iflag,2) If (Iflag .EQ. 1) Return If (N .EQ. 0) Then Write(7,200) 200 Format(' ERROR - Try again') Go To 20 End If Ichose = X(1) If (Ichose .LT. 0 .OR. Ichose .GT. 17) Then Write(7,200) Go To 20 End If If (Ichose .LT. 17) Ipflag = 1 If ((Ichose .GT. 1 .AND. Ichose .LT. 5) .OR. Ichose .EQ. 10 ) $ Then If (Ichose .EQ. 2) Then Ticdir = Ticdir + 1 If (Ticdir .GT. 3) Ticdir = 1 End If If (Ichose .EQ. 3) Axtypx = 3 - Axtypx If (Ichose .EQ. 4) Axtypy = 3 - Axtypy If (Ichose .EQ. 10) Spchar = 3 - Spchar Else If (Ichose .LT. 8) Then 30 Continue Write(7,300) 300 Format( ' Enter the new line thickness ',$) Call Indata(1,'R',Value) c Read(5,*,END=30,ERR=30) Value If (Value .LT. 0.0 .OR. Value .GT. 0.2) Then Write(7,350) 350 Format(' Thickness value is out of range. Try Again ',$) Go To 30 End If If (Ichose .EQ. 1) Axthik = Value If (Ichose .EQ. 5) Cvthik = Value If (Ichose .EQ. 6) Thikmj = Value If (Ichose .EQ. 7) Thikmr = Value Else If (Ichose .EQ. 8 .OR. Ichose .EQ. 9 .OR. Ichose .GT. 13) $ Then Write(7,375) 375 Format(/' Color Selection:'//' 1) Black'/ $ ' 2) Red'/' 3) Dk. Green'/' 4) Blue'/' 5) Orange'/ $ ' 6) Purple'/' 7) Lt. Green'/' 8) Brown'// $ ' Enter 1-8: ',$) Call Inchek(1,8,Ich) If (Ichose .EQ. 8) Grdcmj = Ich If (Ichose .EQ. 9) Grdcmr = Ich If (Ichose .EQ. 14) Axcolr = Ich If (Ichose .EQ. 15) Atxclr = Ich If (Ichose .EQ. 16) Lacolr = Ich If (Ichose .EQ. 17) Lecolr = Ich Else Write(7,400) 400 Format(/' Available character sets:'// $ ' 0) Hardware'/' 1) Simplex Roman'/' 2) Duplex Roman'/ $ ' 3) Complex Roman'/' 4) Triplex Roman'/ $ ' 5) Complex Italic'/' 6) Triplex Italic'/ $ ' 7) Complex Script'/' 8) Gothic English'// $ ' Select 0-8: ',$) Call Inchek(0,8,Ich) If (Ichose .Eq. 11) Axchst = Ich If (Ichose .EQ. 12) Lachst = Ich If (Ichose .EQ. 13) Lechst = Ich End If Go To 10 End Subroutine LSEVAL(Xvals,Yvals,Npoint,Ndegre,Coefs) c c ************************************************************************ c * * c * Subroutine LSEVAL - To evaluate a polynomial at various X * c * locations. I realize that this subroutine may look * c * inefficient, but it is written this way to eliminate overflow * c * for large values of X at high powers. * c * * c * Input values: * c * * c * Xvals - The X values to evaluate the polynomial at * c * Npoint - The number of points to evaluate * c * Ndegre - The degree of the polynomial (cubic = 3) * c * Coefs - The polynomial coefficients, where Coefs(N) * c * is the coefficent for X**(N-1) * c * * c * Output values: * c * * c * Yvals - The computed Y values corresponding to the X * c * values in Xvals * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c ************************************************************************ c Dimension Xvals(1),Yvals(1),Coefs(1) Double Precision Xpoint c Nterm = Ndegre+1 Do 20 I=1,Npoint Yvals(I) = Coefs(1) Do 10 J=2,Nterm Xpoint = Coefs(J) Do 5 K=2,J Xpoint = Xpoint * Xvals(I) 5 Continue Yvals(I) = Yvals(I) + Xpoint 10 Continue 20 Continue Return End Subroutine Lsindf(Xvals,Yvals,Numbr,Coefs,Iorder,Iopt) c c *********************************************************************** c * * c * Subroutine Lsindf - To integrate or differentiate a * c * polynomial, and then evaluate the polynomial at supplied * c * X values. * c * * c * Input Values: * c * * c * Xvals - Values to evaluate the integral/derivitave at * c * Numbr - Number of spots to evaluate at * c * Coefs - The polynomial coefficients * c * Iorder - The order of the polynomial * c * Iopt - Flag to indicate integration or differentiation * c * Iopt = 1 : Integration * c * Iopt = 2 : Differentiation * c * * c * Output Values: * c * * c * Yvals - The Y values corresponding to the X values in * c * Xvals * c * Coefs - The coefficients of the integral/derivative * c * Iorder - The order of the integral/derivative * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Dimension Xvals(1),Yvals(1),Coefs(1) c If (Iopt .EQ. 1) Then c c Polynomial integration: c Do 10 I=Iorder+1,1,-1 Coefs(I+1) = Coefs(I)/I 10 Continue Iorder = Iorder + 1 Coefs(1) = 0.0 Do 20 I=Numbr,1,-1 Yvals(I) = Yvals(I) - Yvals(1) 20 Continue Else c c Polynomial differentiation c Do 30 I=2,Iorder+1 Coefs(I-1) = Coefs(I)*(I-1) 30 Continue Iorder = Iorder - 1 End If c c Solve for the new Y values c Call Lseval(Xvals,Yvals,Numbr,Iorder,Coefs) c If (Iopt .EQ. 1) Then Do 40 I=Numbr,1,-1 Yvals(I) = Yvals(I) - Yvals(1) 40 Continue End If c Return End Subroutine Runcmd(Com) Byte Com(1) Call Setcmd(Com) Return End