!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 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 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=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 992 %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 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 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