!Modified 7/ 5/82 11.00
!**********************************************************************!
!**********************************************************************!
! !
! !
! This Module is designed to handle List-Directed Output !
! !
! for FORTRAN77 Programs !
! !
! on ICL PERQ Machines !
! !
! !
!**********************************************************************!
!**********************************************************************!
!-----Module History-----!
! !
! !
! FIO7701Q --------first version (numerous restrictions)
! (derived from FIO7731N)
!
! FIO7731N ---conversion to IMP80
!
! FIO7730N -----includes reps to B70 release
!Conditional Compilation Variables:
!
%CONSTINTEGER EMAS= 0
%CONSTINTEGER PERQ= 1
!
{********************} %CONSTINTEGER SYSTEM=PERQ {*********************}
!
!
%CONSTINTEGER CURRENT= 0
%CONSTINTEGER FUTURE= 1
!
{********************} %CONSTINTEGER RELEASE=CURRENT {*****************}
%CONSTHALFINTEGER FALSE= 0
%CONSTHALFINTEGER TRUE = 1
!
!***********************************************************************
!
! ENVIRONMENTAL VARIABLES
!
!***********************************************************************
!
%CONSTHALFINTEGER OUTPUT LEN= 84; !The record length of the diagnostic
! stream. Should the characteristics
! of the stream change then only this
! variable need be altered.
!***********************************************************************
!
! RECORD FORMATS
!
!***********************************************************************
!
%RECORDFORMAT FILE DEFINITION TABLE ( %C
%C
%INTEGER LINK , BACK {LINK},
%INTEGER DSNUM ,
%BYTEINTEGER STATUS , CUR STATE ,
%BYTEINTEGER VALID ACTION , Spare1 ,
%BYTEINTEGER MODE OF USE , ACCESS TYPE ,
%HALFINTEGER EXISTENCE , ACCESS ROUTE ,
%HALFINTEGER RECORD TYPE ,
%HALFINTEGER RECORD LEN , {of the current record}
%HALFINTEGER RECSIZE ,
%HALFINTEGER MINREC ,
%HALFINTEGER MAXREC ,
%INTEGER DA RECNUM ,
%INTEGER LINES IN ,
%INTEGER LINES OUT ,
%HALFINTEGER FILE ID ,
%HALFINTEGER SCRATCH ID ,
%HALFINTEGER LAST BLK , MAX BLK ,
%HALFINTEGER BLK , {the current one}
%HALFINTEGER POS , {and position within it}
%HALFINTEGER REC POS ,
%HALFINTEGER UFD ,
%HALFINTEGER F77BLANK ,
%HALFINTEGER F77RECL ,
%HALFINTEGER FLAGS ,
%INTEGER CUR POS {in bytes from start of file},
%INTEGER CUR LEN {In bytes from start of file},
%INTEGER ID ADDR )
!
! %C
Values That May Be Set in a File Definition Table:
!
!
%CONSTINTEGER F77 DEFINED = X'48'; ! Bit Values
%CONSTINTEGER FORMATTED BIT = X'01'; ! of the
%CONSTINTEGER FREEFMT BIT = X'02'; ! F77UFD field
%CONSTINTEGER FMTED FILE BITS= X'49'; !and byte values
%CONSTINTEGER FREEFMT FILE BITS= X'4B'; ! of the field
%RECORDFORMAT TRANSFER CONTROL TABLE ( %C
%C
%INTEGER DSNUM ,
%INTEGER REC NUMBER ,
%HALFINTEGER COROUTINE INDEX ,
%HALFINTEGER IOSTAT VALUE ,
%INTEGER IOSTAT ADDRESS {used only by user code} )
!
!***********************************************************************
!
! GLOBAL PROCEDURE SPECIFICATIONS
!
!***********************************************************************
!
%HALFINTEGERFNSPEC F77 IOD %C
(%RECORD (Transfer Control Table) %NAME TCT ,
%HALFINTEGER KEY , FORM ,
%HALFINTEGER IO MODE, FLAGS, MARKERS ,
%HALFINTEGERFN IO ITEM %C
(%HALFINTEGER KEY ,
%INTEGER LEN TYPE ADR,
%INTEGERNAME ADDRESS) )
%EXTERNALHALFINTEGERFN F77 IOD ( %C
{! }%C
{! }%C
{! }%C
{! }%C
{! THIS PROCEDURE IS THE INTERFACE BETWEEN A LIST-DIRECTED OUTPUT }%C
{! }%C
{! STATEMENT IN THE USER PROGRAM AND THE UNDERLYING }%C
{! }%C
{! SYSTEM-DEPENDENT PROCEDURES OF THE FORTRAN77 }%C
{! }%C
{! RUN-TIME SYSTEM. }%C
{! }%C
{! }%C
{! At Exit: RESULT= 1 if the END= label is to be used }%C
{! RESULT= 2 if the ERR= label is to be used }%C
{! RESULT= 0 otherwise }%C
{! }%C
{!-Parameters: }%C
{! ! }%C
{parm1} %RECORD (Transfer Control Table) %NAME TCT ,
{parm2} %HALFINTEGER KEY ,
{parm3} %HALFINTEGER FORM ,
{parm4} %HALFINTEGER IO MODE ,
{parm5} %HALFINTEGER FLAGS ,
{parm6} %HALFINTEGER SPECIFIER FLAGS ,
%C
{parm7} %HALFINTEGERFN IO ITEM (%HALFINTEGER KEY ,
%INTEGER SIZE TYPE ADR,
%INTEGERNAME ADDRESS ) )
!The Parameters have the following meanings:
!
! %C
DSNUM the FORTRAN channel number,
IO MODE classifies the I/O statement
! X'5x' if Internal File I/O,
X'6x' if Sequential File I/O,
X'7x' if Direct-Access File I/O {where x=1 if input }
{ or x=2 if output}
!also X'04' if Rewind and X'20' if Open,
X'08' if Backspace X'40' if Close,
X'10' if Endfile X'80' if Inquire,
!%C
FORM classifies the processing required,
as follows:
%CONSTINTEGERC
UNFORMATTED IO = 0 ,
FORMAT IO = 1 ,
FORMAT IN ARRAY= 2 ,
LIST DIRECTED IO= 3 ,
REWIND = 7 ,
BACKSPACE = 7 ,
ENDFILE = 7 ,
OPEN CLOSE AND INQUIRE= 8
!
!***********************************************************************
!
! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES
!
!***********************************************************************
!
%EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT)
%EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C
TRACEBACK)
!
!***********************************************************************
!
! SPECIFICATIONS FOR EXTERNAL I/O HANDLING ROUTINES
!
!***********************************************************************
!
%EXTERNALHALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM ,
%HALFINTEGER ACTION, FILETYPE,
%INTEGERNAME FD TABLE ADDRESS)
%EXTERNALHALFINTEGERFNSPEC OUT CHAR (%HALFINTEGER CHAR, AT)
%EXTERNALHALFINTEGERFNSPEC OUT FILL (%HALFINTEGER LENGTH, AT, WITH)
%EXTERNALHALFINTEGERFNSPEC OUT FIELD (%HALFINTEGER LENGTH,
%INTEGER FROM ADR,
%INTEGER FROM INC,
%HALFINTEGER BUFF PTR)
%EXTERNALHALFINTEGERFNSPEC OUT REC
!
!***********************************************************************
!
! SPECIFICATIONS FOR MAIN UTILITY ROUTINES
!
!***********************************************************************
!
%ROUTINESPEC GET EXTRA ERROR INFO
%HALFINTEGERFNSPEC INITIALISE EXTERNAL IO OPERATION
%HALFINTEGERFNSPEC NEW RECORD
%HALFINTEGERFNSPEC OUT FORMAT
%HALFINTEGERFNSPEC OUT ITEM
%INTEGERFNSPEC ARRAY ADDRESS ( %INTEGER DV ADDR ,
%HALFINTEGER DATA TYPE )
%HALFINTEGERFNSPEC UNASSIGNED CHECK (%INTEGER ADR, %HALFINTEGER LEN)
%HALFINTEGERFNSPEC BYTE AT (%INTEGER ADR, %HALFINTEGER INC)
%ROUTINESPEC PROPAGATE (%INTEGER LENGTH,
%INTEGER BASE, %HALFINTEGER AT INC, WITH)
%ROUTINESPEC COPY (%INTEGER LENGTH,
%INTEGER FROM, %HALFINTEGER FROM DISP ,
%INTEGER TO , %HALFINTEGER TO DISP )
!***********************************************************************
!
! ERROR MESSAGES
!
!***********************************************************************
!
%CONSTHALFINTEGER UNASSIGNED VARIABLE = 401
%CONSTHALFINTEGER RECORD TOO SMALL = 154
%CONSTHALFINTEGER CONNECTION NOT FORMATTED = 194
%CONSTHALFINTEGER ACCESS CONFLICT = 119
!***********************************************************************
!
! CONSTANTS
!
!***********************************************************************
!
%CONSTHALFINTEGER DOT = '.'
%CONSTHALFINTEGER PLUS = '+'
%CONSTHALFINTEGER TRUE SIGN = 'T'
%CONSTHALFINTEGER FALSE SIGN = 'F'
%CONSTHALFINTEGER BLANK = ' '
%CONSTHALFINTEGER QUOTE = ''''
%CONSTHALFINTEGER MINUS = '-'
%CONSTHALFINTEGER NOUGHT= '0'
!*
!*
!*
%CONSTHALFINTEGER NULL = 0
%CONSTHALFINTEGER NONE = 0
%CONSTHALFINTEGER NOT SET = 0, SET = 1
%CONSTHALFINTEGER NOT USED= 0
%CONSTHALFINTEGER NOT REQD= 0, REQD= 1
%CONSTHALFINTEGER NIL = 0
%CONSTHALFINTEGER OFF = 0, ON = 1
%CONSTINTEGER UNDEFINED =-9
!Values taken by 'boolean' variables
! (ie. Integers used as flags)
%IF SYSTEM\=PERQ %THENSTART
!
%CONSTREALARRAY POWERS OF TEN (-37:38) %C
= R'2222073B' ,
R'23154485' ,
R'23D4AD2E' ,
R'2484EC3D' ,
R'255313A6' ,
R'2633EC48' ,
R'272073AD' ,
R'2814484C' ,
R'28CAD2F8' ,
R'297EC3DB' ,
R'2A4F3A69' ,
R'2B318482' ,
R'2C1EF2D1' ,
R'2D1357C3' ,
R'2DC16D9A' ,
R'2E78E480' ,
R'2F4B8ED0' ,
R'302F3942' ,
R'311D83C9' ,
R'3212725E' ,
R'32B877AA' ,
R'33734ACA' ,
R'34480EBE' ,
R'352D0937' ,
R'361C25C2' ,
R'3711979A' ,
R'37AFEBFF' ,
R'386DF37F' ,
R'3944B830' ,
R'3A2AF31E' ,
R'3B1AD7F3' ,
R'3C10C6F8' ,
R'3CA7C5AC' ,
R'3D68DB8C' ,
R'3E418937' ,
R'3F28F5C2' ,
R'4019999A' ,
R'41100000' ,
R'41A00000' ,
R'42640000' ,
R'433E8000' ,
R'44271000' ,
R'45186A00' ,
R'45F42400' ,
R'46989680' ,
R'475F5E10' ,
R'483B9ACA' ,
R'492540BE' ,
R'4A174876' ,
R'4AE8D4A5' ,
R'4B9184E7' ,
R'4C5AF310' ,
R'4D38D7EA' ,
R'4E2386F2' ,
R'4F163458' ,
R'4FDE0B6B' ,
R'508AC723' ,
R'5156BC76' ,
R'523635CA' ,
R'5321E19E' ,
R'54152D02' ,
R'54D3C21C' ,
R'55845951' ,
R'5652B7D3' ,
R'5733B2E4' ,
R'58204FCE' ,
R'591431E0' ,
R'59C9F2CA' ,
R'5A7E37BE' ,
R'5B4EE2D7' ,
R'5C314DC6' ,
R'5D1ED09C' ,
R'5E134261' ,
R'5EC097CE' ,
R'5F785EE1' ,
R'604B3B4D'
!
! Other Floating Point Constants
!
%CONSTREAL POINT ONE = R'4019999A'
%CONSTREAL TEN TO THE 38= R'604B3B4D'
%CONSTREAL TEN TO THE %C
MINUS 36= R'23154485'
%FINISH; !if not PERQ
%IF SYSTEM=PERQ %THENSTART
!
!
%CONSTINTEGERARRAY PERQ POWERS OF TEN (-37:38) %C
= X'02081CEA' , X'03AA2425' , X'0554AD2E' ,
X'0704EC3D' , X'08A6274C' , X'0A4FB11F' ,
X'0C01CEB3' , X'0DA24260' , X'0F4AD2F8' ,
{This Table } X'10FD87B6' , X'129E74D2' , X'14461206' ,
{ is } X'15F79688' , X'179ABE15' , X'19416D9A' ,
{ an } X'1AF1C901' , X'1C971DA0' , X'1E3CE508' ,
{ accurate } X'1FEC1E4A' , X'219392EF' , X'233877AA' ,
{ representation} X'24E69595' , X'26901D7D' , X'283424DC' ,
{ of } X'29E12E13' , X'2B8CBCCC' , X'2D2FEBFF' ,
{ the } X'2EDBE6FF' , X'3089705F' , X'322BCC77' ,
{ powers of ten } X'33D6BF95' , X'358637BD' , X'3727C5AC' ,
{ in } X'38D1B717' , X'3A83126F' , X'3C23D70A' ,
{ the } X'3DCCCCCD' , X'3F800000' , X'41200000' ,
{ range } X'42C80000' , X'447A0000' , X'461C4000' ,
{ 10**(-37) } X'47C35000' , X'49742400' , X'4B189680' ,
{ to 10** 38 } X'4CBEBC20' , X'4E6E6B28' , X'501502F9' ,
{ expressed } X'51BA43B7' , X'5368D4A5' , X'551184E7' ,
{ in the } X'56B5E621' , X'58635FA9' , X'5A0E1BCA' ,
{ form of } X'5BB1A2BC' , X'5D5E0B6B' , X'5F0AC723' ,
{ floating } X'60AD78EC' , X'6258D727' , X'64078678' ,
{ point } X'65A96816' , X'6753C21C' , X'69045951' ,
{ numbers } X'6AA56FA6' , X'6C4ECB8F' , X'6E013F39' ,
{ which conform } X'6FA18F08' , X'7149F2CA' , X'72FC6F7C' ,
{ to the } X'749DC5AE' , X'76453719' , X'77F684DF' ,
{ IEEE draft } X'799A130C' , X'7B4097CE' , X'7CF0BDC2' ,
{ standard } X'7E967699'
!
! Other Floating Point Constants
!
%CONSTINTEGER PERQ POINT ONE = X'3DCCCCCD'
%CONSTINTEGER PERQ TEN TO THE 38= X'7E967699'
%CONSTINTEGER PERQ TEN TO THE %C
MINUS 36= X'03AA2425'
%OWNREALARRAYNAME POWERS OF TEN; !mapped onto PERQ POWERS OF TEN
!
%OWNREALNAME POINT ONE ; !mapped onto PERQ POINT ONE
%OWNREALNAME TEN TO THE 38; !mapped onto PERQ TEN TO THE 38
%OWNREALNAME TEN TO THE %C
MINUS 36; !mapped onto PERQ TEN TO THE MINUS 36
!
!
%REALARRAYFORMAT ARRAY FORM (-37:38)
!
%FINISH; !if PERQ
!***********************************************************************
!
! INTERNAL WORK-AREAS
!
!***********************************************************************
!
{---TEMPORARILY----->} %BYTEINTEGERARRAY IO FIELD (0:OUTPUT LEN)
!
%INTEGER TEXT ADR; !address of IO FIELD
!***********************************************************************
!
! GLOBAL VARIABLES
!
!***********************************************************************
!
!Initialisation Criterion on PERQ is determined via:
!
%OWNHALFINTEGER F77IO FLAG= FALSE
{= TRUE if F77 IO is initialised}
%OWNHALFINTEGER RUN MODE; ! =-1 => Running in JOBBER mode
! = 0 => Running in STAND-ALONE mode but
! using Subsystem Diagnostics
! = 1 => Running in OPEH mode
{Set At Initialisation}
!
! Variables defining the compilation options specified
!
%HALFINTEGER CHECK
%HALFINTEGER RELAX ANSI
!
!the operating values of these variables is governed
! by the values within the Transfer Control Table
!
! Variables Controlling Access to the File Definition Table
!
%OWNRECORD (File Definition Table) %NAME F
!
! Buffer Variables
!
%HALFINTEGER BLEN {maximum length of a logical record } ,
BPTR {current position within a logical record}
!
%HALFINTEGER BUFF LENGTH ;!%C
work variable
%HALFINTEGER F PTR; !current position within IO FIELD
!
! Declarations of Variables Extracted from the Parameter List
!
%INTEGER DSNUM
!
! Variables Controlling Access to or from a File
!
%HALFINTEGER UFD; !copy of F77UFD field of the current I/O channel FD Table
!
!its bits are set as follows:
!
! F77 DEFINED= X'48' => details are F77 defined
! FORMATTED BIT= X'01' => connection/file is formatted
! FREEFMT BIT= X'02' => connection/file has
!list-directed records
!
! Variables associated with Error Reporting
!
%HALFINTEGER ERROR ; !the value to be assigned to the IOSTAT scalar
%HALFINTEGER FAULT ; !the error that has been detected
!
! Variables Defining the Current I/O Item
!
%INTEGER NUM DATA ITEMS; !set to number of elements in an array
!set to 2 for COMPLEX arrays
!set to 1 for other scalars
%INTEGER DATA AD ; !address of I/O item
%INTEGER DATA INC ; !set 0 if I/O item is on a word boundary
!set 1 if I/O item is on a byte boundary
%HALFINTEGER DATA BYTES ; !length of I/O item in bytes
%HALFINTEGER DATA WORDS ; !length of I/O item in words
!HALFINTEGER DATA SIZE ; !code for length if I/O item,
as follows: %C
0 for Character variables,
3 for Byte ,
4 for Word ,
5 for Double Word
%HALFINTEGER DATA TYPE
!DATA TYPE defines the FORTRAN type %C
as follows:
%constinteger AN INTEGER = 1 , A REAL = 2 ,
A COMPLEX = 3 , A LOGICAL= 4 ,
A CHARACTER= 5
%HALFINTEGER LAST DATA TYPE ;!%C
DATA TYPE of the previous I/O item
!
! Variables for processing the I/O list
!
%INTEGER ITEM AD ; !address of the next I/O item
%HALFINTEGER ITEM TYPE ;!%C
ITEM TYPE is the result from %C
the coroutine which is set: -1 for end of list
! 0 for a scalar
! 1 for an array
! 2 for a Character scalar
!
! Variables Defining the Current Format
!
%INTEGER WIDTH
%HALFINTEGER DECIMALS
%IF F77IO FLAG= FALSE %THENSTART;
! !
! !
! Initialise FIO Itself !
! !
! !
RUN MODE={COMREG (42)} 0
!
! Initialise Real Constants names
!
POWERS OF TEN== ARRAY(ADDR(PERQ POWERS OF TEN(-37)),ARRAY FORM)
!!
POINT ONE == POWERS OF TEN(- 1)
TEN TO THE 38== POWERS OF TEN( 38)
TEN TO THE %C
MINUS 36== POWERS OF TEN(-36)
F77IO FLAG= TRUE; ! (for EMAS or PERQ)
!
!----->END OF INTERNAL INITIALISATION
!
%FINISH
!Initialise TEXT ADR:
!
TEXT ADR= ADDR(IO FIELD(0))
!
! Analyse The Parameters
!
RELAX ANSI = FLAGS & 8
CHECK = FLAGS & 4
!
DSNUM = TCT_DSNUM
!
! Request a New File Operation
!
FAULT=INITIALISE EXTERNAL IO OPERATION
-> BASIC IO ERROR %IF FAULT\=NONE
!
! Extract the FORM Property of the Connection
!
UFD= F_UFD
%IF UFD= NOT SET %THENSTART
!
! Set the FORM Property of the File
!
UFD= X'49'
F_UFD= UFD
%FINISH
!And now Validate the FORM Property:
!
%IF (UFD&FMTEDFILE BITS)\=X'49' %THENSTART
!
! Report a FORM Conflict
!
FAULT=CONNECTION NOT FORMATTED
-> BASIC IO ERROR
%FINISH
%IF SYSTEM\=EMAS %THENSTART
!
!
!
%IF F_ACCESS TYPE\= 0 %THEN FAULT=ACCESS CONFLICT %C
%AND -> BASIC IO ERROR
%FINISH; !if not EMAS
!
!
! PREPARE FOR PROCESSING OUTPUT
!
!
%IF F_ACCESS ROUTE= 2 {a DTA file} %THENSTART
!
! Determine Record Length for a Data File
!
%IF F_RECORD TYPE= 2 %THEN BUFF LENGTH= 508 %C
%ELSE BUFF LENGTH=F_MAXREC
!
%FINISHELSE BUFF LENGTH= OUTPUT LEN;!%C
for the console %C
or a Text File
!
! INITIALISE THE BUFFER POINTERS
!
BPTR = 0 ; !-> relative start of logical record
BLEN = BUFF LENGTH ; !-> maximum length of logical record
!
!***********************************************************************
!
! PERFORM LIST-DIRECTED OUTPUT
!
!**********************************************************************
!
%IF TCT_COROUTINE INDEX\=NONE %THENSTART ; !There is an I/O list
!
! INITIALISE VARIABLES
!
LAST DATA TYPE= NONE
IO FIELD(0) = BLANK
F PTR = 1
!
! GET THE NEXT I/O ITEM
!
CALL COROUTINE: ITEM TYPE=IO ITEM(KEY,ADDR(DATA WORDS),ITEM AD)
%IF ITEM TYPE<0 %THEN -> RETURN
DATA TYPE=DATA TYPE & 15
%IF ITEM TYPE= 0 %THENSTART
!
! I/O Item is a Non-Character Scalar
!
DATA BYTES=DATA WORDS + DATA WORDS
DATA AD =ITEM AD
NUM DATA ITEMS=1; %FINISHELSESTART
%IF ITEM TYPE= 1 %THENSTART
!
! I/O Item is an Array
!
DATA AD= ARRAY ADDRESS(ITEM AD,DATA TYPE)
%FINISHELSESTART
{%IF ITEM TYPE= 2 %THENSTART}
!
! I/O Item is a Character Scalar
!
NUM DATA ITEMS= 1
DATA AD = INTEGER(ITEM AD )
DATA INC = HALFINTEGER(ITEM AD+2)
DATA BYTES= DATA WORDS
%FINISH
%FINISH
!
! FORMAT AND OUTPUT THE NEXT I/O ITEM
!
FAULT = OUT ITEM
%IF FAULT\=NONE %THEN -> IO ERROR {for some error }
-> CALL COROUTINE {for the next I/O item}
RETURN:
!
! TIDY UP
!
%IF UFD\=FREEFMTFILE BITS %THENSTART
!
! Mark the connection/file as having Free Format Records
!
UFD= FREEFMTFILE BITS
F_UFD= UFD %AND F_FLAGS= 1
!to ask CLOSE to update the file header if DTA access
%FINISH
%FINISH
!
! CLOSE the Last Record
!
FAULT=NEW RECORD
%IF FAULT>0 %THEN -> IO ERROR
EXIT:
!***********************************************************************
!
! RETURN (after successful completion)
!
!***********************************************************************
!
!Set the IOSTAT field in the Transfer Control Table
!
TCT_IOSTAT VALUE= 0
!
%RESULT= 0
!***********************************************************************
!
! REPORT AN ERROR
!
!***********************************************************************
!
BASIC IO ERROR: BPTR= UNDEFINED
!=> an error has been detected
!and no I/O buffer has been acquired
IO ERROR:
%IF SPECIFIER FLAGS\=NONE %THENSTART
!
!
! Examine the I/O error specifiers given
!
!
ERROR= FAULT
ERROR=-ERROR %IF ERROR< 0 {check for FORMATCD fault}
!
TCT_IOSTAT VALUE= ERROR {first set the IOSTAT value}
!
! Check Label Exits
!
%RESULT=2 %IF SPECIFIER FLAGS&2\= 0
!
%RESULT=0 %IF SPECIFIER FLAGS>= 4
!
!Continue with ordinary error reporting
!if no label exit was taken and
%FINISH; !if no IOSTAT specifier was given
%IF FAULT>0 %THENSTART
!
!
! Report a fault detected by FIO
!
!
{SELECT OUTPUT (107)}
SSMESS (FAULT) {print the error message }
GET EXTRA ERROR INFO { and the I/O buffer}
!
%FINISH
{give a %MONITOR and %STOP} F77IOERR ( 1 {stack frame to unwind})
%ROUTINE GET EXTRA ERROR INFO
!
!
!
!
! This Routine Displays the Current I/O Buffer (if it
!
! is relevant) after an error message has
!
! been printed.
!
!
!
%IF RELEASE=FUTURE %THENSTART
!
!
%BYTEINTEGERARRAY MONITOR BUFFER (0:OUTPUT LEN) ;!%C
MONITOR BUFFER is used %C
to hold a snapshot of the current %C
I/O buffer when reporting an error
%INTEGER BUFF DISP
%INTEGER LENGTH
%INTEGER I
%RETURN {-----FOR NOW}
!
! SEE IF A PRINT OF THE I/O BUFFER WOULD BE HELPFUL
!
%IF BPTR>=0 %THENSTART
!Helpful if the buffer isn't
! empty and the contents are
! supposed to be characters
BUFF DISP= 0 {BINC}
BLEN = BPTR - BUFF DISP
LENGTH = BLEN
BPTR = BPTR - BUFF DISP
!
! SEE IF BUFFER LENGTH IS GREATER THAN LINE-PRINTER PAPER WIDTH
!
%IF LENGTH>OUTPUT LEN %THENSTART ; !Try and make sure that we
! print the part of the
! buffer that was being
! processed when the
! error occurred
LENGTH=OUTPUT LEN
%IF BPTR>=LENGTH %THENSTART
I= BPTR + (OUTPUT LEN//2)
%IF I<BLEN %THEN BLEN= I
BUFF DISP= BUFF DISP + (BLEN - OUTPUT LEN)
%FINISH
%FINISH
!
! SET UP THE CURRENT I/O BUFFER FOR PRINTING
!
MONITOR BUFFER(0)=LENGTH
COPY(LENGTH,TEXT ADR,BUFF DISP,ADDR(MONITOR BUFFER(0)),1)
!
! NOW PRINT THE BUFFER
!
PRINT STRING ("Current I/O Buffer:
".STRING(ADDR(MONITOR BUFFER(0)))); NEWLINE
SPACES (BPTR)
PRINT SYMBOL ('!')
NEWLINES (2)
%FINISH
%FINISH; !the future release
!
%END; !of GET EXTRA ERROR INFO
!***********************************************************************
!
! I/O PERFORMING PROCEDURES
!
!***********************************************************************
!
%HALFINTEGERFN INITIALISE EXTERNAL IO OPERATION
!
!
!
!
! A PROCEDURE TO ESTABLISH A CONNECTION BETWEEN
!
! THE UNIT SPECIFIER AND THE CORRESPONDING
!
! INTERNAL OR EXTERNAL FILE
!
!
!
%HALFINTEGER FAULT ; !reported from NEW FILE OP
%INTEGER AFD
!
!
! Initialise for External File Input/Output
!
!
FAULT = NEW FILE OP (DSNUM,2,3,AFD)
%IF FAULT\=NONE %THENRESULT=FAULT
!
F==RECORD(AFD); !map address of file definition table
! onto the corresponding record fmt
%RESULT= 0
%END; !of INITIALISE EXTERNAL IO OPERATION
%HALFINTEGERFN NEW RECORD
!
!
!
!
! A PROCEDURE TO TERMINATE THE CURRENT OUTPUT RECORD
!
! AND TO PREPARE FOR THE NEXT ONE.
!
!
!
%HALFINTEGER MINREC ; !the minimum length required of an output record
%HALFINTEGER FAULT ; !the result variable
!
!
! Write a record to an External File
!
!
%IF BPTR=NOT SET %THENSTART
!
! Put a Blank in the Buffer
!
FAULT= OUT CHAR (BLANK,0)
%IF FAULT> 0 %THENRESULT=FAULT
BPTR= 1
%FINISH
MINREC=F_MINREC
%IF MINREC>BPTR %THENSTART
!
FAULT= OUT FILL (MINREC-BPTR,BPTR, BLANK{s})
%RESULT=FAULT %UNLESS FAULT=NONE
%FINISH
!
! NOW WRITE THE RECORD OUT
!
FAULT = OUTREC
-> REPORT FAULT %IF FAULT\= NONE
!
! Re-set the buffer variables
!
BPTR= 0
!
%RESULT= 0
!REPORT FAULT:
REPORT FAULT:
!REPORT FAULT:
BPTR=UNDEFINED ; %RESULT=FAULT
{Inhibit error handling}
{ from displaying a }
{ non-existant buffer}
%END; !of NEW RECORD
%INTEGERFN ARRAY ADDRESS (%INTEGER DATA AD , %HALFINTEGER DATA TYPE)
!
!
!
!
! THIS PROCEDURE DETERMINES THE ADDRESS OF THE FIRST ACTUAL
!
! ARRAY ELEMENT AND THE NUMBER OF ARRAY ELEMENTS
!
! USING THE DOPE VECTOR ADDRESS (Data Ad) AND THE
!
! VARIABLE TYPE (Data Type).
!
!
!The Form of a Dope Vector is as follows:
! %C
Integer: Address of 1st actual element (word boundary) %C
Halfinteger: Increment to start of 1st actual element ---AND %C
Halfinteger: Element size if type= CHARACTER Array %C
Integer: Number of Array elements
!
!
%INTEGER RESULT {returned is address of 1st element}
RESULT= INTEGER(DATA AD)
!
!
%IF DATA TYPE=A CHARACTER %THENSTART
!
! Extract CHARACTER Dependent Information
!
DATA INC = HALFINTEGER(DATA AD + 2)
DATA BYTES= HALFINTEGER(DATA AD + 3)
DATA WORDS= DATA BYTES
DATA AD = DATA AD + 4
%FINISHELSE %C
DATA BYTES= DATA WORDS + DATA WORDS
NUM DATA ITEMS= INTEGER(DATA AD + 2)
%RESULT= RESULT
!
%END; !of ARRAY ADDRESS
%HALFINTEGERFN OUT ITEM
!
!
!
!
! A UTILITY PROCEDURE TO OUTPUT A SCALAR OR AN ARRAY ELEMENT OR
!
! A WHOLE ARRAY ACCORDING TO THE VARIABLE TYPE, AND
!
! ACCORDING TO THE STANDARDS OF LIST-DIRECTED OUTPUT.
!
!
!
%HALFINTEGERFNSPEC CHECK LENGTH (%HALFINTEGER BUFFER SPACE REQD)
%HALFINTEGERFNSPEC OUT COMPLEX
%HALFINTEGERFNSPEC OUT CHARACTER
!
!
%CONSTHALFINTEGERARRAY INTEGER WIDTHS(1:3)= 6, 11, 20
%CONSTHALFINTEGERARRAY REAL WIDTHS(1:4)= 14, 22, 0, 37
%CONSTHALFINTEGERARRAY DECS PER SIZE(1:4)= 7, 15, 0, 30
!
!
%HALFINTEGER LEN ; !the field width reserved in the buffer for the value
%HALFINTEGER SIZE ; !set to DATA BYTES/4 for Reals, Integers, and Complex
!ie. 0=> bytes=2
! 1=> bytes=4
! 2=> bytes=8
! 4=> bytes=16
%HALFINTEGER FAULT
%HALFINTEGER DELIM; !set to TRUE if a value separator is to be output
! before formatting a value
!set to FALSE otherwise
!
! DETERMINE HOW TO OUTPUT A NON-NUMERIC VALUE
!
%IF DATA TYPE= 5 %THEN %C
%RESULT= OUT CHARACTER
{determine}
{DATA SIZE} SIZE=DATA BYTES >> DATA TYPE
!
! DETERMINE HOW TO OUTPUT A 'STANDARD' VALUE
!
%IF DATA TYPE= A LOGICAL %THEN LEN =1 %ELSESTART
%IF DATA TYPE=AN INTEGER %THEN LEN =INTEGER WIDTHS (SIZE) %C
%ELSESTART; LEN = REAL WIDTHS (SIZE)
DECIMALS= DECS PER SIZE (SIZE)
%FINISH; %FINISH
%CYCLE; !through each element of the current I/O item
! and output each in turn
!
%IF LAST DATA TYPE=A CHARACTER %OR BPTR=0 %THEN DELIM= FALSE %C
%ELSE DELIM= TRUE
%IF DATA TYPE=A COMPLEX %THEN FAULT= OUT COMPLEX %ELSESTART
!
{!otherwise check that } WIDTH=LEN
{! there is buffer space} FAULT= CHECK LENGTH (WIDTH+DELIM)
%IF FAULT> 0 %THEN -> RETURN
!
IO FIELD(0)=BLANK %AND FPTR=1 %IF BPTR\= 0 %AND DELIM=TRUE
!
! Output an Integer, Real, or Logical Value
!
FAULT=OUT FORMAT; %FINISH
%IF FAULT>0 %THEN -> RETURN
{output the field} FAULT= OUT FIELD (F PTR,TEXT ADR,NIL,BPTR)
!
%IF FAULT> 0 %THENRESULT=FAULT
!
BPTR= BPTR + FPTR
FPTR= 0
%EXIT %IF NUM DATA ITEMS<=1
!
NUM DATA ITEMS =NUM DATA ITEMS-1 ; !select the next
DATA AD = DATA AD + DATA WORDS; ! element of
! an array
%REPEAT
!
!
RETURN: %RESULT=FAULT
%HALFINTEGERFN OUT CHARACTER
!
!
!
!
! A ROUTINE TO OUTPUT THE VALUE (or values) OF
!
! A CHARACTER VARIABLE FOR FREE FORMAT
!
!
!NOTE: CHARACTER variables are to be output without
! preceding or following value separators
!
!
!
%HALFINTEGER BUFFER LENGTH
%INTEGER ITEM PTR
%INTEGER WIDTH
%HALFINTEGER FAULT
ITEM PTR = DATA INC {note displacement for start of 1st variable}
%CYCLE; !OUTPUT A CHARACTER VARIABLE!
! FOR FREE FORMAT !
! !
! !
%IF CHECK\=FALSE %AND BYTE AT(DATA AD,DATA INC)= X'80' %C
%THEN %RESULT = UNASSIGNED VARIABLE
!
WIDTH=DATA BYTES
!Check if we are at the start of a record
!
%IF BPTR=0 %THENSTART
!
! Insert a Blank for Carriage Control (as per ANSI)
!
NEW BUFFER: FAULT= OUTCHAR (BLANK, 0)
%IF FAULT> 0 %THEN -> FAULT REPORTED
BPTR= 1
%FINISH
!Check if the variable overflows the buffer!
! !
BUFFER LENGTH= BLEN - BPTR
%IF BUFFER LENGTH< WIDTH %THENSTART
!
! Fill (the rest of) the Buffer
!
FAULT= OUT FIELD (BUFFER LENGTH,DATA AD,ITEM PTR,BPTR)
%IF FAULT> 0 %THEN -> FAULT REPORTED
!
ITEM PTR= ITEM PTR + BUFFER LENGTH
BPTR= BLEN
WIDTH= WIDTH - BUFFER LENGTH
{write the } FAULT= NEW RECORD
{ current record} -> FAULT REPORTED %UNLESS FAULT=NONE
-> NEW BUFFER
!
%FINISH; !if the variable is longer than the current buffer
!
! Now Move (the rest of) the Variable into the Buffer
!
FAULT= OUT FIELD (WIDTH,DATA AD,ITEM PTR,BPTR)
%IF FAULT> 0 %THEN -> FAULT REPORTED
!
ITEM PTR=ITEM PTR + WIDTH
BPTR= BPTR + WIDTH
{Now check if more variables} %EXIT %IF NUM DATA ITEMS<= 1
{repeat if more} NUM DATA ITEMS=NUM DATA ITEMS - 1
%REPEAT
!
! RETURN WHEN NO MORE VARIABLES
!
%RESULT=0
!
! RETURN WITH AN ERROR
!
FAULT REPORTED:
!
%RESULT= FAULT
!
!
!
%END; !of OUT CHARACTER
%HALFINTEGERFN OUT COMPLEX
!
!
!
!
! A LOCAL PROCEDURE WHICH OUTPUTS A COMPLEX VALUE IN FREE FORMAT
!
!
! ANSI 77 requires that complex values which are too long for an
! entire record, are split across a record boundary between the
! comma and the following imaginary part. This procedure takes
! this requirement into consideration.
!
!
!
%HALFINTEGERFNSPEC WIDTH FOR (%INTEGER DATA AD)
!
%HALFINTEGER LENGTH; !field width reserved for the complex value
%HALFINTEGER WIDTH1; !field width reserved for the real part
%HALFINTEGER WIDTH2; !field width reserved for the imaginary part
%HALFINTEGER WIDTH3; !least width required for the complex value
%HALFINTEGER BUFF WIDTH ; !largest field available within the record size
!
!Note that, if possible, the field width used is twice the
! field required for a real value plus space for the
! opening and closing bracket and the separating comma
!
%HALFINTEGER SPACES REQD
!to right-justify the value within the determined field
%HALFINTEGER FAULT; !reported by CHECK LENGTH
DATA WORDS= DATA WORDS >> 1
!
! Determine the field widths for each complex part
!
WIDTH1= WIDTH FOR (DATA AD)
WIDTH2= WIDTH FOR (DATA AD + DATA WORDS)
WIDTH3= WIDTH1 + WIDTH2 + 3; !=Width(imaginary part) + '('
!+Width(real part) + ',' + ')'
LENGTH = LEN + LEN + 3
!
! Compare Constant and Record Sizes
!
BUFF WIDTH= BLEN-1; !allow for initial ' '
%IF BUFF WIDTH< LENGTH %THENSTART
%IF BUFF WIDTH<=WIDTH1 %THEN FAULT=RECORD TOO SMALL %AND -> RETURN
!
! Decide if an 'un-spaced' constant will fit wholely in the record
!
%IF BUFF WIDTH< WIDTH3 %THEN LENGTH=WIDTH1+1 %ELSE LENGTH=BUFF WIDTH
!Then no it wont Else yes it will
%FINISH
!
FAULT=CHECK LENGTH(LENGTH+DELIM); !get a new record
%IF FAULT>0 %THEN -> RETURN ; ! if we need one
IO FIELD(F PTR)=BLANK %AND F PTR=1 %IF DELIM=TRUE %AND BPTR\=0
!
!insert a separator between last and new value
%IF CHECK\=FALSE %THENSTART
!
! Perform Unassigned Checking
!
-> COMPLEX UNASSIGNED %C
{machine } %IF UNASSIGNED CHECK (DATA AD , DATA WORDS)=TRUE %C
{independent} %OR UNASSIGNED CHECK (DATA AD + DATA WORDS,
{ code} DATA WORDS)=TRUE
%FINISH
!performing unassigned checking
!
! Insert any leading spaces required to right-justify the value
!
SPACES REQD= LENGTH-WIDTH3
%WHILE SPACES REQD> 0 %CYCLE
!
IO FIELD(F PTR)= BLANK
F PTR = F PTR + 1
SPACES REQD= SPACES REQD-1
%REPEAT
!
! Now Output the Real Part
!
IO FIELD(F PTR)= '(' %AND F PTR=F PTR+1
WIDTH = WIDTH1
FAULT = OUT FORMAT; !--no fault expected
IO FIELD(F PTR)= ',' %AND F PTR=F PTR+1
!
! Then Output the Imaginary Part
!
%IF LENGTH=WIDTH1+1 %THENSTART ; !Check the imaginary
FAULT=CHECK LENGTH(WIDTH2+1); ! part will fit if
%IF FAULT>0 %THEN -> RETURN ; ! the value crosses
%FINISH ; ! a record boundary
DATA AD=DATA AD + DATA WORDS
WIDTH=WIDTH2
FAULT=OUT FORMAT
!(no fault expected)
!
! Finally Return
!
IO FIELD(FPTR)= ')'
FPTR = FPTR+1
RETURN: DATA AD = DATA AD - DATA WORDS
DATA WORDS= DATA WORDS + DATA WORDS
%RESULT=FAULT
!
! Report UNASSIGNED VARIABLE
!
COMPLEX UNASSIGNED: FAULT = UNASSIGNED VARIABLE %AND -> RETURN
%HALFINTEGERFN WIDTH FOR (%INTEGER DATA AD)
!
!
!
!
! A LOCAL PROCEDURE WHICH RETURNS THE FIELD WIDTH TO BE USED
!
! TO OUTPUT A PART OF A COMPLEX VALUE. THE FACTORS
!
! INVOLVED ARE THE SCALE OF THE VALUE AND THE NUMBER
!
! OF SIGNIFICANT DIGITS REQUIRED.
!
!
!It should be noted that the value will be output under a 'G' format
! which left justifies the value up to four places. This feature of
! 'G' format is unsatisfactory for complex values and necessitates a
! setting of the global variable WIDTH which will preclude any
! left justification.
!
!
!
%HALFINTEGER WIDTH {the result returned},
SIGN {set to 1 if A is negative}
{set to zero otherwise }
%REAL A; !a copy of the value to be output
!
! Get a copy of the complex part
!
A = REAL(DATA AD)
!
%IF A< 0.0 %THEN A=-A %AND SIGN=TRUE %C
%ELSE SIGN=FALSE
!
! Determine whether 'F' or 'E' formatting will be used
!
%IF A>=POINT ONE %AND A<POWERS OF TEN(DECIMALS) %THENSTART
!
{!'F' formating will be used} WIDTH=DECIMALS+1
WIDTH= WIDTH+1 %IF A<1.0
%FINISHELSE WIDTH=DECIMALS+6
%RESULT=WIDTH+SIGN
!(add on one if value is negative)
%END; !of WIDTH FOR
%END; !of OUT COMPLEX
%HALFINTEGERFN CHECK LENGTH(%HALFINTEGER EXTRA)
!
!
!
!
! This Function is used by Free Format Output when it wants
! to check if there is enough space in the output buffer
! to write another value.
!
! If there is not enough space the buffer is output and is
! re-initialised for another record. A check is made to
! ensure that the next value does not overflow the buffer.
!
!
!
%HALFINTEGER FAULT
!
%IF EXTRA+BPTR< BLEN %THENRESULT= 0 {there is enough room}
!
! Output the current record
!
FAULT= NEW RECORD
%IF FAULT=NONE %THENSTART
%IF BLEN> EXTRA %THEN IO FIELD(0)= BLANK %C
%AND F PTR = 1 %C
%ELSE FAULT = RECORD TOO SMALL
%FINISH
%RESULT= FAULT
%END; !of CHECK LENGTH
!
!
!
%END; !of OUT ITEM
%HALFINTEGERFN UNASSIGNED CHECK ( %INTEGER DATA AD ,
%HALFINTEGER DATA WORDS )
!
!
!
!
! THIS IS A UTILITY PROCEDURE TO PERFORM UNASSIGNED
!
! VARIABLE CHECKING IN A MACHINE-INDEPENDENT FORM.
!
!
!Note: The data type is assumed NOT to be of type CHARACTER
!
!
!
%IF DATA WORDS = 1 %THENSTART
!
%RESULT=FALSE %IF HALFINTEGER(DATA AD)\=X'8080'
%FINISHELSESTART; %RESULT=FALSE %IF INTEGER(DATA AD)\=X'80808080'
%FINISH; %RESULT= TRUE
!
!
%END; !of UNASSIGNED CHECK
%HALFINTEGERFN OUT FORMAT
!
!
!
!
!
%REALFNSPEC INTO RANGE (%REAL VALUE)
!
!
!
%CONSTINTEGERARRAY MIN PER WIDTH (0:10)= 0, -9, -99,
-999, -9999, -99999, -999999,
-9999999, -99999999, -999999999, X'80000000'
!
!Each array element corresponds to a value of
! WIDTH, and denotes the largest negative
! integer that may be formatted given that
! value of WIDTH
!
%OWNBYTEINTEGERARRAY OUTPUT AREA (0:31); !%C
OUTPUT AREA is used to save the generated %C
digits while formatting a value
!
! POINTERS
!
%INTEGER AREA PTR ; !Ptr used to save numerals in the work-area
%INTEGER PTR ; !Ptr used to construct a value in the output field
%INTEGER PTR MAX ; !addresses the end of the output field (+1)
!
!
%HALFINTEGER IO ITEM {FORTRAN type of }
%HALFINTEGER DATA LEN { the I/O item}
%HALFINTEGER FORMAT {Variables }
%HALFINTEGER DECS { describing }
%HALFINTEGER SCALE FACTOR { the format }
%HALFINTEGER LENGTH { code}
%REAL A {REAL value to format }
%HALFINTEGER SIGN {='+' or '-' or NONE }
%HALFINTEGER EXP {scale of the value to be formatted }
%HALFINTEGER ROUNDING {scale of the rounding to be applied}
%INTEGER I {INTEGER value to format}
%INTEGER M {a scale factor}
%INTEGER Q {a quotient }
%HALFINTEGER N {a utility variable}
%HALFINTEGER MAX INT DIGITS {max digits allowed left of '.'}
%HALFINTEGER INT DIGITS {no of digits reqd left of '.' }
%HALFINTEGER LEADING ZEROS {no of zeros reqd left of '.' }
%HALFINTEGER TOTAL CHARS {no of digits reqd on both sides of '.'}
%HALFINTEGER EXPONENT {value of an exponent }
%HALFINTEGER EXP TYPE {='D' or 'E' or 'Q' or NONE}
%HALFINTEGER EXP LENGTH {no of digits reqd in formatted exponent}
!
%CONSTHALFINTEGER MAX SCALE= 36
!=the highest power of ten that may
! be applied to a rounding factor
!
! INITIALISE VARIABLES
!
LENGTH = WIDTH
PTR =FPTR
PTR MAX= PTR + LENGTH
{copy details of the I/O item} IO ITEM= DATA TYPE
DATA LEN = DATA WORDS
!
! SPACE FILL THE OUTPUT BUFFER
!
%FOR I=F PTR,1,PTR MAX %CYCLE
!
IO FIELD(I)=BLANK
%REPEAT
%IF CHECK\=FALSE %THENSTART
!
! Test for an unassigned INTEGER or REAL or COMPLEX or LOGICAL
!
%IF UNASSIGNED CHECK(DATA AD,DATA LEN)=TRUE %THEN -> UNASSIGNED VARIABLE
!
%FINISH
%IF IO ITEM = A LOGICAL %THEN -> L FORMAT
%IF IO ITEM\=AN INTEGER %THEN FORMAT='G' %AND ->LOAD UP A REAL VALUE %C
%ELSE FORMAT='I' %AND ->LOAD UP AN INTEGER VALUE
!
!
! PICK UP THE VALUE TO BE FORMATTED NUMERICALLY
!
!
%IF IO ITEM=A REAL %THENSTART
!
LOAD UP A REAL VALUE: A= REAL(DATA AD) + 0.0 {to normalise}
%FINISHELSESTART
!
LOAD UP AN INTEGER VALUE: ! Get an INTEGER*4 or INTEGER*2
!
%IF DATA LEN=1 %THEN I=HALFINTEGER(DATA AD) %C
%ELSE I= INTEGER(DATA AD)
-> I FORMAT
%FINISH
!
! HANDLE A NEGATIVE VALUE
!
%IF A<0.0 %THEN A=-A %AND SIGN=MINUS %AND LENGTH= LENGTH-1 %C
%ELSE SIGN=NONE
!
! INITIALISE WORK-AREA VARIABLES
!
AREA PTR= 0 {displacement into OUTPUT AREA}
EXP= 1
!-> FORMAT TYPE (FORMAT)
!***********************************************************************
!
! HANDLE 'G' FORMAT
!
!***********************************************************************
!
{FORMAT TYPE ('G'):} DECS= DECIMALS
!
%IF POINT ONE<=A<POWERS OF TEN(DECS) %THENSTART
!
{!bring the value into range} A= INTO RANGE (A)
!
! Apply the rounding factor
!
A = A + 5.0/POWERS OF TEN(DECS)
%IF A>=10.0 %THENSTART
A= A/10.0; !apply correction if rounding put
EXP=EXP+1 ; ! the value back out of range
%FINISH;
!
! Determine actual WIDTH and DECIMALS to use
!
EXP LENGTH = 4
N =LENGTH - DECS - 1
!number of surplus characters in the field
%IF N>=EXP LENGTH %THEN LENGTH = LENGTH - EXP LENGTH
!
DECS= DECS - EXP
COLLECT DIGITS:
!
%IF EXP<=(-DECS) %AND SIGN=MINUS %THENSTART
!
!----only zeros will be printed,
!------so ensure that no minus will be printed too
!
SIGN= NONE %AND LENGTH= LENGTH+1
%FINISH
!
!
! DETERMINE THE VARIABLES WHICH CONTROL FORMATTING
!
!
MAX INT DIGITS= LENGTH - DECS - 1 ; != number of digits that
! may be output left
! of the decimal pt.
INT DIGITS= EXP
!
!INT DIGITS is the number of digits that are
! required to the left of the decimal point
%IF INT DIGITS<=0 %THENSTART
!
! Determine how many leading zeros are required if value is < 1.0
!
%IF MAX INT DIGITS=NONE %THENSTART
!
LEADING ZEROS= -INT DIGITS %AND INT DIGITS= NONE
%FINISHELSE LEADING ZEROS=1-INT DIGITS %AND INT DIGITS= 1
TOTAL CHARS= INT DIGITS - LEADING ZEROS + DECS
GENERATE LEADING ZEROS: !in the work area
!
PROPAGATE (LEADING ZEROS,ADDR(OUTPUT AREA(0)),0,NOUGHT)
AREA PTR= LEADING ZEROS
%FINISHELSESTART;
!
! Determine total number of numerals required if value>=1.0
!
TOTAL CHARS= INT DIGITS + DECS
%FINISH
FORMAT DIGITS: !
!
! CONVERT VALUE TO CHARACTERS (using machine
! independent code)
!
%WHILE TOTAL CHARS> 0 %CYCLE
TOTAL CHARS= TOTAL CHARS - 1
!
N = INT PT (A)
A = 10.0*(A - N)
OUTPUT AREA(AREA PTR)= NOUGHT + N
AREA PTR = AREA PTR + 1
!
%REPEAT
!
!
! FORM THE FORMATTED VALUE IN THE OUTPUT FIELD
!
!
PTR= PTR + (MAX INT DIGITS - INT DIGITS)
!
!point to where the first significant char should go
%IF SIGN\=NONE %THENSTART
!
! Move in a Sign
!
IO FIELD (PTR)= SIGN
PTR =PTR+1
%FINISH
!
! Write out the digits to the left of the decimal point
!
COPY(INT DIGITS,ADDR(OUTPUT AREA(0)),0,TEXT ADR, PTR)
AREA PTR= INT DIGITS
PTR= PTR + INT DIGITS
!
! Write out the decimal point
!
IO FIELD (PTR)=DOT
PTR =PTR+1
!
! Write out the digits to the right of the decimal point
!
%IF DECS>0 %THENSTART
!
COPY(DECS,ADDR(OUTPUT AREA(0)),AREA PTR,TEXT ADR,PTR)
PTR=DECS+PTR
%FINISH
%IF FORMAT='D' %THEN -> OUTPUT THE EXPONENT
!
!Jump if format code is 'D' or 'E' or 'Q' and continue
! to format the exponent characteristic
-> EXIT
!
!
%FINISH
!
! OUTPUT THE NUMBER WITH AN EXPONENT
!
-> D FORMAT ; !GO AND LET 'D' FORMATING
! DO ALL THE WORK
!***********************************************************************
!
! HANDLE 'D' FORMAT AND 'E' FORMAT AND 'Q' FORMAT
!
!***********************************************************************
!
D FORMAT:
!
{!Examine the scale factor} DECS= DECIMALS
!
SCALE FACTOR= 1 {always 1 for List-Directed output}
{adjust the } ROUNDING= DECS + 1
{ DECIMALS} DECS= ROUNDING - SCALE FACTOR
{ field }
%IF A=0.0 %THEN EXPONENT=NONE %C
%AND EXP =NONE %ELSESTART
!Bring the value into the range: 10.0> A >=1.0
!
A= INTO RANGE (A) + 5.0/POWERS OF TEN(ROUNDING)
%IF A> 10.0 %THENSTART ; !apply rounding
A=A/10.0; !apply correction
EXP=EXP+1 ; ! if rounding took value back out of range
%FINISH
EXPONENT= EXP-SCALE FACTOR; !determine the value of the exponent part
EXP=SCALE FACTOR; %FINISH
!
! Determine the sub-field required for the exponent
!
EXP LENGTH= 4
!= number of characters required
! to represent the exponent
!
! PRODUCE THE DECIMAL PART
!
LENGTH= LENGTH - EXP LENGTH; FORMAT= 'D'
!
-> COLLECT DIGITS
!expect a return with PTR pointing to
! the remainder of the output field
!OUTPUT THE EXPONENT:
OUTPUT THE EXPONENT: {ANALYSE THE EXPONENT TO FORMAT}
!OUTPUT THE EXPONENT:
I= EXPONENT
%IF I< 0 %THEN SIGN= MINUS %C
%ELSE SIGN= PLUS %AND I= -I
%IF I<-99 %THEN -> SKIP EXP TYPE
!
!IF 99<exponent<=999 THEN use the form '+zzz'
!IF exponent<= 99 THEN use the form 'E+zz'
!
! Determine the characteristic of the exponent
!
%IF RELAX ANSI\=FALSE %AND DATA LEN>2 %THENSTART
%IF DATA LEN>4 %THEN EXP TYPE= 'Q' %C
%ELSE EXP TYPE= 'D'
%FINISHELSE EXP TYPE= 'E'
{and write it into the field} IO FIELD (PTR)=EXP TYPE
PTR= PTR +1
!
EXP LENGTH= EXP LENGTH -1
SKIP EXP TYPE: !only if the exponent form is '+zzz' or '-zzz'
!
! Determine formatting control variables
!
EXP= EXP LENGTH -1
{PERFORM FORMATTING} -> FORMAT AN EXPONENT; !(see I format)
!***********************************************************************
!
! HANDLE 'I' FORMAT
!
!***********************************************************************
!
I FORMAT:
!
%IF I=0 %THEN -> OUTPUT A ZERO INTEGER
%IF I<0 %THEN SIGN =MINUS %AND LENGTH= LENGTH-1 %C
%ELSE SIGN = NONE %AND I=-I
!
! Determine the Scale of the Value
!
EXP= 1
EXP=EXP+1 %WHILE I<MIN PER WIDTH(EXP)
!
! Initialise formatting control variables
!
TOTAL CHARS= EXP
!
! Prepare the Output Field (for an Exponent as well)
!
PTR=PTR + (LENGTH - EXP)
FORMAT AN %C
EXPONENT: IO FIELD(PTR)=SIGN %C
%AND PTR = PTR + 1 %UNLESS SIGN=NONE
!
! NOW PERFORM INTEGER FORMATTING
!
M = MIN PER WIDTH (EXP-1) - 1 {initial value of Multiplier}
!
%CYCLE; Q = I// M ; !extract the next digit
I = I -(M*Q) ; ! and adjust the Value accordingly
M = M// 10 ; ! and adjust the Multiplier too
IO FIELD(PTR)= Q + NOUGHT ; !insert the digit into
PTR =PTR+ 1 ; ! the output field
%REPEAT %UNTIL M = 0 ; ! and repeat 'til all digits are acquired
!
!
-> EXIT
OUTPUT A ZERO INTEGER:
! OUTPUT A ZERO INTEGER:
! OUTPUT A ZERO INTEGER:
!
IO FIELD(PTR MAX-1)= NOUGHT %AND -> EXIT
!***********************************************************************
!
! HANDLE 'L' FORMAT
!
!***********************************************************************
!
L FORMAT:
%IF DATA LEN=2 %THENSTART
%IF INTEGER(DATA AD)&1= FALSE %C
%THEN SIGN= FALSE SIGN %C
%ELSE SIGN= TRUE SIGN
%FINISHELSE %IF HALFINTEGER(DATA AD)&1= FALSE %C
%THEN SIGN= FALSE SIGN %C
%ELSE SIGN= TRUE SIGN
IO FIELD (PTR MAX-1)= SIGN
-> EXIT
!***********************************************************************
!
! END OF HANDLING OUTPUT FORMATS
!
!***********************************************************************
!
UNASSIGNED %C
VARIABLE: %RESULT= UNASSIGNED VARIABLE
!
!
!
EXIT: FPTR= PTR MAX
!
%RESULT=0
!***********************************************************************
!
! ROUTINES FOR HANDLING OUTPUT FORMATS
!
!***********************************************************************
!
%REALFN INTO RANGE (%REAL X)
!
!
!
! A PROCEDURE WHICH BRINGS THE VALUE OF THE GIVEN
!
! PARAMETER INTO THE RANGE 10.0> X >=1.0
!
!
!Additionally, the variable EXP is changed to reflect the
! magnitude (scale of 10) of the parameter.
!
!
%INTEGER I; !a work variable
%IF X>=10.0 %THENSTART
!
! The value is too large
!
%IF X>=TEN TO THE 38 %THEN I=38 %ELSESTART
!
{!ELSE } I= 2
{!find the scale of} I=I+1 %WHILE X>= POWERS OF TEN(I)
{! the value } I=I-1
%FINISH; X =X/POWERS OF TEN(I)
EXP = EXP+I
%FINISH
%IF X<1.0 %THENSTART
!
! The value is too small
!
X=X*10.0 %AND EXP=EXP-1 %WHILE X<TEN TO THE MINUS 36
!
I= -1
I=I-1 %WHILE X< POWERS OF TEN( I)
EXP=I+EXP %AND X=X*POWERS OF TEN(-I)
%FINISH
!
! Return
!
%RESULT= X
%END; !of INTO RANGE
%END; !of OUT FORMAT
!
!***********************************************************************
!
! UTILITY PROCEDURES
!
!***********************************************************************
!
%ROUTINE PROPAGATE (%INTEGER LEN,BASE %HALFINTEGER INC,WITH)
!
!
!
!
! This is a utility procedure to fill part of an area which
!
! is usually a CHARACTER variable with a specified number
!
! of a given character.
!
!
!
%BYTEINTEGERARRAYFORMAT AREA FORMAT (0:1023)
%BYTEINTEGERARRAYNAME AREA
AREA==ARRAY (BASE,AREA FORMAT)
%WHILE LEN> 0 %CYCLE
!
AREA(INC)= WITH
INC = INC + 1
LEN = LEN - 1
%REPEAT
%END; !of PROPAGATE
%IF SYSTEM=PERQ %THENSTART
!
!
%HALFINTEGERFN BYTE AT (%INTEGER DATA AD, %HALFINTEGER DATA INC)
!
!
!
%HALFINTEGER I
I=HALFINTEGER(DATA AD + DATA INC>>1)
%RESULT= I & 255 %IF (DATA INC&1)= 0
%RESULT= I >> 8
%END; !of BYTE AT
!*
%ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP,
%INTEGER TBASE,%HALFINTEGER TDISP)
**@TBASE; *LDDW; **TDISP
**@SBASE; *LDDW; **SDISP
**LEN
*STLATE_X'63'; *MVBW
%END
!
!
%FINISH; !if PERQ
%IF SYSTEM=EMAS %THENSTART
!
!
%ROUTINE COPY (%INTEGER LENGTH, FROM BASE {word address} ,
%HALFINTEGER FROM DISP {byte displacement} ,
%INTEGER TO BASE {word address again} ,
%HALFINTEGER TO DISP {byte displacement again} )
%WHILE LENGTH> 0 %CYCLE
!
BYTEINTEGER(TO BASE + TO DISP)=BYTEINTEGER(FROM BASE + FROM DISP)
TO DISP= TO DISP + 1
FROM DISP=FROM DISP + 1
LENGTH= LENGTH - 1
%REPEAT
%END; !of COPY
%HALFINTEGERFN BYTE AT (%INTEGER DATA AD {word address} ,
%HALFINTEGER DATA DISP {byte displacement} )
%RESULT= BYTEINTEGER (DATA AD + DATA DISP)
%END; !of BYTE AT
!
!
%FINISH; !if EMAS
!
!
!
!
!
%END; !of F77 IOD
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
%ENDOFFILE