1 /3 OS/8 FORTRAN (PASS THREE)
3 / VERSION 4A PT 16-MAY-77
5 / OS/8 FORTRAN IV COMPILER-PASS 3
8 / UPDATED BY: R. LARY + M. HURLEY
11 /COPYRIGHT (C) 1974,1975 BY DIGITAL EQUIPMENT CORPORATION
22 /THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
23 /AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
24 /CORPORATION. DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
25 /FOR ANY ERRORS THAT MAY APPEAR IN THIS DOCUMENT.
27 /THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
28 /UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
29 /(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
30 /SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
32 /DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
33 /OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
40 OUDEVH=7000 /PUT OUDEVH AND OUBUF IN DIFFERENT
43 OUBUF=5400 /SEGMENTS, STAN KNOWS WHY
52 DEV1CE=173 /THROUGH 177
58 / OS/8 V3C MAINTENANCE RELEASE FIXES:
60 /1. EXTENDED RANGE OF PAGE NUMBERS TO 99
61 /2 INTERCHANGED CR/LF FOR HASSINGER
62 /3 CHANGED VERSION NO. TO 305
63 /5. ADDED 'I' TO JMP (OFOO3
66 / CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
67 / .CHANGED VERSION NUMBER TO 4A
68 / .PUT IN NEW DATE ALGORITHM
72 *400 /DON'T LOAD INTO 0-377
76 TAD I LSTFIL /COPY FILE NAME
83 TAD DEV1CE /FETCH HANDLER FOR OUTPUT FILE
85 JMS I (200 /USR IS IN CORE
87 OH, OUDEVH+1 /TWO PAGE HANDLER IS OK
90 TAD DEV1CE /OPEN THE LISTING FILE
96 TAD OB /SAVE BLOCK NUMBER
99 DCA OSIZE /AND SIZE OF HOLE
100 TAD OH /SAVE HANDLER ADDRESS
102 TAD (NUMS-1 /SET UP NUMBER POINTER
104 TAD TEMP /GET THE DATE--FOR YEAR ROUTINE
107 AND (7 /MASK OUT ALL BUT YEAR OFFSET BITS
108 DCA YRTEMP /INCREMENT FROM THE BASE YEAR
109 DCA TEMP1 /HOLDS THE FIRST DIGIT OF THE YEAR
110 TAD I (7777 /GET THE DATE EXTENSION BITS
111 AND (600 /MASK TO GET THE EXTENSION BITS
112 CLL RTR /ROTATE THEM INTO BIT
113 RTR /POSITIONS 7 AND 8
114 TAD (106 /ADD IN 70---OLD BASE YEAR
115 TAD YRTEMP /ADD IN THE YEAR OFFSET BITS
116 /TO FIND THE NEW BASE YEAR
117 CONVYR, CLL /FIND THE YEAR IN DECIMAL
118 TAD (-12 /KEEP SUBTRACTING 12
120 JMP SECDIG /FIND THE SECOND DIGIT OF THE YEAR
121 ISZ TEMP1 /FIND THE FIRST DIGIT OF THE YEAR
122 JMP CONVYR /TRY AGAIN
123 SECDIG, TAD (72 /GET THE SECOND DIGIT OF THE YEAR
124 RTL /AND MAKE IT SIXBIT
127 DCA I (YEAR+1 /PUT IT IN THE PRINT LINE
128 TAD TEMP1 /GET THE FIRST DIGIT
129 TAD (5560 /MAKE IT SIXBIT
130 DCA I (YEAR /PRINT IT
131 TAD TEMP /GET THE DATE--NOW FIND THE MONTH/DAY
136 SIMPLE, TAD TEMP /GET THE DAY
138 TAD (DAYS-1 /THIS IS THE LAZY WAY
142 TAD TEMP /GET THE MONTH
152 JMP I (PAJE /WE GOT THE DATE
159 PAJE, JMP I (PRHDR /PRINT THE FIRST HEADING
160 CLL CML RTL /INITIALIZE LINE NUMBER
163 RDLUPE, TAD (SEVCHR-1 /SEVEN CHAR BUFFER
168 JMP RDACHO /ECHO & IGNORE SHORT LINES
169 TAD (-211 /IS IT A TAB ?
173 DCA TABCNT /SET POINTER TO DO EXTRA SPACES LATER**
178 JMP WHAT /GO LOOK AT THE LINE
180 DCA I X10 /SAVE THE CHAR
183 WHAT, TAD SEVCHR /IS IT A COMMNET
186 JMP NOISN /YES, NO INTERNAL STMT NUMBER
187 TAD SEVCHR+5 /IS IT A CONTINUATION ?
190 JMP NOISN /YES, NO ISN
191 TAD LINENO /NEITHER OF THESE
192 JMS I (ONUMBR /PRINT ISN
193 TAD LINENO /2.01/ PUT LINE NUM
195 CLA /2.01/ CLA IF NO EAE
196 ISZ LINENO /BUMP LINE NUMBER
199 TAD (SEVCHR-1 /PRINT FIRST SEVEN
207 TAD TABCNT /SEE IF A TAB WAS 1ST
208 SMA CLA /IF YES,NEED 2 MORE SPACES
210 DCA TABCNT /WAS A TAB
215 NOTTAB, JMS I (ICHAR /PRINT REST OF LINE
219 ENDLIN, JMS I (CRLF /END LINE
220 JMS I (ERRCHK /CHECK ERROR LIST
221 JMP RDLUPE /DO NEXT LINE
224 HEADER, TEXT ' FORTRAN IV 4AAAA '
231 ZBLOCK 7 /V3C ROOM FOR LARGE PAGE NUMBERS
238 NUMS,/ 2427;1740;4040
285 DAYS, 4061;4062;4063;4064;4065;4066;4067;4070;4071
286 6160;6161;6162;6163;6164;6165;6166;6167;6170;6171
287 6260;6261;6262;6263;6264;6265;6266;6267;6270;6271
289 MONTHS, 5512;0116 /-JAN
302 \fENDX, TAD (-601 /2.02/ CLEAR END OF BUFFER
303 DCA LINENO /2.01/ FOR TV: REASONS
304 TAD X232 /2.01/ OUTPUT ^Z
308 CIF 10 /CLOSE THE OUTPUT FILE
315 CDF 10 /LOOK AT OPTIONS
319 JMP I (7605 //A MEANS DON'T CHAIN TO RALF
321 TAD FILDEV /SET UP RALF INPUT LIST
322 DCA I (7617 /FILE SIZE AND DEVICE CODE
324 TAD FILBLK /FILE START
326 ISZ (7617 /ZERO END OF LIST
328 TAD I X7643 /IS IT /F (FULL LIST) ?
335 AND (20 /LET /T SWITCH THRU ALSO
337 DCA I (7605 /NO, INHIBIT RALF LISTING
341 JMS I (200 /LOOKUP RALF.SV
348 CIF 10 /CHAIN TO RALF
354 DCA TEMP /OUTPUT ISN IN OCTAL
358 CLL RTL /ANYONE WHO CAN'T FOLLOW THIS
359 RAL /SHOULDN'T BE A PROGRAMMER
369 CONVRT, 0 /CONVERT TO ASCII AND PRINT
378 LINECT, -1 /EJECT FIRST TIME
388 PRHDR, TAD M70 /RESET COUNT
390 TAD (HEADER /COPY HEADER OUT
399 TAD I TEMP /END YET ?
404 TAD (215 /V3C SKIP EXTRA LINE AFTER TITLE
407 JMS I (OCHAR /FOR CENTRONICS
408 JMP PUTNUM /GET NEW PAGE NUMBER
409 \f/ OS/8 FILE INPUT ROUTINES
411 ICHAR, 0 /READ CHAR FROM INPUT FILE
412 ISZ INJMP /BUMP THREE WAY UNPACK SWITCH
415 TAD INEOF /DID LAST READ YEILD END OF FILE ?
417 JMP INGBUF /NO, DO ANOTHER READ
418 GETNEW, JMS INNEWF /OPEN A NEW INPUT FILE
419 JMP I (ENDX /NO FILE TO OPEN
420 INGBUF, TAD INCTR /BUMP RECORD COUNTER
423 DCA INCTR /RESTORE IF IT HASN'T OVERFLOWED
425 ISZ INEOF /SET END OF FILE SWITCH
426 JMS I INHNDL /DO THE READ
430 JMP INERR /HANDLER ERROR
431 INBREC, ISZ INREC /BUMP RECORD NUMBER
432 TAD (-601 /SET CHAR COUNT
434 TAD INJMPP /RESET THREE WAY JUMP SWITCH
436 TAD INBUFP /RESET BUFFER POINTER
438 JMP ICHAR+1 /GO AGAIN
439 INERR, ISZ INEOF /EITHER EOF OR BADDIE
441 JMP INBREC /END OF FILE, DO NEXT FILE
443 INJMP, HLT /3 WAY CHARACTER UUPACK SWITCH
446 ICHAR3, TAD INJMPP /RESET JUMP SWITCH
449 AND (7400 /COMBINE THE HIGH ORDER BITS
450 CLL RTR /OF THE TWO WORDS
452 TAD INTMP /TO FORM THE THIRD CHAR
455 ISZ INPTR /BUMP WORD POINTER
456 JMP ICHAR1+1 /DO SOME COMMON STUFF
457 ICHAR2, TAD I INPTR /SAVE THE HIGH ORDER BITS
459 DCA INTMP /FOR THE THIRD CHAR
460 ISZ INPTR /GO TO THE SECOND WORD
461 ICHAR1, TAD I INPTR /GET THE LOW 8 BITS
462 AND (377 /AND I MEAN ONLY 8 !!
465 TAD (-232 /IS IT ^Z (END OF FILE)
467 JMP GETNEW /YES, LOOK FOR THE NEXT FILE
470 JMP ICHAR+1 /IGNORE LINE FEEDS
473 JMP I ICHAR /RETURN ON CARRIAGE RETURN
476 JMP ICHAR+1 /IGNORE FORM FEEDS
479 JMP I ICHAR /RETURN TO THE CALLING WORLD
481 INFPTR, 7617 /POINTER TO INPUT FILE LIST
484 INNEWF, -1 /FETCH HANDLER FOR NEXT FILE
485 TAD (INDEVH+1 /THIS IS WHERE IT GOES
488 TAD I INFPTR /GET NEXT INPUT FILE INFO
491 JMP I INNEWF /NO MORE FILES
493 JMS I INCALL /CALL MONITOR
495 INHNDL, 0 /ENTRY ADDR GOES HERE
498 TAD I INFPTR /GET LENGTH
500 SZA /A ZERO HERE MEANS >=256 BLOCKS
501 TAD (17 /PUT IN SOME MORE BITS
504 DCA INCTR /STORE LENGTH OF FILE
506 TAD I INFPTR /GET STARTING RECORD NUMBER
509 DCA INEOF /CLEAR EOF FLAG
515 /PUTNUM, TAD (PAGENO-1 /COPY THE NEW NUMBER
527 RDECHO, /KEEP LINES WITH L.T. 6 CHARS OUT OF ISN COLUMN
534 JMP ENDLIN /ONLY ECHO WHAT YOU READ
539 OUDUMP, 0 /BUMP THE DUFFER
540 TAD OSIZE /ANY ROOM LEFT ?
544 DCA OSIZE /YES, ITS OK
547 OUBUF /BUFFER POINTER
548 OBLOCK, 0 /BLOCK NUMBER
550 ISZ OBLOCK /INCREMENT BLOCK NUMBER
551 ISZ FILSIZ /AND FILE SIZE
552 TAD OBLOCK-1 /SET BUFFER POINTER
554 TAD (-200 /SET DOUBLE WORD COUNT
557 OCHAR, 0 /OUTPUT A CHAR TO THE RALF INPUT FILE
559 DCA OUTEMP /SAVE CHAR
567 NOSTOP, ISZ OUJUMP /BUMP 3 WAY SWITCH
571 TAD OUTEMP /HIGH FOUR BITS GO INTO
572 CLL RTL /THE HIGH ORDER BITS OF THE
573 RTL /FIRST WORD OF THE TWO WORD PAIR
574 AND (7400 /SEE NOTE * BELOW
575 TAD I OUPOLD /COMBINE WITH OTHER BITS
577 TAD OUTEMP /THE OTHER FOUR BITS OF THIS CHAR
578 CLL RTR /GO INTO THE HIGH ORDER FOUR
579 RTR /BITS OF THE SECOND WORD OF THE PAIR
584 TAD OUJMP /RESET 3 WAY BRANCH
586 ISZ OUPTR /BUMP BUFFER POINTER
587 ISZ OUWDCT /AND DOUBLE WORD COUNTER
588 JMP I OCHAR /BUFFER NOT FULL
591 CHAR2, TAD OUPTR /SAVE FIRST WORD POINTER
593 ISZ OUPTR /GO TO SECOND WORD
594 CHAR1, TAD OUTEMP /STORE CHAR 1 OR 2
606 TAD I ERRPTR /ANY ERRORS FOR THIS LINE
612 CLL CMA RAL /BACK UP POINTER
622 DCA TEMP /SAVE NEGATIVE
625 FIND, TAD I X10 /LOOK FOR ERROR MESSAGE
631 JMP FIND /SKIP POINTER WORD
634 DCA X10 /POINTER TO MESSAGE
635 PMLOOP, TAD I X10 /GET TWO CHARS
641 JMS CONVRT /PRINT FIRST
643 JMS CONVRT /PRINT SECOND
645 AND (77 /END OF MESSAGE ?
649 JMP ERRCHK+1 /SEE IF ANY MORE FOR THIS LINE
650 RALFNM, FILENAME RALF.SV
655 OFOO3, TAD X304 /FATAL ERROR IN PASS 3
711 SYSERR, TEXT 'UNDEFINED ERROR'
712 II, TEXT 'ILLEGAL USE OF IF'
713 GT, TEXT 'BAD GOTO STATEMENT'
714 RW, TEXT 'BAD READ OR WRITE STATEMENT'
715 CO, TEXT 'ARGS IN COMMON OR VAR IN TWO COMMONS OR SYNTAX BAD'
716 IT, TEXT 'BAD IO LIST ELEMENT'
717 EX, TEXT 'BAD EXTERNAL STMT'
718 QS, TEXT 'SYNTAX ERROR IN EQUIVALENCE'
719 QL, TEXT 'VARIABLE IS EQUIVALENCED MORE THAN ONCE'
720 IF, TEXT 'THIS KIND OF STATEMENT NOT LEGAL AFTER LOGICAL IF'
721 DO, TEXT 'BAD SYNTAX IN DO OR IMPLIED DO'
722 SN, TEXT 'NOT LEGAL AS SUBROUTINE NAME'
723 TD, TEXT 'SYNTAX ERROR IN TYPE STATEMENT'
724 BD, TEXT 'DIMENSIONS TOO BIG, OR SYNTAX ERROR IN DIMENSION LIST'
725 ED, TEXT 'ILLEGAL AS DO ENDING STATEMENT'
726 RT, TEXT 'ATTEMPT TO RE-TYPE A VARIABLE'
727 RD, TEXT 'ATTEMPT TO RE-DIMENSION A VARIABLE'
728 ST, TEXT 'INTERNAL COMPILER ABORT NUMBER ONE'
729 CL, TEXT 'ERROR IN COMPLEX LITERAL'
730 MO, TEXT 'OPERAND EXPECTED, NONE PRESENT'
731 HO, TEXT 'HOLLERITH COUNT WRONG, OR MISSING QUOTES'
732 MM, TEXT 'MISMATCHED PARENTHESIS'
733 SS, TEXT 'SUBSCRIPT OR ARGUMENT LIST ERROR'
734 OP, TEXT 'ILLEGAL OPERATOR'
735 AS, TEXT 'ASSIGN ???'
736 DA, TEXT 'DATA STATEMENT ?'
737 DH, TEXT 'HOLLERITH COUNT OR QUOTE ERROR IN DATA STATEMENT'
738 ML, TEXT 'THIS LINE NUMBER IS ALREADY DEFINED'
739 DE, TEXT "WRONG WAY TO END A DO LOOP"
740 BS, TEXT 'ILLEGAL IN BLOCK DATA'
741 LT, TEXT 'LINE TOO BIG'
742 IE, TEXT 'INPUT FILE ERROR, TAKEN AS END STATEMENT'
743 PH, TEXT 'THIS FUNCTION / SUBROUTINE STATEMENT IS UNACCEPTABLE'
744 MK, TEXT 'YOU MISPELED A KEYWURD'
745 OT, TEXT 'ILLEGAL OPERAND TYPE FOR THIS OPERATOR'
746 PD, TEXT 'INTERNAL COMPILER ABORT NUMBER TWO'
747 MT, TEXT "ILLEGAL VARIABLE TYPE MIXING"
748 GV, TEXT 'VARIABLE IN ASSIGNED OR COMPUTED GOTO MUST BE INTEGER OR REAL'
749 LI, TEXT 'EXPRESSION IN LOGICAL IF IS NOT TYPED LOGICAL'
750 DP, TEXT 'DO PARAMETERS MUST BE INTEGER OR REAL'
751 DL, TEXT "YOUR DATA AND VARIABLE LISTS ARE OF DIFFERENT LENGTHS"
752 AA, TEXT 'SUBROUTINES MAY ONLY HAVE SIX ARGUMENTS THAT ARE DIMENSIONED'
753 SF, TEXT 'BAD STATEMENT FUNCTION'
754 DF, TEXT 'BAD DEFINE FILE'
757 PUTNUM, ISZ PAGEN /BUMP PAGE NUMBER
763 JMS MOVE /MOVE IN NUMBER
768 DCA NUM /PT TO NEXT ONE
775 OVER19, DCA TENS /CONVERT
776 TAD PAGEN /PAGE NUMBER TO ONES AND TENS
777 O1, TAD (-12 /DIVIDE BY TEN
787 DCA HIP /POINT TO HIGH PART