Subroutine Comp(Data) c c *********************************************************************** c * * c * Subroutine Comp - To do math calculations on columns of data. * c * User can do calculations using trig and log functions. * c * * c * Example: * c * * c * Sin(A) + (396*5)/(54-23) * c * * c * Where "A" represents a data column. The results can be saved * c * by the user as another data column. * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) Byte Line(132),Names(20) Character*20 Hold c Equivalence (Hold,Names(1)) Equivalence (Y(1),Val(1)),(Y(51),Array(1)),(Y(71),Value(1)), $ (Y(121),Namept(1)),(Y(131),Ivar(1)),(Y(141),Ipoint(1)), $ (Y(151),Iopt(1)),(Y(176),Iprior(1)),(Y(201),Ip(1)), $ (Y(226),Io(1)),(Y(251),Icol(1)),(Y(261),Line(1)) c Dimension Val(50),Array(20),Namept(20),Iopt(50),Icol(20), $ Iprior(50),Value(50),Ivar(20),Ipoint(20),Ip(50),Io(50) c Data Hold/'ABCDEFGHIJKLMNOPQRST'/ c Write(6,100) 27 100 Format(/1X,1A1,'#6 EQUATION SOLVER'/) c 10 Continue c c Prompt the user for the columns to use in the equation c Write(6,200) 200 Format(' Enter the column numbers to use in the equation, ', $ 'or "S" to stop') Call Inpt(X,Narray,Iflag,2) If (Iflag .EQ. 1) Return c c See if the column numbers are in range, and have c an equal number of points c Do 20 I=1,Narray If (X(I) .LT. 1 .OR. X(I) .GT. Ncols) Then Write(6,300) 300 Format(' Column number out of range. Try again') Go To 10 End If c Icol(I) = X(I) Namept(I) = 1 If (Npoint(Icol(I)) .NE. Npoint(Icol(1))) Then Write(6,400) Icol(I),Icol(1) 400 Format(' ERROR - Number of points in column number',I4, $ ' does not match'/8X,'the number of points in', $ ' column number',I4'; try again'/) Iflag = 1 End If Call Point(Ipoint(I),Icol(I),Npoint) c 20 Continue If (Iflag .EQ. 1) Go To 10 c Write(6,500) 500 Format(' Selected columns:'/) c c List the column numbers c Do 30 I=1,Narray Call Name(Titl,Icol(I),Title,Ttllen) Write(6,550) Names(I),Icol(I),(Titl(J),J=1,Ttllen(Icol(I))) 550 Format(1X,1A1,' = Column',I4,': ',A1) 30 Continue Write(6,600) 600 Format(/' Are the column numbers correct? (y/n) ',$) Call Instrg('YyNn',4,Iflag) If (Iflag .GT. 2) Go To 10 c 35 Continue c Nchar = 0 c 40 Continue c c Read in a line of computations c Write(6,700) 700 Format(' Enter in computations, or $ to quit, # to list') c Call Linedt(Line,Nchar,132,1) c c Delete all blanks, and replace lower case letters with uppercase c Call Blanks(Line,Nchar) c c Exit if a "$" is encountered c If (Line(1) .EQ. '$') Return c c If a "#" is encountered, list the current parameters c If (Line(1) .EQ. '#') Then Call Listeq(Icol,Narray) Go To 35 End If c c Look for (an) illegal character(s) c Call Ilegal(Line,Nchar,Iflag) c c Get a new expression if an illegal character is encountered c If (Iflag .GT. 0) Go To 40 c c Interpret the string c Call Inpret(Value,Ivar,Iprior,Iopt,Nvals,Names,Namept,Narray, $ Line,Nchar,Iflag) If (Iflag .GT. 0) Go To 40 c c Evaluate the string c Call Point(Lastpt,Ncols+1,Npoint) Npt = Npoint(Icol(1)) Do 60 Loop=1,Npt Do 50 J=1,Nvals If (Ivar(J) .GT. 0) Then Val(J) = Value(J) * Data(Loop+Ipoint(Ivar(J))-1) Else Val(J) = Value(J) End If Ip(J) = Iprior(J) Io(J) = Iopt(J) 50 Continue c Nv = Nvals Call Cmpute(Val,Ip,Io,Nv,Iflag) c c Check for errors c If (Iflag .EQ. 1) Go To 40 c c Save results c Data(Loop+Lastpt-1) = Val(1) c 60 Continue c c List out the results c Call Prteq(Data,Icol,Narray,Ivar,Nvals) c c Get a new column title c Write(6,800) 800 Format(/' Enter the title of the new column to save (or return', $ ' to not save it)') Call Point(Ipt,Ncols+1,Ttllen) Call Linedt(Title(Ipt),Ttllen(Ncols+1),80,0) c If (Ttllen(Ncols+1) .GT. 0) Then c c Update pointers to save data and add to columns to use c If (Ncols .GE. Ncolmx) Then Write(6,810) Ncolmx 810 Format(' Insufficient room for an additional column -', $ ' only',I4,' allowed') Return End If Call Point(It,Ncols+1,Npoint) If (It+Npt-1 .GT. Last) Then Write(6,811) Last 811 Format(' Insufficient room for additional points -', $ ' only',I6,' allowed') Return End If c Idflag = 1 Ncols = Ncols + 1 Npoint(Ncols) = Npt If (Ncols .EQ. Ncolmx .OR. Narray .EQ. 20) Return Narray = Narray + 1 Namept(Narray) = 1 Icol(Narray) = Ncols Call Point(Ipoint(Narray),Ncols,Npoint) Write(6,850) Names(Narray),Ncols,(Title(K),K=Ipt, $ Ttllen(Ncols)-1+Ipt) 850 Format(1X,1A1,' = Column',I3,': ',A1) End If c c Loop back to get the next expression c Go To 35 End Subroutine Prteq(Data,Icol,Narray,Ivar,Nvars) c c *********************************************************************** c * * c * Subroutine Prteq - To print out the results from the * c * evaluation of the user's equations out to the terminal * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Virtual Data(1) Integer Icol(1),Ivar(1),Ic(20) Character*14 Ac(10) Byte Char c c See which columns were used c Nuse = 0 Do 10 I=1,Nvars If (Ivar(I) .NE. 0) Then Do 7 K=1,Nuse If (Ic(K) .EQ. Ivar(I)) Go To 10 7 Continue Nuse = Nuse + 1 Ic (Nuse) = Ivar(I) End If 10 Continue c c If we have alot to print out, see if the user wishes to c minimize the printout c Istart = 1 Iprt = 1 If (Npoint(Icol(1)) .GT. 50) Then Write(6,100) Npoint(Icol(1)) 100 Format(/' Do you wish to print out every point on the', $ ' screen?'/' (There are',I5,' points per column)', $ ' ',$) Call Instrg('YyNn',4,Iopt) If (Iopt .GE. 3) Then 15 Continue Write(6,150) 150 Format(' Enter the starting point, and the Nth point', $ ' to print') Call Indata(2,'II',Istart,Iprt) If (Istart .LT. 1 .OR. Istart .GT. Npoint(Icol(1)) $ .OR. Iprt .LT. 1 .OR. Iprt .GT. Npoint(Icol(1))) Go To 15 End If End If c c Print out the column titles c Do 20 I=1,Nuse Char = Ic(I) + 64 Ic (I) = Icol(Ic(I)) Call Name(Titl,Ic(I),Title,Ttllen) Write(6,300) Char,Ic(I),(Titl(J),J=1,Ttllen(Ic(I))) 300 Format(1X,1A1,' = Column ',I3,': ',A1) 20 Continue c c Limit the number of columns printed out to 4 + Results c Nuse = Min0(4,Nuse) c c Print out the headers c If (Nuse .GT. 0) Then Write(6,400) (Ic(J),J=1,Nuse) 400 Format(/' pt ',(4X,'Column '),' Results'/ $ ' no. ',(I4,11X)/) Else Write(6,425) 425 Format(' pt Results'/) End If c c Write out the rest of the data c Nuse = Min0(4,Nuse) Nuse = Nuse + 1 Ic(Nuse) = Ncols + 1 c L = Nuse + 2 Do 50 I=Istart,Npoint(Icol(1)),Iprt Iflag = 1 Do 40 J=1,Nuse Call Point(K,Ic(J),Npoint) Encode(14,450,Ac(J)) Data(K+I-1) 450 Format(G14.7) 40 Continue c c Pause for long listings c c c Print out on the terminal c Write(6,500) I,(Ac(J),J=1,Nuse) 500 Format(I5,(1X,A14)) !??? c L = L + 1 If (L .GE. 20) Then Call Spause L = 0 End If c 50 Continue c Return End