Subroutine Tabprt(Data) c c *********************************************************************** c * * c * Subroutine Tabprt - to print out the table on the screen, * c * or send it to a printer or file. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' Include 'Ctable' Include 'Cflags' c Integer*4 Status,Lib$Spawn Character*60 Command Integer*4 Ia,Ai Double Precision Av,Ar Virtual Data(1) c Dimension Isfig(Nhedmx),Ihedln(Nhedmx),Ns(Nhedmx),Lesc(11), $ Iwid(11) Byte Line(150),Byt Character*60 File_Name,Upesc*20,Downesc*20,Escape(11)*20,Chr*1, $ String*132 Equivalence (Byt,Chr),(String,Line) c c See if all of the table data exists c Iflag = 0 Do 1 I=1,Ntab If (Tabcol(I) .GT. Ncols) Then Write(6,100) I 100 Format(' ERROR - There is no data for table column ',I3, $ '. Table cannot be printed.') Iflag = 1 End If 1 Continue 2 Continue If (Iflag .EQ. 1) Return c c Find out what you will print to c 3 Continue Write(6,110) 110 Format(/' Select the device to print the table to:'// $ ' 1) Screen'/ $ ' 2) System Printer'/ $ ' 3) Printer attached to terminal'/ $ ' 4) Disk File'//' Enter 1-4 ',$) Call Inchek(1,4,Ichose) c c Set up according to the proper output unit c Lwidth = 80/2 If (Ichose .EQ. 1) Then c c To the screen; c Write(6,120) 27,27 120 Format(1X,1A1,'[H',1A1,'[J') Iunit = 6 Iup = 1 Upesc = '^' Idown = 0 Else If (Ichose .EQ. 2) Then c c System printer; c Lwidth = 96/2 Nwid = 1 Iprt = 1 Open(Unit=12,Name='DP:PLTPRG.PTR',TYPE='OLD',ERR=12,SHARED, $ Readonly) Call Instr(Nchars,String,1) Read(String(1:Nchars),130,ERR=3) Nprint 130 Format(20I10) If (Nprint .GT. 1) Then Write(6,140) 140 Format(/' Select the printer to use:'/) Do 5 I=1,Nprint Call Instr(N,String,0) Write(6,150) I,(String(1:N)) 150 Format(I3,') ',A) 5 Continue Write(6,160) Nprint 160 Format(/' Enter 1-',I1,' ',$) Call Inchek(1,Nprint,Iprint) Else Call Instr(N,String,0) Iprint = 1 End If c Do 10 J=1,Iprint Call Instr(Nchars,String,1) Read(String(1:Nchars),130,ERR=3) Nwid,Ispool, $ (Iwid(I),I=1,Nwid) Do 7 I=1,Nwid+1 Call Instr(Lesc(I),Escape(I),0) 7 Continue Call Instr(Iup,Upesc,0) Call Instr(Idown,Downesc,0) 10 Continue c Close(Unit=12) If (Nwid .GT. 1) Then Write(6,170) (I,Iwid(I),I=1,Nwid),Nwid 170 Format(/' Select the page width:'// $ (I3,') ',I3,' Characters'/)/ $ ' Enter 1-',I1,' ',$) Call Inchek(1,Nwid,Iprt) End If Lwidth = Iwid(Iprt)/2 c 12 Continue Open(Unit=12,Name='Prt.out',Type='NEW',ERR=3) Write(12,180) Escape(Iprt) (1:Lesc(Iprt)) 180 Format(1X,A,$) Iunit = 12 Else If (Ichose .EQ. 3) Then c c To the printer hooked to the terminal c Iunit = 6 Lwidth = 80/2 c Nwid = 1 Iprt = 1 Open(Unit=12,Name='Sys$Login:PLTPRG.TPR',TYPE='OLD',ERR=16, $ Readonly) Go To 20 16 Continue Open(Unit=12,Name='DP:PLTPRG.TPR',TYPE='OLD',ERR=30, $ Readonly) 20 Continue c Call Instr(Nchars,String,1) Read(String(1:Nchars),130,ERR=3) Nprint If (Nprint .GT. 1) Then Write(6,190) 190 Format(/' Select the terminal printer type:'/) Do 22 I=1,Nprint Call Instr(N,String,0) Write(6,150) I,String(1:N) 22 Continue Write(6,160) Nprint Call Inchek(1,Nprint,Iprint) Else Call Instr(N,String,0) Iprint = 1 End If c Do 26 J=1,Iprint Call Instr(Nchars,String,1) Read(String(1:Nchars),130,ERR=30) Nwid,Ispool, $ (Iwid(I),I=1,Nwid) Do 24 I=1,Nwid+1 Call Instr(Lesc(I),Escape(I),0) 24 Continue Call Instr(Iup,Upesc,0) Call Instr(Idown,Downesc,0) 26 Continue c Close(Unit=12) If (Nwid .GT. 1) Then Write(6,170) (I,Iwid(I),I=1,Nwid),Nwid Call Inchek(1,Nwid,Iprt) End If Lwidth = Iwid(Iprt)/2 c 30 Continue c Close(Unit=12) Write(6,200) 27 200 Format(1X,1A1,'[5i',$) Write(6,180) Escape(Iprt) (1:Lesc(Iprt)) Else c c To a file; c Write(6,250) 250 Format(' Enter the file name to write to: ',$) Read(5,300,END=98,ERR=98) File_name 300 Format(A) Call Chknam(File_Name,Iflag) If (Iflag .EQ. 1) Return Call Tabwid(Data,Ns,Ntab,Maxwid) c c Compute file size c Maxno = 0 Ifl = 0 Do 40 I=2,Ntab Maxno = Max0(Maxno,Npoint(Tabcol(I))) If (Isci(I) .NE. 0) Ifl = 1 40 Continue Isave = 4 ! + (Maxwid/2.+45.)*Maxno/512. c Call Filchk(File_Name,Isave,Iflag) If (Iflag .EQ. 1) Return c If (Ifl .NE. 0) Then Write(6,310) 310 Format(' There is scientific notation used - select:'// $ ' 1) Dec printer type'/ $ ' 2) Diablo printer type'/ $ ' 3) Screen "^" symbol'// $ ' Select 1-3 ',$) Call Inchek(1,3,It) c Byt = 27 Upesc = ' L' Upesc(1:1) = Chr Iup = 2 Downesc = ' K' Downesc(1:1) = Chr Idown = 2 If (It .EQ. 2) Then Upesc(2:2) = 'D' Downesc(2:2) = 'U' Else If (It .EQ. 3) Then Upesc ='^' Iup = 1 Idown = 0 End If End If c Open(Unit=12,Name=File_Name,Type='NEW',ERR=99, $ Carriagecontrol='LIST') Iunit = 12 End If c Call Tabcmp(Data,Isfig,Ihedln) c c Initialize parameters c Lmax = Tcolen(2) Do 45 I=2,Ntab Lmax = Max0(Lmax,Tcolen(I)) 45 Continue Iloop = 0 Jloop = 0 c c First, compute the maximum width of the table c Maxwid = Isfig(Ntab) Do 54 I=2,Ntab-1 Maxwid = Nspac(I-1) + Isfig(I) + Maxwid 54 Continue If (Lwidth .LT. Maxwid/2) Lwidth = Maxwid/2 + 1 If (Ichose .EQ. 1 .AND. Lwidth .GT. 40) Then Lwidth = 66 Write(6,320) 27,'h' 320 Format(1X,1A1,'[?3',A,$) End If c 50 Continue c c Form feed a printer attached to the terminal c If (Jloop .NE. 0 .AND. Ichose .EQ. 3) Then Write(Iunit,325) 12 325 Format(1X,1A1) End If c Jloop = Tcolen(1) + 5 + Lmax Iprtit = Max0(Jloop+2,Iprtln) c c Print out the header c Write(Iunit,350,ERR=98) 350 Format(/) Do 56 I=1,Tcolen(1) If (Iabort .EQ. .TRUE.) Call Abort Call Name(Titl,I,Table,Tablen) Write(Iunit,400,ERR=98) (Titl(J),J=1,Tablen(I)) 400 Format(X,A1) 56 Continue Write(Iunit,350,ERR=98) c c Write out the table header c Do 68 I=1,Lmax Do 58 J=1,132 Line(J) = ' ' 58 Continue Istart = Lwidth - Maxwid/2 Do 64 J=2,Ntab Istart = Isfig(J)/2 + Istart If (Tcolen(J) .GE. I) Then Call Point(K,J,Tcolen) Call Name(Titl,K+I-1,Table,Tablen) Do 60 L=1,Tablen(K+I-1) Line(Istart+L-1-Tablen(K+I-1)/2) = Titl(L) 60 Continue End If If (J .LT. Ntab) Istart = Istart+(Isfig(J)-Isfig(J)/2)+ $ Nspac(J-1) 64 Continue Iend = Istart + Max0(Ihedln(Ntab),Isfig(Ntab))-Isfig(Ntab)/2 Write(Iunit,450,ERR=98) (Line(J),J=1,Iend) 450 Format(1X,A1) 68 Continue c c Turn the data into an ASCII character string, and c write it out. c Write(Iunit,500,ERR=98) 500 Format(1X) c 70 Continue Jloop = Jloop + 1 c c See if there are too many lines on this page c If (Jloop .GT. Iprtit) Go To 50 ! Setting the lines per page c Iloop = Iloop + 1 Ipoint = Lwidth - Maxwid/2 Iflag = 0 Do 72 J=1,132 Line(J) = ' ' 72 Continue c c Start getting the values loaded into a character string c Do 90 J=2,Ntab If (Npoint(Tabcol(J)) .GE. Iloop) Then Iflag = 1 Call Point(Ipt,Tabcol(J),Npoint) A = Data(Ipt+Iloop-1) c c Round off the values c If (Round(J) .NE. 0.0) Then Av = A Ar = Round(J) If (Av .LT. 0.0) Then Av = Av/Ar - 0.499999D0 Else Av = Av/Ar + 0.5 End If c c See if we can round off - this requires that the value / round off c value must not be so large that it cannot be represented by a c four byte integer value c If (Abs(Av) .LT. 2E9) Then Ai = Av A = Ai * Ar End If End If If (Ndeci(J) .GT. 0) Then c c If we have a decimal point c Encode(Isfig(J),550,Line(Ipoint)) A 550 Format(F.) Else c c No decimal point c Ia = A Encode(Isfig(J),600,Line(Ipoint)) Ia 600 Format(I) End If c c Add in the commas if required c If (Icom(J) .EQ. 1) Then Nc = 0 Isf = Isfig(J) - Ndeci(J) If (Ndeci(J) .GT. 0) Isf = Isf - 1 If (A .NE. 0.0) Then Av = A Nc = DLog10(Dabs(Av))/3 If (Nc .LT. 0) Nc = 0 End If Do 76 K=Nc,1,-1 Do 74 Kk=Ipoint,Ipoint+Isf-2-K*3 Line(Kk) = Line(Kk+1) 74 Continue Line(Ipoint+Isf-1-K*3) = ',' 76 Continue End If c c Add scientific notation exponent c If (Isci(J) .NE. 0) Then If (Isci(J) .GT. 0) Then Kk = 7 Else Kk = 8 End If Do 78 K = Ipoint,Ipoint+Isfig(J)-1-Kk Line(K) = Line(K+Kk) 78 Continue c K = Ipoint + Isfig(J) - Kk - 1 Line(K+1) = ' ' Line(K+2) = '*' Line(K+3) = ' ' Line(K+4) = '1' Line(K+5) = '0' c If (Isci(J) .LT. 0) Then Line(K+6+Iup) = '-' Line(K+7+Iup) = 48 - Isci(J) Iskip = 2 Else Line(K+6+Iup) = 48 + Isci(J) Iskip = 1 End If c c Set up superscripts c Do 80 I=1,Iup Chr = Upesc(I:I) Line(K+5+I) = Byt 80 Continue c c Return from the superscript c Do 84 I=1,Idown Chr = Downesc(I:I) Line(K+Iup+5+Iskip+I) = Byt 84 Continue c c If Idown is equal to zero, then the superscript c is represented by a printed symbol, so don't c update this pointer. c If (Idown .GT. 0) Ipoint = Ipoint + Iup + Idown End If c End If Ipoint = Ipoint + Isfig(J) + Nspac(J-1) 90 Continue c Write(Iunit,650,ERR=98) (Line(J),J=1,Ipoint) 650 Format(1X,A1) c If (Iflag .EQ. 1) Go To 70 c c End here; close files or close terminal printer port, or c wait for a return to continue (screen option only) c Write(Iunit,500,ERR=98) 97 Continue If (Ichose .EQ. 4) Close(Unit=12) c If (Ichose .EQ. 3) Then Write(6,180) Escape(Nwid+1) (1:Lesc(Iprt)) Write(6,700) 27 700 Format(1X,1A1,'[4i') End If If (Ichose .EQ. 1) Call Spause If (Ichose .EQ. 1 .AND. Lwidth .GT. 40) Write(6,320) 27,'l' If (Ichose .EQ. 2) Then c c Print file on system printer, and reset (if necessary) c the printer character width c Write(12,180) Escape(Nwid+1) (1:Lesc(Iprt)) Close(Unit=12) c c For the system printer, determine where to c print the data out Byt = 48 + Iprint If (Ispool .EQ. 1) Then Command = ' Print/Device=Prtdev /delete/noid Prt.out ' c 123456789t123456789t1 Command(21:21) = Chr Status = Lib$Spawn(Command) Else Command = ' Copy/nolog Prt.out Prtdev : ' c 123456789t123456789t123456789t123456 Command(27:27) = Chr Status = Lib$Spawn(Command) Open(Unit=12,Name='Prt.out',Type='OLD',Dispose='DELETE', $ ERR=96) Close(Unit=12) 96 Continue End If End If Return c c ********** ERROR RETURNS ********** c 98 Continue c Write(6,750) 750 Format(' ERROR in write statement - routine aborted') Go To 97 c 99 Continue c Write(6,800) 800 Format(' ERROR in opening file - routine aborted') Go To 97 c End Subroutine Instr(Nchars,String,Iflag) c c *********************************************************************** c * * c * Subroutine Instr - To read in strings of dats? * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Character*(*) String c c Read in the character string c 5 Continue Read(12,100,ERR=5) Nchars,String 100 Format(Q,A) If (String(1:1) .EQ. '!') Go To 5 c c Put commas in string if we are to read it later c If (Iflag .EQ. 1) Then Do 10 J=2,Nchars If (String(J:J) .EQ. ' ' .AND. String(J-1:J-1) .NE. ',' $ .AND. String(J-1:J-1) .NE. ' ') String(J:J) = ',' 10 Continue c End If Return End