************************************************************************* * * * FORTRAN 77 spool subroutine * * * * PURPOSE: * * * * To print a file as a background task. * * * * This file is used to generate the core of * * the file 'spool.s', see the comments in * * 'spool.s' for instructions on customizing spool.sub * * * * METHOD: * * * * subroutine call from FORTRAN * * * * ARGUMENTS: * * * * name type description * * * * FILE CHARACTER file name to be printed * * PRINTER INTEGER file name to accept output * * SWITCHES INTEGER switches: * * * * the following switch values are implemented, * * all others are ignored: * * * * 4 - delete file when done printing * * 16 - print file with header * * 64 - supply a trailing line feed (ascii 12) * * 32768 - pass the input file directly to the output * * file with no changes. * * * * COPIES INTEGER number of copies * * LPP INTEGER lines per page * * WIDTH INTEGER page width * * * * * * DEFAULT SWITCHES: * * * * if implicitly called by printing or writing to unit 6: * * * * delete file when done, no headers, * * trailing form feed * * * * if called explicitly as a subroutine: * * * * delete file when done, no headers, * * trailing form feed, * * LF's are output as CR-LF pairs * * * * (LF to CRLF can be turned of with 32768) * * * * CALLING SEQUENCE: * * * * CALL SPOOL(FILE,PRINTER,SWITCHES,COPIES,LPP,WIDTH) * * * ************************************************************************* * * * Edit history: * * 28 Mar 86 file created JAK * 03 Apr 86 rewritten for AMIGA JAK * 07 Apr 86 added 'who' argument to simplify this routine JAK * subroutine spool(file,printer,switch,copies,lpp,width,who) implicit none character*(*) file character*(*) printer integer switch integer copies integer lpp integer width integer who ! NOT a user argument integer RL,USER ! defined values of 'who' parameter(RL=1,USER=0) * bit positions in switches. * Note: * * 1. although switches is implemented as * a long, only the low order word is used. It is declared long to allow * the user to call spool with constants for integer expressions as actual * arguments * 2. All possible switches are listed below for portability reasons. Only * those switches listed in the header above are actually checked or used. * * low order byte of switch - defined as stated in Reference Manual. * * bits 0 & 1 - banner control are not currently implemented. * Bit 8 - wait if print queue full, is system dependent, and is not * implemented in this version. * * Also note: the 'no_' bits are ignored, we just check to see if the * on bit is set. * C integer reserv0 ; parameter(reserv0 =2**0) C integer reserv1 ; parameter(reserv1 =2**1) integer delete ; parameter(delete =2**2) integer no_del ; parameter(no_del =2**3) integer headers ; parameter(headers =2**4) integer no_head ; parameter(no_head =2**5) integer FFend ; parameter(FFend =2**6) integer no_FFend ; parameter(no_FFend=2**7) C integer reserv8 ; parameter(reserv8 =2**8) integer lf2cr ; parameter(lf2cr =2**9) integer cr2lf ; parameter(cr2lf =2**10) integer cr2crlf ; parameter(cr2crlf =2**11) integer lf2crlf ; parameter(lf2crlf =2**12) integer crstrip ; parameter(crstrip =2**13) integer lfstrip ; parameter(lfstrip =2**14) integer noformat ; parameter(noformat=2**15) * local stuff logical exist ! inquire variable character pr*20 ! local copy of printer integer sl ! local copy of switches integer wi ! local copy of width integer lp ! local copy of lp integer pn ! page number integer ln ! line number integer cc ! current column integer kx ! multipurpose scratch variable integer*1 c ! input buffer logical endlin ! fcn - called at end of a line logical NEWPAG ! endlin return value integer*1 CR,LF integer IN,OUT ; parameter(IN=1,OUT=2) character*(*) DEFPRNTR parameter (DEFPRNTR="PRT:RAW") ! for parallel printers c parameter (DEFPRNTR="SER:") ! for serial printers CR = 13 LF = 10 * * if there is nothing to print just return: * inquire(file=trim(file),size=kx,exist=exist) if ((.not.exist).or.(kx=0)) RETURN * * - check the arguments, supplying the default if an argument is * not supplied. * pr = printer ; if (pr=" ") pr=DEFPRNTR lp = lpp ; if (lp<=6) lp = 66 ! minimum page = 6 lines wi = width ; if (wi<0) wi = 0 ! no width adjustments * mask of the bits we don't care about from switch sl = switch .and.(delete+headers+FFend+noformat) * use the defaults if no switches were specified: if (sl = 0) sl = delete+no_head+FFend * if the width specified is too small to support headers, turn them off: if ((wi<>0).and.(wi<66)) sl = sl .and.(.not.headers) * Headers imply page formatting. Consequently to pretty the output up * we leave 3 blank line at the end of a page. Adjust lines per page * specification to automatically generate these 3 lines: if ((lp=66).and.(headers.and.sl)) then lpp = 66 ! no adjustment for defaults elseif (headers.and.sl) then lp = lp - 3 ! room for footer and header elseif (lp=66) then ! no header with default... lp = 72 ! ...lpp, make lpp 72 endif DO (copies times) open(IN,file=file,form="unformatted",status="old") open(OUT,file=pr,form="unformatted",status="new") if ((sl.and.noformat)<>0) then ! for unformatted, pure... read(IN,iostat=kx) c ! ...byte stream, just copy do while (kx=0) ! ...IN to OUT write(OUT) c read(IN,iostat=kx) c repeat else ! formatted output pn = 1 ! page number = 1 ln = 0 ! line number = 0 cc = 0 ! column zero if (sl.and.headers) then call outhd(pn,file) ln = 3 ! outhd puts out 3 lines endif do READ(IN,iostat=kx) c ! transfer data and filter... 100 if (kx<>0) exit ! ...until end of file if(c=CR.or.c=LF) then if(endlin(c,who,cc,pn,ln,wi,lp)) then if (sl.and.headers) then write(OUT) CR,LF,CR,LF,CR,LF ! soft form feed ln = 3 ! outhd puts out 3 lines call outhd(pn,file) if (c<>0) then ! flush any look ahead write(OUT) c ! character from endlin cc = 1 endif endif endif else write(OUT) c ! output the character cc = cc + 1 ! count it if((cc>=wi).and.(wi<>0))then ! full line? do while((c<>10).and.(c<>13)) read(IN,iostat=kx) c ! yes, truncate the line if (kx<>0) exit repeat GOTO 100 endif endif repeat if (FFend.and.sl)write(OUT)char(12) ! trailing Form feed close(IN) close(OUT) endif ! formatted/unformatted IF Repeat ! next copy if (delete.and.sl) then ! if deletion flag set.. open(IN,file=file,status="old") ! ...delete the input file close(IN,status="delete") endif return ! from spool end * * - endlin: called at the end of a line, returns TRUE if at a new page * logical function endlin(c,who,cc,pn,ln,wi,lp) implicit none integer*1 c,co,CR integer wi,lp,pn,ln,cc,who,i integer IN,OUT ; parameter(IN=1,OUT=2) integer RL,USER ; parameter(RL=1,USER=0) logical NEWPAG ;parameter (NEWPAG=.true.) endlin = .not.NEWPAG ! default endlin to not a new page CR = 13 ! integer*4 to integer*1 co = 0 ! nothing in look-a-head buffer if (who=USER) then ! called by user? if (c=10) write(OUT) CR ! yes, if necessary LF to CRLF write(OUT) c elseif (c=13) then write(OUT) c ! put out the CR read(IN,iostat=i) c ! look ahead, part of a pair (CRLF)? if (i<>0) return ! no, end of file --> return if (c=10) then write(OUT) c ! yes, write it out else co = c ! no, save char in look-a-head buffer endif else write(OUT) c ! LF generated by unit 6 ouput endif cc = 0 ! reset line character counter ln = ln + 1 ! count the line if (ln>=lp) then ! full page? ln = 0 ! - reset line counter endlin = NEWPAG ! - flag new page elseif(co<>0) then write(OUT) co ! no - flush any the look ahead endif c = co ! return any saved character end * * - outhd: format the header for the current page and write it out * subroutine outhd(pn,file) implicit none character hbuf*80,file*20 integer mm,dd,yy integer*1 CR,LF integer OUT ; parameter(OUT=2) CR = 13 ; LF = 10 call date(mm,dd,yy) write(hbuf,1) file,mm,dd,yy,pn ! create the header write(OUT) CR,LF,trim(hbuf),CR,LF,CR,LF ! out the header pn = pn + 1 ! we're on next page 1 format('File ',a20,5x, + 'Printed on ',i2.2,2('/',i2.2),6x, + 'Page ',i4) end