Subroutine Prgevl(Data) c c *********************************************************************** c * * c * Subroutine Prgevl - To "run" users "programs" * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) c Dimension Val(50),Namept(50),Iopt(50),Icol(50), $ Iprior(50),Value(50),Ivar(50),Ipoint(50),Ip(50), $ Io(50),Ivrcon(50),Conval(50) Byte Line(132),Names(500),Filnam(15) c Equivalence (X(1),Names(1)),(X(126),Ipoint(1)),(X(151),Ip(1)), $ (X(176),Io(1)),(X(201),Ivrcon(1)),(X(226),Conval(1)), $ (X(251),Filnam(1)) Equivalence (Y(1),Val(1)),(Y(51),Value(1)), $ (Y(101),Namept(1)),(Y(126),Iopt(1)),(Y(151),Icol(1)), $ (Y(176),Iprior(1)),(Y(201),Ivar(1)),(Y(226),Line(1)) Equivalence (Line(1),Type) c Nvars = 0 Npt = 1 Ncolv = Ncols c Write(7,100) 27 100 Format(/1X,1A1,'#6 DATA ANALYSIS ROUTINE'/) c 10 Continue c c Prompt the user for the file containing the program c Write(7,150) 150 Format(' Enter the file name containing the compute routine'/ $ ' (Press return to stop)') Read(5,175,END=10,ERR=10) Filnam 175 Format(15A1) 200 Format(Q,80A1) Call Chknam(Filnam,Iflag) If (Iflag .EQ. 1) Return Open(Unit=12,Name=Filnam,Type='OLD',Readonly,ERR=15) Write(7,175) Go To 20 c 15 Continue c Write(7,250) 7 250 Format(' ERROR - Bad filename - Try again',1A1) Go To 10 c c Read the header out of the file c 20 Continue Read(12,200,END=99,ERR=99) Nchars,(Line(I),I=1,Nchars) If (Line(1) .EQ. '$') Go To 30 Write(7,300) (Line(I),I=1,Nchars) 300 Format(1X,A1) Go To 20 c c Get the column variable names & prompts c 25 Continue Read(12,200,END=90,ERR=90) Nchars,(Line(I),I=1,Nchars) 30 Continue Call Blanks(Line,Nchars) c If (Type .EQ. '$VAR' .OR. Type .EQ. '$CON') Then Types = Type c c ************** If a variable column or constant is needed: ************ c Call Point(Istart,Nvars+1,Namept) Do 35 I=6,Nchars Names(Istart+I-6) = Line(I) 35 Continue Nvars = Nvars + 1 Namept(Nvars) = Nchars - 5 c c Print out the column variable or constant prompt c Write(7,300) 7 40 Continue Read(12,200,END=90,ERR=90) Nchars,(Line(I),I=1,Nchars) If (Line(1) .EQ. '$') Go To 45 Write(7,300) (Line(I),I=1,Nchars) Go To 40 c 45 Continue If (Types .EQ. '$VAR') Then Call Invars(Ivrcon,Icol,Ipoint,Nvars,Npt,Iflag) If (Iflag .EQ. 1) Return Else Ivrcon(Nvars) = 1 Call Indata(1,'R',Conval(Nvars)) End If Go To 30 c Else If (Type .EQ. '$EQN') Then c c **************** Set up and do the computations **************** c c Look for (an) illegal character(s) c If (Ncolv .GE. Ncolmx-1) Go To 99 Call Point(It,Ncolv+1,Npoint) If (It+Npt-1 .GT. Last) Go To 99 Nchars = Nchars - 5 Call Ilegal(Line(6),Nchars,Iflag) c c End if an illegal character is encountered c If (Iflag .GT. 0) Go To 99 c c Get the variable name that results c Call Point(Istart,Nvars+1,Namept) Do 50 I=1,Nchars Names(Istart+I-1) = Line(I+5) If (Line(I+5) .EQ. '=') Go To 55 50 Continue Go To 99 55 Continue c c Set the various pointers for the new variable name c Do 57 J=1,Nvars If (Ivrcon(J) .EQ. 3) Then If (Namept(J) .EQ. I-1) Then Call Point(Np,J,Namept) Do 56 K=1,I-1 If (Names(Np-1+K) .NE. Names(Istart+K-1)) Go to 57 56 Continue Call Point(Lastpt,Icol(J),Npoint) Narray = Nvars Go To 58 End If End If 57 Continue Nvars = Nvars + 1 Namept(Nvars) = I - 1 Ivrcon(Nvars) = 3 Narray = Nvars - 1 Ncolv = Ncolv + 1 Ttllen(Ncolv) = 0 Npoint(Ncolv) = Npt Icol(Nvars) = Ncolv c Call Point(Ipoint(Nvars),Ncolv,Npoint) Call Point(Lastpt,Ncolv,Npoint) c c Interpret the string c 58 Continue Nchars = Nchars - I Call Inpret(Value,Ivar,Iprior,Iopt,Nvals,Names,Namept, $ Narray,Line(I+6),Nchars,Iflag) If (Iflag .GT. 0) Go To 99 c c Load the variable values into the proper arrays c Do 65 Loop=1,Npt Do 60 J=1,Nvals If (Ivar(J) .GT. 0) Then If (Ivrcon(Ivar(J)) .GE. 2) Then Val(J) = Value(J) * Data(Loop+Ipoint(Ivar(J))-1) Else Val(J) = Value(J) * Conval(Ivar(J)) End If Else Val(J) = Value(J) End If c c Load the operation priority and function pointers c Ip(J) = Iprior(J) Io(J) = Iopt(J) 60 Continue c c Evaluate the equation c Nv = Nvals Call Cmpute(Val,Ip,Io,Nv,Iflag) c c Check for errors c If (Iflag .EQ. 1) Go To 99 c c Store results c Data(Loop+Lastpt-1) = Val(1) c 65 Continue c c Go back for the next input c Go To 25 c Else If (Type .EQ. '$SAV') Then c c ************** Save the computed results *********** c c Match the variable name to save with known variable names c Inew = Ncolv - Ncols Nchars = Nchars - 5 Do 80 I=1,Inew K = Nvars - Inew + I If (Nchars .NE. Namept(K)) Go To 80 Call Point(Ipt,K,Namept) Do 75 J=1,Nchars If (Line(J+5) .NE. Names(Ipt+J-1)) Go To 80 75 Continue Igood = Ncols + I Go To 85 80 Continue Go To 99 85 Continue c c Get the prompt for the column title c Write(7,300) 7 86 Continue Read(12,200,END=87,ERR=87) Nchars,(Line(I),I=1,Nchars) If (Line(1) .EQ. '$') Go To 87 Write(7,300) (Line(I),I=1,Nchars) Go To 86 87 Continue Call Point(Ipt,Igood,Ttllen) Call Point(Itend,Ncolv+1,Ttllen) c c Input the "saved" column title c Call Linedt(Titl,Nchar,70,0) Call Rep(Title,Itend,Ipt,Ttllen(Igood),Titl,Nchar) Ttllen(Igood) = Nchar c If (Line(1) .EQ. '$') Go To 30 Else c c Line that isn't anything: c Write(7,300) (Line(I),I=1,Nchars) Go To 25 End If c 90 Continue c c ******************* Delete out unwanted columns ****************** c Nc = Ncolv Do 98 I=Nc,Ncols+1,-1 c c If the title length is zero, do not save the column c If (Ttllen(I) .EQ. 0) Then Call Point(Ipt,I+1,Npoint) Call Point(Iend,Ncolv+1,Npoint) Np = Npoint(I) Do 95 J=Ipt,Iend Data(J-Np) = Data(J) 95 Continue Ncolv = Ncolv - 1 c c Update pointers c Do 97 J=I,Ncolv Ttllen(J) = Ttllen(J+1) Npoint(J) = Npoint(J+1) 97 Continue End If 98 Continue c c Set data change flag if any data saved c If (Ncolv .GT. Ncols) Then Idflag = 1 Write(7,890) 27,27 890 Format(/10X,1A1,'[1;7mADDED COLUMNS:',1A1,'[0m'// $ ' Col# Title'/) Do 91 I=Ncols+1,Ncolv Call Name(Titl,I,Title,Ttllen) Write(7,895) I,(Titl(J),J=1,Ttllen(I)) 895 Format(I5,4X,A1) 91 Continue End If Ncols = Ncolv Close(Unit=12) Return c 99 Continue Close(Unit=12) Write(7,900) 900 Format(' ERROR Encountered - Routine aborted') Return End Subroutine Usrpgm(Data) c *********************************************************************** c * * c * Subroutine Usrpgm - To prompt the user to see whether the * c * user wants to run or create a user written data analysis * c * routine. * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Virtual Data(1) c Write(7,100) 27 100 Format(//2X,1A1,'#6USER WRITTEN DATA ANALYSIS ROUTINES'// $ ' SELECT:'//' 1) Execute a routine'/' 2) Create a', $ ' routine'/' 3) Stop'//' Enter 1-3 ',$) c Call Inchek(1,3,Ich) If (Ich .EQ. 1) Then Call Prgevl(Data) Else If (Ich .EQ. 2) Then Call Creprg End If Return End Subroutine Creprg c c *********************************************************************** c * * c * Subroutine Creprg- To "create" users "programs" * c * * c * Programmed By Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Byte Names(500),Filnam(15) Dimension Namept(50),Iopt(50),Iprior(50),Value(50),Ivar(50) c Equivalence (X(1),Names(1)),(X(251),Filnam(1)) Equivalence (Y(1),Value(1)),(Y(51),Namept(1)),(Y(76),Iopt(1)), $ (Y(101),Iprior(1)),(Y(126),Ivar(1)) c Nvars = 0 Istart = 1 c Write(7,100) 27 100 Format(/1X,1A1,'#6 DATA ANALYSIS CREATION ROUTINE'/) c 10 Continue c c Prompt the user for the file containing the program c Write(7,150) 150 Format(' Enter the file name to store the compute routine') Read(5,175,END=10,ERR=10) Filnam 175 Format(15A1) 200 Format(Q,80A1) c c Check the file name out: c Isave = 5 Call Filchk(Filnam,Isave,Iflag) If (Iflag .EQ. 1) Return c Write(7,250) 250 Format(' Enter the heading text for the routine. Press return', $ ' twice to end the header') Open(Unit=12,Name=Filnam,Type='NEW',ERR=99) Rewind(12) c c Read the header out of the file c Call Prompt(Titl) c c Get the column variable names & prompts c 25 Continue Write(7,350) 'data columns' 350 Format(' Enter the number of ',A,' you will use ',$) Call Inchek(0,20,Nvars) Do 35 I=1,Nvars Write(7,400) 'column variable',I 400 Format(' Enter the name for ',A,' number ',I2,':') Call Linedt(Names(Istart),Nchars,70,0) Call Blanks(Names(Istart),Nchars) Write(12,450) '$VAR:',(Names(J+Istart-1),J=1,Nchars) 450 Format(A5,A1) Istart = Istart + Nchars Namept(I) = Nchars Write(7,500) 'column' 500 Format(' Enter the prompt text for this ',A,'. Press', $ ' return twice to end the prompt') Call Prompt(Titl) 35 Continue c c c Get the column variable names & prompts c Write(7,350) 'input constants' Call Inchek(0,20,Ncons) Do 45 I=1,Ncons Write(7,400) 'constant',I Call Linedt(Names(Istart),Nchars,70,0) Call Blanks(Names(Istart),Nchars) Write(12,450) '$CON:',(Names(J+Istart-1),J=1,Nchars) Istart = Istart + Nchars Namept(I+Nvars) = Nchars Write(7,500) 'constant' Call Prompt(Titl) 45 Continue Nvars = Ncons + Nvars c c ************** Get the equations to use ************** c Write(7,350) 'equations' Call Inchek(0,40,Neq) Do 70 I=1,Neq Iflag = 0 50 Continue Write(7,700) I 700 Format(' Enter equation number ',I2,':') Call Linedt(Titl,Nchars,80,Iflag) Call Blanks(Titl,Nchars) Call Ilegal(Titl,Nchars,Iflag) c c If an illegal character is encountered; c If (Iflag .GT. 0) Go To 50 c c Get the variable name that results (save the left hand side) c Call Point(Istart,Nvars+1,Namept) Do 55 J=1,Nchars Names(Istart+J-1) = Titl(J) If (Titl(J) .EQ. '=') Go To 60 55 Continue Write(7,800) 800 Format(' ERROR - There must be an equals sign -', $ ' Try again') Go To 50 60 Continue c Namept(Nvars+1) = J - 1 c c Interpret the string c Nchar = Nchars - J Call Inpret(Value,Ivar,Iprior,Iopt,Nvals,Names,Namept, $ Nvars,Titl(J+1),Nchar,Iflag) If (Iflag .GT. 0) Go To 50 Nvars = Nvars + 1 c c Save the string c Write(12,450,END=99,ERR=99) '$EQN:',(Titl(J),J=1,Nchars) 70 Continue c c ************** To save the computed results *********** c Write(7,850) 850 Format(' Enter the number of new columns to save: ',$) Call Inchek(0,50,Nsav) Do 95 I=1,Nsav 75 Continue Write(7,875) 875 Format(' Enter the name of the variable representing a', $ ' column to save') Call Linedt(Titl,Nchars,30,0) Call Blanks(Titl,Nchars) c c Match the variable name to save with known variable names c Do 85 L=1,Neq K = Nvars + 1 - L If (Nchars .NE. Namept(K)) Go To 85 Call Point(Ipt,K,Namept) Do 80 J=1,Nchars If (Titl(J) .NE. Names(Ipt+J-1)) Go To 85 80 Continue Go To 90 85 Continue c c Variable does not exist c Write(7,900) 900 Format(' This variable does not exist - try again') Go To 75 90 Continue c c Get the prompt for the column title c Write(12,450,END=99,ERR=99) '$SAV:',(Titl(J),J=1,Nchars) Write(7,925) 925 Format(' Enter the prompt text for a title for this', $ ' variable (Return twice to finish)') Call Prompt(Titl) 95 Continue Close(Unit=12) Return c 99 Continue Close(Unit=12) Write(7,950) 950 Format(' ERROR Encountered while writing to file - Routine ', $ 'aborted') Return End Subroutine Prompt(Titl) c *********************************************************************** c * * c * Subroutine Prompt - to write the analysis routine headers * c * and prompts to a file * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Titl(1) c 10 Continue c Call Linedt(Titl,Nchars,80,0) If (Nchars .EQ. 0) Go To 20 Write(12,100,END=20,ERR=20) (Titl(J),J=1,Nchars) 100 Format(A1) Write(7,200) 27 200 Format('+',1A1,'[A',$) Go To 10 20 Return End