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