Subroutine WRTNOW(Data,Iflag) c c *********************************************************************** c * * c * Program WRTNOW - To write the datafiles for PLTPRG * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Virtual Data(1) Integer*4 Isave c c Compute the size of the file needed c Iflag = 0 Call Point(Isave,Ncols+1,Npoint) Call Point(Isave1,Ncols+1,Ttllen) Isave = (Isave * 4 + Ncols*10 + Isave1 + 100) / 512 + 1 c Open(Unit=12,NAME='PLTPRG.DAT',TYPE='NEW',ERR=99, $ FORM='UNFORMATTED',INITIALSIZE=Isave) c Write(12,END=99,ERR=99) Ncols c c Save number of points/column, number of characters/title c Write(12,END=99,ERR=99) (Npoint(I),I=1,Ncols) Write(12,END=99,ERR=99) (Ttllen(I),I=1,Ncols) c c Save the column titles c Call Point(Ipoint,Ncols+1,Ttllen) Write(12,END=99,ERR=99) (Title(I),I=1,Ipoint-1) c c Save the data c Call Point(Ipoint,Ncols+1,Npoint) c Write(12,END=99,ERR=99) (Data(I),I=1,Ipoint-1) c Close(Unit=12) Return 99 Close(Unit=12) Iflag = 1 Return End Subroutine REDNOW(Data) c c *********************************************************************** c * * c * Subroutine REDNOW - To read a file containing the data * c * for program PLTPRG * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) Byte Filnam(25) c c Open the scratchfile c Open(Unit=12,NAME='PLTPRG.DAT',TYPE='OLD',ERR=99, $ FORM='UNFORMATTED') c c Re-set the flag indicating the data has changed c Idflag = 0 c c Read in the heading data c Read(12,END=99,ERR=99) Ncols c Read(12,END=99,ERR=99) (Npoint(I),I=1,Ncols) Read(12,END=99,ERR=99) (Ttllen(I),I=1,Ncols) c Call Point(Ipoint,Ncols+1,Ttllen) Read(12,END=99,ERR=99) (Title(I),I=1,Ipoint-1) c c Read in the data c Call Point(Ipoint,Ncols+1,Npoint) Read(12,END=99,ERR=99) (Data(I),I=1,Ipoint-1) c 99 Continue Close(Unit=12) Return End Subroutine Pltdev(Idev,Iflag,Ibatch) c c *********************************************************************** c * * c * Subroutine PLTDEV - To get the plot device from the user * c * * c * Output value: * c * * c * Idev - The device number to plot to * c * Ibatch - Flag indicating whether job can be run as detached. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Character*75 Line Integer Batch(50) Include 'Cplsiz' c Open(Unit=12,Name='DP:PLTPRG.DVI',Type='OLD',Readonly) Write(7,100) 100 Format(/' Select the device to plot to:'/) Loop = 0 Lflag = 10000 10 Continue Read(12,150,END=20) Line 150 Format(A) If (Line(1:1) .EQ. '!') Go To 10 If (Line(1:1) .EQ. '$') Then If (Iflag .EQ. 1) Go To 20 Lflag = Loop Go To 10 End If Loop = Loop + 1 Read(12,*) Batch(Loop) Write(7,200) Loop,Line 200 Format(I3,2X,A) Go To 10 c 20 Continue c Close (Unit=12) J = Log10(Loop*1.0)+1.01 Write(7,250) Loop 250 Format(/' Select 1-',I,' ',$) Call Inchek(1,Loop,Idev) c Ibatch = Batch(Idev) If (Idev .LE. Lflag) Return Write(7,300) 300 Format(' First, place grid paper in the plotter. Then, enter'/ $ ' the X and Y distance of the paper corner to the lower'/ $ ' left corner of the grid, and the grid spacing (inches)') Call Indata(3,'RRR',Delx,Dely,Space) c Return End Subroutine Prout(Data,Xvals,Yvals,Numbr,Ix,Iy,Icheck,Iorder,Coefs) c c *********************************************************************** c * * c * Subroutine Prout - To print out the results from the * c * interpolation, integration, and differentiation routines * c * on the screen. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Cflags' c Virtual Data(1) c Byte Blank(8),Char,Sign Dimension Xvals(1),Yvals(1),Coefs(1),Lop(8) Dimension Isfig(20),Ideci(20) c Data Blank/8*' '/ Ncc = 3 Nline = 18 c c If we have a lot to print out; c c see if every value is to be printed out c Iprt = 1 Istart = 1 If (Numbr .GT. 100) Then Write(7,110) Numbr 110 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 5 Continue Write(7,120) 120 Format(' Enter the starting point, and the Nth point', $ ' to print') Call Indata(2,'II',Istart,Iprt) If (Istart .LT. 1 .OR. Istart .GT. Numbr .OR. Iprt $ .LT. 1 .OR. Iprt .GT. Numbr) Go To 5 End If End If c c Leave room to print out the Least squares coefficients c If ( Icheck .EQ. 2) Nline = Nline - 2 Num = (Numbr-Istart)/Iprt + 1 Nc = Num / Nline + 1 If (Nc .GT. Ncc) Nc = Ncc Loop = Num / Nc Mod = Num - Loop * Nc Lop(1) = 0 If (Nc .NE. 1) Then Do 10 I=2,Nc Lop(I) = Loop*Iprt + Lop(I-1) If (Mod .GE. (I-1)) Lop(I) = Lop(I) + 1*Iprt 10 Continue End If c c Write the data headers c Write(7,100) 27,27 100 Format(1X,1A1,'[H',1A1,'[J') Call Colchk(Ix,Iy,Iflag,7) Write(7,150) (Blank(K),K=1,Nc) 150 Format(/5(1A1,5x,'X',11X,'Y',7x)) Write(7,200) 200 Format(5X) c c Print the data in neat columns c Is = Istart - 1 If (Loop .NE. 0) Then L = 3 Do 20 I=1,Loop*Iprt,Iprt Write(7,250)(Xvals(I+Is+Lop(K)),Yvals(I+Is+Lop(K)), $ K=1,Nc) 250 Format(5(1X,G12.5,1X,G12.5)) c c If the screen is full, have the user press return to continue c L = L + 1 If (L .GE. 20) Then Call Spause L = 0 End If c 20 Continue End If If (Mod .NE. 0) Then Write(7,250) (Xvals(I+Is+Lop(K)),Yvals(I+Is+ $ Lop(K)),K=1,Mod) End If c c If it is a least squares fit, print the polynomial coefficients c If (Icheck .EQ. 2) Then c Call Digit(Coefs(1),Is,Id) c If (Coefs(1) .EQ. 0.0) Then Write(7,400) Else Write(7,400) Coefs(1) End If c 400 Format(/' Least Squares Fit Coefficients:'//1X, $ F.,$) c Icount = Is + Id + 1 Do 33 J=2,Iorder+1 c If (Coefs(J) .EQ. 0.0) Go To 32 If (Coefs(J) .LT. 0.0) Then Sign = '-' Else Sign = '+' End If c Coefs(J) = Abs(Coefs(J)) Call Digit(Coefs(J),Is,Id) c I1 = 1 + J/11 c If (Id .LT. 8 .AND. Is .LT. 8) Then Write(7,410) Sign,Coefs(J),J-1 410 Format('+ ',1A1,1X,F.,' * X^',I,$) Else Write(7,415) Sign,Coefs(J),J-1 415 Format('+ ',1A1,1X,G12.5,' * X^',I,$) Is = 6 Id = 5 End If c Icount = Icount + Is + Id + 10 32 Continue If ((J .EQ. Iorder+1) .OR. Icount .GT. 60) Then Write(7,420) 420 Format(1X) Icount = 0 End If 33 Continue End If c c c See if the user wishes to save the integrated/differentiated data c Write(7,450) 450 Format(' Do you wish to keep the computed values? (y/n) '$) Call Instrg('YyNn',4,Ichose) If (Ichose .LE. 2) Then c c See if there is room c If (Ncols .EQ. Ncolmx) Then Write(7,475) Ncolmx 475 Format(' Insufficient room - only',I4,' columns allowed'/) Return End If c Call Point(I,Ncols+1,Npoint) If (I+Npoint(Ix)-1 .GT. Last) Then Write(7,476) Last 476 Format(' Insufficient room - only',I6, $ ' total points allowed'/) Return End If c c Set flag to show that the data is changed c Idflag = 1 c c Get a title for the new columns c Write(7,500) 500 Format(' Enter a title for the values') Call Linedt(Titl,Nchars,80,0) Do 40 I = 1,2 Call Point(Ipoint,Ncols+1,Npoint) Call Point(Ititle,Ncols+1,Ttllen) c c Save the title, and append (X) and (Y) for the X and Y columns c Call Rep(Title,Ititle-1,Ititle,0,Titl,Nchars) Call Rep(Title,Ititle+Nchars-1,Ititle+Nchars,0,' (X)',4) Ttllen(Ncols+1) = Nchars + 4 Npoint(Ncols+1) = Numbr Ncols = Ncols + 1 c c Store the new computed data into DATA c Do 30 J=1,Numbr Data(Ipoint-1+J) = Xvals(J) Xvals(J) = Yvals(J) 30 Continue 40 Continue Call Rep(Title,Ititle+Nchars+3,Ititle+Nchars+2,1,'Y',1) c End If c Return End Subroutine Digit(Aval,Isfig,Ideci) c Character*12 Av Byte Bb(12) Equivalence (Bb(1),Av) c If (Aval .GE. 1.0) Isfig = Int(Log10(Aval)) + 1 If (Aval .LT. 1.0 .AND. Aval .GE. 0.0) Isfig = 1 If (Aval .LT. 0.0 .AND. Aval .GE. -1.0) Isfig = 2 If (Aval .LT. -1.0) Isfig = Int(Log10(-Aval)) + 2 Ipower = 0 If (Aval .LE. 100.0) Then ! If the increment > 100, no decimal place If (Aval .LT. 1.0 .AND. Aval .GT. 0.0) Then Ipower = -Int(Log10(Aval)) If (Ipower .GT. 0) Then Bval = Aval * 10.0 ** Ipower Else If (Ipower .LT. 0) Then Bval = Aval / 10.0 ** (-Ipower) Else Bval = Aval End If Else Bval = Aval End If Encode(12,100,Av) Bval 100 Format(G12.5) Iflag1 = 0 Iflag2 = 0 Do 20 I=12,1,-1 If (Bb(I) .NE. ' ' .AND. Iflag1 .EQ. 0 .AND. Bb(I) .NE. '0' $ ) Iflag1 = I If (Bb(I) .EQ. '.') Iflag2 = I ! Find the decimal point 20 Continue Ideci = Iflag1 - Iflag2 If (Iflag2 .EQ. 0) Ideci = 0 Else Ideci = 0 Endif Ideci = Ideci + Ipower If (Ideci .EQ. 0) Ideci = 1 If (Isfig .GT. 1 .AND. Aval .GT. 0.0) Ideci = Max0(6-Isfig,1) If (Isfig .GT. 2 .AND. Aval .LT. 0.0) Ideci = Max0(7-Isfig,1) Return End