Subroutine Ilegal(Line,Nchar,Iflag) c c *********************************************************************** c * * c * Subroutine ILEGAL - To Find illegal characters in the * c * input line. This subroutine also checks for balanced * c * parenthesis, and other illegal combinations of legal * c * characters. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Line(1),Ch1,Ch2,Ch c c Set the initial flags c Iflag = 0 Iequal = 0 Iparen = 0 Ibreak = 0 Ch1 = Line(1) c c Check for illegal first characters c If (Ch1 .EQ. ')' .OR. Ch1 .EQ. '+' .OR. Ch1 .EQ. '/' $ .OR. Ch1 .EQ. '*' .OR. Ch1 .EQ. '^' .OR. Ch1 .EQ. '=' .OR. $ (Nchar .GT. 1 .AND. (Ch1 .EQ. '-' .AND. (Line(2) .GE. 'A' $ .AND. Line(2) .LE. 'Z')))) Then Write(6,100) 100 Format(' ERROR - First character cannot be of this type') Iflag = 1 End If c c Loop over the expression string c Do 10 I=1,Nchar c c If a +,/,-,*,(,), or ^ is encountered prior to a equal sign, c an error has occured c If (Ibreak .GT. 0 .AND. Line(I) .EQ. '=') Then Write(6,200) 200 Format(' ERROR - Illegal character prior to equal sign') Iflag = 1 End If c c More than one equal sign c If (Line(I) .EQ. '=') Iequal = Iequal + 1 c c Count the parenthesis c If (Line(I) .EQ. '(') Iparen = Iparen + 1 If (Line(I) .EQ. ')') Iparen = Iparen - 1 c c If there are more closed parenthesis than open at any c given time, it is an error c If (Iparen .LT. 0) Then Write(6,300) 300 Format( ' ERROR - Illegal use of parenthesis') Iflag = 1 End If c Ch1 = Line(I) c c Set Ibreak = 1 if an *,/,+,-,),(, or ^ is encountered c If (Ch1 .EQ. '(' .OR. Ch1 .EQ. ')' .OR. Ch1 .EQ. '/' .OR. $ Ch1 .EQ. '*' .OR. Ch1 .EQ. '^' .OR. Ch1 .EQ. '-' .OR. $ Ch1 .EQ. '+') Ibreak = 1 c c Check for legal characters c If ((Ch1 .GE. 'A' .AND. Ch1 .LE. 'Z') .OR. (Ch1 $ .GE. '0' .AND. Ch1 .LE. '9') .OR. (Ch1 .EQ. '+') $ .OR. (Ch1 .EQ. '-') .OR. (Ch1 .EQ. '/') .OR. $ (Ch1 .EQ. '*') .OR. (Ch1 .EQ. '(') .OR. (Ch1 $ .EQ. ')').OR. (Ch1 .EQ. '^') .OR. (Ch1 .EQ. $ '.') .OR. (Ch1 .EQ. '=')) Go To 5 c c Illegal character found c Write(6,400) Ch1 400 Format(' Illegal character in your input "',1A1, $ '" - TRY AGAIN') Iflag = 1 5 Continue c c Look for illegal combinations of characters c If (I .LT. Nchar) Then Ch2 = Line(I+1) c c Illegal for a open parenthesis to immediately follow c a closed parenthesis c If (Ch1 .EQ. ')' .AND. Ch2 .EQ. '(') Then Write(6,800) Ch1,Ch2 800 Format(' ERROR - Illegal combinations of characters -', $ ' "',2A1,'"') Iflag = 1 End If c c Illegal character combinations with the first c character an open parenthesis c If (Ch1 .EQ. '(' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Illegal character combinations with the first c character a "^" (for raising a number to a power) c If (Ch1 .EQ. '^' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Illegal character combinations with the first c character a multiply sign c If (Ch1 .EQ. '*' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Illegal character combinations with the first c character a division sign c If (Ch1 .EQ. '/' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Illegal character combinations with the first c character a plus sign c If (Ch1 .EQ. '+' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Illegal character combinations with the first c character a minus sign c If (Ch1 .EQ. '-' .AND. (Ch2 .EQ. '^' .OR. Ch2 .EQ. '/' $ .OR. Ch2 .EQ. '*' .OR. Ch2 .EQ. '+' .OR. Ch2 .EQ. $ ')')) Then Write(6,800) Ch1,Ch2 Iflag = 1 End If c c Improper use of a decimal point c If (I .GT. 1) Then Ch = Line(I-1) If (Ch1 .EQ. '.' .AND. ((Ch .LT. '0' .OR. Ch .GT. '9') $ .AND. (Ch2 .LT. '0' .OR. Ch2 .GT. '9'))) Then Write(6,500) 500 Format(' ERROR - Illegal use of decimal point') Iflag = 1 End If End If c End If 10 Continue c c Check to see if there are more than one equals signs c If (Iequal .GT. 1) Then Write(6,600) 600 Format(' ERROR - Improper use of equal sign - TRY AGAIN') Iflag = 1 End If c c Check to see if the total number of open parenthesis c is equal to the total number of closed parenthesis c If (Iparen .NE. 0) Then Write(6,700) 700 Format(' ERROR - Parenthesis are not balanced - TRY AGAIN') Iflag = 1 End If c Return c End Subroutine Cmpute(Val,Iprior,Iopt,Nvals,Iflag) c c *********************************************************************** c * * c * Subroutine CMPUTE - To compute the mathamatical expression. * c * * c * Input Data: * c * * c * Val - An array containing the numbers and variable * c * values to operate on * c * Iopt - An array containing numbers corresponding to * c * what operations are to be performed on the numbers * c * Iprior - Array containing the priority in which the * c * operations are to be performed (Highest, first) * c * Nvals - Total number of values (numbers and variables) * c * plus the number of function calls (SIN, etc) * c * * c * Output Data: * c * * c * Val(1) - The result from the expression * c * Iflag - Error return; equals 0 if no error is encountered * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Dimension Val(1),Iprior(1),Iopt(1) c Iflag = 0 PI180 = 3.141592654/180.0 N = Nvals - 1 c c Loop over the total number of operations (Nvals-1) c Do 30 I = 1,N Iflag1 = -16000 Npos = 1 c c Find the operation with the highest priority c Do 10 J=1,N If (Iprior(J) .GT. Iflag1) Then Iflag1 = Iprior(J) Npos = J End If 10 Continue c c Highest priority operation found, so compute operation c Ip = Iopt(Npos) J = Npos c c Operation is the equals sign c If (Ip .EQ. 0) Then Val(J) = Val(J+1) c c Operation is subtraction c Else If (Ip .EQ. 1) Then Val(J) = Val(J) - Val(J+1) c c Operation is addition c Else If (Ip .EQ. 2) Then Val(J) = Val(J) + Val(J+1) c c Operation is Multiplication - check for too large of results c Else If (Ip .EQ. 3) Then If (Abs(Val(J)) .LT. 1E20 .AND. Abs(Val(J+1)) .LT. 1E20) $ Then Val(J) = Val(J) * Val(J+1) Else Iflag = 1 Write(6,120) 120 Format(' ERROR - Numbers too large to multiply') End If c c Operation is division - check for zero denominator, and too c large of results c Else If (Ip .EQ. 4) Then If (Val(J+1) .NE. 0.0) Then If (Val(J) .EQ. 0.0) Then Val(J) = 0.0 Else If (Log(Abs(Val(J)))-Log(Abs(Val(J+1))) .GT. 38.0) $ Then Iflag = 1 Write(6,130) 130 Format(' ERROR - Infinite result from divide') Else Val(J) = Val(J) / Val(J+1) End If End If Else Iflag = 1 Write(6,100) 100 Format(' ERROR - Zero Divide ') End If c c Operation is raising a number to a power - check for too large c of results, and a negative number raised to a power c Else If (Ip .EQ. 5) Then If (Val(J) .GT. 0.0) Then If (Log(Abs(Val(J))) * Val(J+1) .LT. 38.0) Then Val(J) = Val(J)**Val(J+1) Else Iflag = 1 Write(6,140) 140 Format(' ERROR - Value of (number raised to power)', $ ' too large') End If Else If (Val(J) .EQ. 0.0) Then Val(J) = 0.0 Else c c If the number to be raised to a power is negative, it is c still OK if the power is an integer c If (Int(Val(J+1)) .EQ. Val(J+1)) Then If (Log(Abs(Val(J))) * Val(J+1) .LT. 38.0) Then Val(J) = (-Val(J))**Val(J+1) If (Int(Val(J+1)/2)*2 .NE. Val(J+1)) $ Val(J) = - Val(J) Else Iflag = 1 Write(6,140) End If Else Iflag = 1 Write(6,160) 160 Format(' ERROR - The number to be raised to a power ', $ 'is negative,'/' and the power is not an integer') End If End If c c Operations are Sine, Cosine, and Tangent c Else If (Ip .EQ. 6) Then Val(J) = Val(J) * Sin(Val(J+1)*Pi180) Else If (Ip .EQ. 7) Then Val(J) = Val(J) * Cos(Val(J+1)*Pi180) Else If (Ip .EQ. 8) Then Val(J) = Val(J) * Tan(Val(J+1)*Pi180) c c Operations are Arcsine and Arccosine - check for arguements c greater/less than +/- 1.0 c Else If (Ip .EQ. 9) Then If (Abs(Val(J+1)) .LE. 1.0) Then Val(J) = Val(J) * Asin(Val(J+1))/Pi180 Else Iflag = 1 Write(6,150) 150 Format(' ERROR - ARCSIN arguement greater than +/- 1.0') End If Else If (Ip .EQ. 10) Then If (Abs(Val(J+1)) .LE. 1.0) Then Val(J) = Val(J) * Acos(Val(J+1))/Pi180 Else Iflag = 1 Write(6,200) 200 Format(' ERROR - ARCCOS arguement greater than +/- 1.0') End If c c Operation is Arctangent c Else If (Ip .EQ. 11) Then Val(J) = Val(J) * Atan(Val(J+1))/Pi180 c c Operations are LOG (base 10) and LN (base e) - check for c nonpositive arguements c Else If (Ip .EQ. 12) Then If (Val(J+1) .GT. 0.0) Then Val(J) = Val(J) * Log10(Val(J+1)) Else Iflag = 1 Write(6,250) 250 Format(' ERROR - LOG arguement is less than or equal to', $ ' 0.0') End If Else If (Ip .EQ. 13) Then If (Val(J+1) .GT. 0.0) Then Val(J) = Val(J) * Log(Val(J+1)) Else Iflag = 1 Write(6,300) 300 Format(' ERROR - LN arguement is less than or equal to', $ ' 0.0') End If c c Operations are absolute value and integer c Else If (Ip .EQ. 14) Then Val(J) = Val(J) * Abs(Val(J+1)) Else If (Ip .EQ. 15) Then Val(J) = Val(J) * Int(Val(J+1)) c c Operation is expoenential - check for too large of an arguement c Else If (Ip .EQ. 16) Then If (Val(J+1) .LT. 88.0) Then Val(J) = Val(J) * Exp(Val(J+1)) Else Iflag = 1 Write(6,350) 350 Format(' ERROR - EXP arguement too large') End If c c Operation is square root - check for negative arguement c Else If (Ip .EQ. 17) Then If (Val(J+1) .GE. 0.0) Then Val(J) = Val(J) * Sqrt(Val(J+1)) Else Iflag = 1 Write(6,400) 400 Format(' ERROR - SQRT arguement is negative') End If End If c c Return now if an error is encountered c If (Iflag .EQ. 1) Return c c Shift the data stored after this up one - this also updates c the priority and operation flags c If (Npos .LE. N) Then Do 20 J=Npos+1,N+1 Val(J) = Val(J+1) Iprior(J-1) = Iprior(J) Iopt(J-1) = Iopt(J) 20 Continue End If 30 Continue Return End Subroutine Listeq(Icol,Narray) c c *********************************************************************** c * * c * Subroutine LIST - to list out the names and the values of * c * the user-defined variables. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Byte Names(1) Integer Icol(1) Character*20 Hold Integer*4 Funct(12) c Equivalence (Hold,Names(1)) c Data Hold/'ABCDEFGHIJKLMNOPQRST'/ c Data Funct/'SIN ','COS ','TAN ','ASIN','ACOS','ATAN','LOG ', $ 'LN ','ABS ','INT ','EXP ','SQRT'/ c Write(6,100) 100 Format(' Selected columns:'/) c c List the column numbers c Do 10 I=1,Narray Call Name(Titl,Icol(I),Title,Ttllen) Write(6,200) Names(I),Icol(I),(Titl(J),J=1,Ttllen(Icol(I))) 200 Format(1X,1A1,' = Column',I4,': ',A1) 10 Continue c c List the scientific functions c Write(6,300) (Funct(I),I=1,12) 300 Format(/' Available scientific functions:'/2(4X,6(A4,7X)/) $ ' ----- Trig functions use degrees -----'/ $ ' ----- to raise to a power, use "^" .... 10^3 -----'/) Return End