Subroutine Modwho(Icol,Ipoint,Nc,Iflag) c c *********************************************************************** c * * c * Subroutine Modwho - To prompt the user to see which groups * c * of columns it should modify using the modify groups of * c * curves option. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Dimension Icol(9),Ipoint(9) c 10 Continue c c Prompt the user for the columns to use in the equation c Write(6,100) 100 Format(' Enter the column numbers to modify, ', $ 'or "S" to stop') Call Inpt(X,Nc,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 Nc = Min0(9,Nc) c Do 20 I=1,Nc 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 c Check for duplicate input column numbers c Do 15 J=1,Nc If (J .NE. I .AND. X(J) .EQ. X(I)) Then Write(6,350) 350 Format(' Duplicate column number input. Try again') Go To 10 End If 15 Continue c Icol(I) = X(I) c c See if the number of points in each column is the same c 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 c 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,Nc Call Name(Titl,Icol(I),Title,Ttllen) Write(6,550) Icol(I),(Titl(J),J=1,Ttllen(Icol(I))) 550 Format(' Column',I4,': ',A1) 30 Continue c c See if the user likes them c Write(6,600) 600 Format(/' Are the column numbers correct? (y/n) ',$) Call Instrg('YyNn',4,Iflag) If (Iflag .GT. 2) Go To 10 Iflag = 0 Return End Subroutine Stopit c c *********************************************************************** c * * c * Subroutine Stopit - To end the program. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Character*10 Scname(3) Data Scname/'PLTPRG.DAT','PLTPRG.PLT','PLTPRG.TBL'/ Write(6,100) 27,27 100 Format(' Do you ',1A1,'[1mreally',1A1,'[m want to stop?', $ ' (y/n) ',$) Call Instrg('YyNn',4,Iflag1) If (Iflag1 .GT. 2) Return Do 10 I=1,3 5 Continue Open(Unit=12,Name=Scname(I),Type='OLD',ERR=10,Dispose='DELETE') Close(Unit=12) Go To 5 10 Continue Call Exit End Subroutine Inpret(Val,Ivar,Iprior,Iopt,Nvar,Names,Namept,Narray, $ Line,Nchar,Iflag) c c *********************************************************************** c * * c * Subroutine Inpret - To interpret the equation. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Line(1),Break(8),Names(1),Fun(48) Integer*4 Funct(12) Integer Funchr,Sign Dimension Val(1),Array(1),Namept(1),Funchr(12),Iopt(1), $ Iprior(1),Ivar(1) c Equivalence (Funct(1),Fun(1)) c Data Break/'+','-','*','/','(',')','=','^'/ Data Funct/'SIN ','COS ','TAN ','ASIN','ACOS','ATAN','LOG ', $ 'LN ','ABS ','INT ','EXP ','SQRT'/ Data Funchr/3,3,3,4,4,4,3,2,3,3,3,4/ c c Initialize pointers and "blank out" arrays c Iflag = 0 Nvar = 0 Iloc = 0 Ipoint = 1 Iparen = 0 Newvar = 0 c Do 25 I=1,20 Iopt(I) = 0 Val(I) = 0.0 Iprior(I) = 0 Ivar(I) = 0 25 Continue c c Adjust for initial left side parenthesis c 30 Continue If (Line(Ipoint) .EQ. '(') Then Ipoint = Ipoint + 1 Iparen = Iparen + 5 Go To 30 End If c c Break the string down to variables and numbers, and operators c 35 Continue Nvar = Nvar + 1 c c Look for the end of a variable, function, or number, by c looking for the next occurance of a +,-,*,/,=,(,), or ^. c Do 45 I=Ipoint+1,Nchar c If (Line(I) .EQ. '=') Then Write(6,100) 100 Format(' ERROR - "=" is not a legal operator') Iflag = 1 End If c Do 40 J=1,8 If (Line(I) .EQ. Break(J)) Then c c Make certain, that if it is a number, it isn't in c scientific notation with an exponent. c If ((Line(I) .EQ. '-' .OR. Line(I) .EQ. '+') .AND. I $ .GT. 1 .AND. Line(I-1) .EQ. 'E') Then If ((Line(Ipoint) .GE. '0' .AND. Line(Ipoint) .LE. $ '9') .OR. Line(Ipoint) .EQ. '.') Go To 40 If (Line(Ipoint) .EQ. '-' .AND. ((Line(Ipoint+1) $ .GE. '0' .AND. Line(Ipoint+1) .LE. '9') .OR. $ Line(Ipoint+1) .EQ. '.')) Go To 40 End If Go To 50 End If 40 Continue 45 Continue c c Jump here when the end of the number, variable, or c function is found c 50 Continue c c Now, we must determine if we have a number, function, c or a variable c If ((Line(Ipoint) .GE. '0' .AND. $ Line(Ipoint) .LE. '9' ) .OR. Line(Ipoint) .EQ. '.' .OR. $ (Line(Ipoint) .EQ. '-' .AND. ((Line(Ipoint+1) .GE. '0' .AND. $ Line(Ipoint+1) .LE. '9') .OR. (Line(Ipoint+1) .EQ. '.'))) $ .OR. Line(Ipoint) .EQ. '+' ) Then c c Number encountered (we think) - check for illegal characters c Ideci = 0 Isci = 0 Do 52 J = Ipoint,I-1 If (Line(J) .EQ. '.' .AND. Isci .GT. 0) Go To 99 If (Line(J) .EQ. '.') Ideci = Ideci + 1 If (Line(J) .EQ. 'E') Then Isci = Isci +1 If (Line(J+1) .EQ. '-' .OR. Line(J+1) .EQ. '+') Then If (I-J .GT. 4 .OR. I-J .LE. 2) Go To 99 If (Line(J+2) .GT. '2' .AND. I-J .EQ. 4) Go To 99 Else If (I-J .GT. 3 .OR. I-J .LE. 1) Go To 99 If (Line(J+1) .GT. '2' .AND. I-J .EQ. 3) Go To 99 End If Else If (Line(J) .GE. 'A' .AND. Line(J) .LE. 'Z') Go To 99 End If 52 Continue c If (Isci .GT. 1 .OR. Ideci .GT. 1) Go To 99 c Decode(I-Ipoint,400,Line(Ipoint)) Val(Nvar) 400 Format(E16.0) Else c c See if it is a negative variable or function c If (Line(Ipoint) .EQ. '-') Then Sign = -1 Ipoint = Ipoint + 1 Else Sign = 1 End If c c See if Function c If (I-Ipoint .LE. 5 .AND. I-Ipoint .GT. 1) Then c c Loop over function name c Do 60 K=1,12 c c Loop over # of characters in function names c If (I-Ipoint .NE. Funchr(K)) Go To 60 Do 55 L=1,Funchr(K) If (Line(Ipoint-1+L) .NE. Fun((K-1)*4+l)) Go To 60 55 Continue c c Function name is found; see if the function arguement c is enclosed by parenthesis c If (Line(I) .NE. '(') Then Write(6,700) (Line(K1),K1=Ipoint,I-1) 700 Format(' ERROR - Function argument must be surrounde', $ 'd by parenthesis. Name: "',A1,'"'/) Iflag = 1 Return End If c c Set the operation number c Val(Nvar) = Sign Iopt(Nvar) = K + 5 Go To 80 60 Continue End If c c Variables; see if it is a known variable c If (Narray .GT. 0) Then c c Loop over known variable names c Do 70 K=Narray,1,-1 Call Point(Ip,K,Namept) c c Loop over the characters in each variable name c If (I-Ipoint .NE. Namept(K)) Go To 70 Do 65 L=1,Namept(K) If (Line(Ipoint+L-1) .NE. Names(Ip-1+L)) Go To 70 65 Continue c c Variable found c Ivar(Nvar) = K Val(Nvar) = Sign c c See if it is to be updated (i.e. variable = .....) c If (Nvar .EQ. 1 .AND. Line(I) .EQ. '=') Iloc = K Go To 80 70 Continue End If c c Current string is unknown; this is an error condition c Write(6,800) (Line(K1),K1=Ipoint,I-1) 800 Format(' ERROR in Variable/function name - "', $ A1,'"'/) Iflag = 1 Return c End If c c Set the operation priority and the operation number c 80 Continue c c Check for parenthesis following the variable & set flags c If (Line(I) .EQ. '(' .AND. Iopt(Nvar) .EQ. 0) Then Iparen = Iparen + 5 I = I + 1 Go To 80 End If If (Line(I) .EQ. ')' .AND. Iopt(Nvar) .EQ. 0) Then Iparen = Iparen - 5 I = I + 1 Go To 80 End If c c Set the operations, and the priorities c If (Line(I) .EQ. '-') Then ! Subtract Iprior(Nvar) = Iparen + 1 Iopt(Nvar) = 1 End If c If (Line(I) .EQ. '+') Then ! Add Iprior(Nvar) = Iparen + 1 Iopt(Nvar) = 2 End If c If (Line(I) .EQ. '*') Then ! Multiply Iprior(Nvar) = Iparen + 2 Iopt(Nvar) = 3 End If c If (Line(I) .EQ. '/') Then ! Divide Iprior(Nvar) = Iparen + 2 Iopt(Nvar) = 4 End If c If (Line(I) .EQ. '^') Then ! Raise to power Iprior(Nvar) = Iparen + 4 Iopt(Nvar) = 5 End If c c Set priority for functions (operation no. previously set) c If (Iopt(Nvar) .GT. 5) Then Iprior(Nvar) = Iparen + 3 Iparen = Iparen + 5 ! Increment parenthesis flag End If c 90 Continue c c Set parenthesis flags for parenthesis to right of variable, c number, or function c I = I + 1 Ipoint = I If (Line(Ipoint) .EQ. '(') Then Iparen = Iparen + 5 Go To 90 End If If (Line(Ipoint) .EQ. ')') Then Iparen = Iparen - 5 Go To 90 End If c c Loop back for next piece of expression to interpret c If (Ipoint .LE. Nchar) Go To 35 c Return c c ERRORS c 99 Continue Write(6,900) (Line(K),K=Ipoint,I-1) 900 Format(' ERROR - Number is too large or has bad characters.', $ ' Number: "',A1,'"'/) Iflag = 1 Return c End Subroutine Blanks(Line,Nchar) c c *********************************************************************** c * * c * Subroutine BLANKS - To remove blanks and to turn lower case * c * letters to upper case in the input string "Line". Removing * c * blanks and changing the lower case to uppercase makes it * c * much easier to search for specific character strings, such * c * as function names and variables. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Line(1) c N=Nchar Do 20 I=1,N If (I .LE. Nchar) Then c c Convert to Upper case if lower case: c If (Line(I) .GE. 'a' .AND. Line(I) .LE. 'z') Line(I) = $ Line(I) - 32 c c Delete blanks c If (Line(I) .EQ. ' ') Then 5 Continue c c If Line(I) is a blank, move all characters to the right c of it, to the left one space c If (I .LT. Nchar) Then Do 10 J=I,Nchar-1 Line(J) = Line(J+1) 10 Continue End If Nchar = Nchar-1 c c If the new Line(I) is a blank, repeat the above c If (Line(I) .EQ. ' ' .AND. I .LE. Nchar) Go To 5 End If End If 20 Continue Return End Subroutine Invars(Ivrcon,Icol,Ipoint,Nvars,Npt,Iflag) c c *********************************************************************** c * * c * Subroutine Invars - To read in the column variables * c * * c *********************************************************************** c Include 'Cmain' c Dimension Icol(1),Ivrcon(1),Ipoint(1) c c Set Ivrcon to a column variable c Ivrcon(Nvars) = 2 Iflag = 0 c c Read in the column number c 20 Continue Call Inchek(0,Ncols,Icol(Nvars)) c c If column number is zero, set flag and return c If (Icol(Nvars) .EQ. 0) Then Iflag = 1 Return End If c c See if this column has the same no. of points c as the other ones we will use c If (Nvars .EQ. 1 .OR. Npt .EQ. 0) Then Npt = Npoint(Icol(1)) Else If (Npt .NE. Npoint(Icol(Nvars))) Then Write(6,300) Icol(Nvars),Icol(1) 300 Format(' ERROR - Number of points in column number',I4, $ ' does not match'/8X,'the number of points in', $ ' column number',I4'; try again,'/ $ ' or enter 0 to stop ',$) Go To 20 End If End If c c See if the user likes the column entered c Call Name(Titl,Icol(Nvars),Title,Ttllen) Write(6,400) Icol(Nvars),(Titl(J),J=1,Ttllen(Icol(Nvars))) 400 Format(' Column',I4,': ',A1/ $ ' Is the column number correct? (y/n) ',$) Call Instrg('YyNn',4,Iflaga) c c Didn't like their column choice; c If (Iflaga .GT. 2) Then Write(6,500) 500 Format(' Re-enter the column number (or 0 to stop) ',$) Go To 20 End If c Call Point(Ipoint(Nvars),Icol(Nvars),Npoint) Return End