ASMB,R,L,C
      HED RTE-M FORTRAN MAIN
      NAM FTN 92064-16045  REV.1650  761118 
      SUP 
* 
* 
*   ********************************************************* 
*   * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.           * 
*   *                                                       * 
*   * ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM MAY BE  * 
*   * PHOTOCOPIED, REPRODUCED, OR TRANSLATED TO ANOTHER     * 
*   * PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN CONSENT OF * 
*   * HEWLETT-PACKARD COMPANY.                              * 
*   ********************************************************* 
* 
*     RTE-M FORTRAN IS SCHEDULED USING THE FOLLOWING FORMAT:
* 
*     ON, 
*     RU,FTN [,FI,LE,NM [,NN]]
*            [,LU            ]
* 
*     WHERE:
* 
*     FI,LE,NM IS THE NAME OF AN ANSWER FILE CONTAINING ANSWERS TO
*     FORTRAN QUERIES.
* 
*     LU IS THE LOGICAL UNIT NUMBER OF A CONSOLE DEVICE WHICH 
*     FORTRAN WILL COMMUNICATE WITH FOR ANSWERS TO ITS QUERIES. 
*     DEFAULT IS THE LU FORTRAN WAS SCHEDULED FROM. 
* 
*     NN IS THE NUMBER OF LINES PER PAGE(0<NN<57) TO BE OUTPUT ON 
*     THE LIST FILE. DEFAULT IS 56. 
* 
* 
      SKP 
* 
*     ENTRY POINTS,EXTERNALS AND COMMON 
* 
      ENT FTN0,FMPER,TERM 
* 
      EXT GTFIL,SEGLD,CREAT,RMPAR,IDCB0,IDCB2,IDCB3 
      EXT IMESS,OPEN,EXEC,.STOP,FCONT,LIMEM 
* 
      COM SPACE(47) USED BY SEGMENTS 1 & 2
* 
      COM AI(6),AO(6),AL(6),AS1(6)
      COM ERRS,OPTS1,OPTS2,OPTS3,NAME,LINES 
      COM FDVL,OPT4 
* 
*     FORTRAN MAIN STARTS HERE BY CALLING GTFIL TO GET INPUT, 
*     OUTPUT,LIST AND SCRATCH FILES. THE INPUT,OUTPUT,LIST
*     AND SCRATCH FILES ARE THEN OPENED. IF NOT THERE,THEY ARE
*     CREATED. THE OUTPUT FILE IS THEN CLOSED SINCE ITS NOT 
*     USED UNTIL PASS 2.
* 
A     EQU 0 
B     EQU 1 
FTN0  EQU * 
      JSB RMPAR     GET 
      DEF *+2        SCHEDULE 
      DEF PBUFF       PARAMETERS
      LDA PBUFF+3   GET LINES PER PAGE OPTION 
      SZA,RSS       DEFAULT?
      JMP FTN11     YES.USE 56
      ADA .M57      NO.IS 
      SSA,RSS        IT >56?
      JMP FTN11     YES.USE 56
      LDB PBUFF+3   NO.USE PARAMETER
      RSS 
FTN11 EQU * 
      LDB .56       SET LINES/PAGE=56 
      CMB,INB       NEGATE LINES PER PAGE 
      STB LINES      AND SAVE IN COMMON 
      LDA .M24      CLEAR 
      STA VAL        COMMON 
      CLA             AREA
      LDB PNT07        USED 
FTN12 EQU *             FOR THE 
      STA B,I            GTFIL
      INB                 ARRAYS
      ISZ VAL 
      JMP FTN12 
      SKP 
      LDA PNT06     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB GTFIL     GET INPUT,
      DEF FTN00      OUTPUT,LIST, 
      DEF GOPTS       AND SCRATCH 
      DEF ERRS         FILES
      DEF PBUFF 
      DEF AI
      DEF AO
      DEF AL
      DEF * 
      DEF AS1 
FTN00 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
      LDA B410      INITIALIZE
      STA OPTS1      OPEN 
      LDA B210        OPTIONS 
      STA OPTS2 
      LDA B110
      STA OPTS3 
      LDA PNT02     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB OPEN      ATTEMPT 
      DEF FTN01      TO OPEN
      DEF IDCB0       INPUT 
      DEF ERRS         FILE 
PNT02 DEF AI+1
      DEF OPTS1 
      DEF AI+5
      DEF AI
FTN01 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
      LDA PNT03     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB OPEN      ATTEMPT TO
      DEF FTN08      OPEN THE OUTPUT
      DEF IDCB2       FILE USING THE
      DEF ERRS         LIST FILE DCB
PNT03 DEF AO+1
      DEF OPTS3 
      DEF AO+5
      DEF AO
FTN08 EQU * 
      SSA,RSS       ERROR OCCUR?
      JMP FTN09     NO.GO ON TO OPEN LIST(CLOSE OUTPUT) 
      LDA ERRS      YES.IS
      CMA,INA        IT FMP 
      CPA B6          ERROR -006? 
      RSS           YES 
      JMP FMPER     NO.GO REPORT IT 
      SKP 
      JSB CREAT     ATTEMPT TO
      DEF FTN10      CREATE THE 
      DEF IDCB2       OUTPUT FILE AS
      DEF ERRS         A TYPE 5 FILE
      DEF AO+1          USING THE LIST
      DEF .20            FILE DCB 
      DEF .5
      DEF AO+5
      DEF AO
FTN10 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
FTN09 EQU * 
      LDA PNT04     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB OPEN      ATTEMPT 
      DEF FTN02      TO OPEN
      DEF IDCB2       LIST FILE 
      DEF ERRS         (AND CLOSE THE 
PNT04 DEF AL+1          OUTPUT FILE)
      DEF OPTS2 
      DEF AL+5
      DEF AL
FTN02 EQU * 
      SSA,RSS       ERROR OCCUR?
      JMP FTN03     NO.GO ON TO SCRATCH FILE
      LDA ERRS      YES.IS
      CMA,INA        IT FMP 
      CPA B6          ERROR -006? 
      RSS           YES 
      JMP FMPER     NO.GO REPORT FMP ERROR
      JSB CREAT     ATTEMPT TO
      DEF FTN04      CREATE THE 
      DEF IDCB2       LIST FILE 
      DEF ERRS         AS A TYPE
      DEF AL+1          4 FILE
      DEF .64 
      DEF .4
      DEF AL+5
      DEF AL
FTN04 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
      SKP 
FTN03 EQU * 
      LDA PNT05     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB OPEN      ATTEMPT 
      DEF FTN05      TO OPEN
      DEF IDCB3       SCRATCH FILE
      DEF ERRS
PNT05 DEF AS1+1 
      DEF OPTS3 
      DEF AS1+5 
      DEF AS1 
FTN05 EQU * 
      SSA,RSS       ERROR OCCUR?
      JMP FTN06     NO.GO ON
      LDA ERRS      YES.IS
      CMA,INA        IT FMP 
      CPA B6          ERROR -006? 
      RSS           YES 
      JMP FMPER     NO.GO REPORT FMP ERROR
      JSB CREAT     ATTEMPT TO
      DEF FTN07      CREATE THE 
      DEF IDCB3       SCRATCH FILE
      DEF ERRS         AS A TYPE
      DEF AS1+1         5 FILE
      DEF .20 
      DEF .5
      DEF AS1+5 
      DEF AS1 
FTN07 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
FTN06 EQU * 
      LDA PNT06     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      JSB SEGLD     LOAD SEGMENT 1 AND
      DEF FMPER      EXECUTE IT FOR PASS 1
      DEF SEG1        EXECUTION,ELSE BRANCH 
      DEF ERRS         TO ERROR ROUTINE FMPER 
* 
*     EXIT THE MAIN TO GO TO EXECUTION OF PASS 1. INPUT,LIST
*     AND SCRATCH FILES ARE OPEN. 
* 
      HED RTE-M FORTRAN MAIN ROUTINES 
*     F M P E R 
* 
*     REPORTS THE FMP ERROR DEFINED BY THE NEGATIVE NUMBER
*     IN COMMON LOCATION "ERRS" AND TERMINATES FTN. EXPECTS 
*     A POINTER TO THE FILE NAME IN COMMON LOCATION "NAME". 
* 
FMPER EQU * 
      LDA B6        INITIALIZE CONVERSION ROUTINE 
      LDB PNT01      TO OUTPUT 6 CHARACTERS EVEN
      JSB XPUTI       THOUGH IT WILL ONLY OUTPUT 5
      LDA ERRS      CONVERT ERROR NUMBER
      CMA,INA        TO ASCII 
      JSB XDCAS       IN ERROR MESSAGE
      LDA NAME,I    MOVE FILE 
      STA FNAME      NAME INTO
      ISZ NAME        ERROR 
      LDA NAME,I       MESSAGE
      STA FNAME+1 
      ISZ NAME
      LDA NAME,I
      STA FNAME+2 
      JSB IMESS     REPORT FMP
      DEF TERM       ERROR ON 
      DEF .2          SESSION 
      DEF ERR          CONSOLE
      DEF .13 
TERM  EQU * 
      JSB IMESS     WRITE "$FTN-
      DEF END        ABORTED" ON
      DEF .2          ON SESSION
      DEF ABORT        CONSOLE
      DEF B6
END   EQU * 
      JSB EXEC      TERMINATE 
      DEF *+2        FTN
      DEF B6
      SKP 
*     X P U T I/X P U T 
* 
*     PACK CHARACTERS IN DESTINATION BUFFER:
* 
*     INIT CALL: INIT DESTINATION BUFFER
*         LDA <CHARACTER LENGTH>
*         LDB <BUFFER ADDRESS>
*         JSB XPUTI 
* 
*     XPUT CALL: STUFF A CHAR 
*         LDA <CHARACTER> 
*         JSB XPUT
*         P+1 <EOB, (A)=CHARACTER, (B)=CURRENT COUNT> 
*         P+2 <NORMAL, (A) =CHARACTER, (B)=CURRENT COUNT> 
* 
XPUTI NOP 
      STA XDLNG 
      STB XDADR 
      CLA 
      STA XDCNT 
      JMP XPUTI,I 
* 
XPUT  NOP 
      LDB XDCNT 
      CPB XDLNG     EOB ? 
      JMP XPUT,I    YES, LEAVE
      STA XPUTI 
      LDA XDADR,I   GET CURRENT WORD
      SLB,RSS       EVEN COUNT ?
      ALF,ALF       YES, POSITION 
      AND M400      CLEAR EXCESS
      IOR XPUTI     MERGE CHARACTER 
      SLB,RSS       EVEN COUNT ?
      ALF,ALF       YES, POSITION 
      STA XDADR,I 
      SLB,INB       ODD COUNT ? 
      ISZ XDADR     YES, BUMP ADDRESS 
      STB XDCNT     BUMP COUNT
      LDA XPUTI 
      ISZ XPUT
      JMP XPUT,I
      SKP 
*     X C V A S/X D C A S 
* 
*     INTEGER TO ASCII CONVERSION ROUTINES. FUNCTIONALLY
*     SIMILAR TO HP PART # 25311-80045. 
* 
*     XCVAS CALL: <RADIX> TO ASCII
* 
*         LDA <VALUE> 
*         LDB <+/- RADIX> 
*             +RADIX: UNSIGNED 16 BIT INTEGER 
*             -RADIX: SIGNED 15 BIT INTEGER 
*         CLE <SUPPRESS LEADING 0'S>
*         CCE <GENERATE LEADING 0'S>
*         JSB XCVAS 
*         P+1 <EOB DETECTED>
*         P+2 <NORMAL, RESULT IN "XPUT" BUFFER> 
* 
*     XDCAS CALL: DECIMAL TO ASCII, UNSIGNED
* 
*         GENERATE LEADING ZEROES.
*         LDA <VALUE> 
*         JSB XDCAS 
*         P+1 <NORMAL, 5 CHARACTER RESULT IN "XPUT" BUFFER> 
* 
*     R.FAJARDO, 731214 
* 
XDCAS NOP 
      LDB .10       RADIX=10, UNSIGNED #
      CCE           GENERATE LEADING 0'S
      JSB XCVAS 
      NOP 
      JMP XDCAS,I 
* 
XCVAS NOP 
      SEZ           SUPPRESS LEADING 0'S ?
      ISZ LDING     NO, GIVE THEM TOO 
      STA VAL 
      STB RADIX 
      SSB,RSS       SIGNED ?
      JMP XCV2
      CMB,INB       YES, FORCE
      STB RADIX      + RADIX
      SSA,RSS       + VALUE?
      JMP XCV2
      CMA,INA       NO, FORCE + 
      STA VAL 
      LDA B55       & GIVE "-"
      JSB XPUT
      JMP XCVAS,I   EOB, EXIT P+1 
      SKP 
XCV2  LDA RADIX     FIND LARGEST
      MPY RADIX      DIGIT POSITION 
      SZB,RSS 
      JMP *-3 
      DIV RADIX     SAVE AS DIVISOR 
      STB FDIG
XCV3  STA DIVSR 
      LDA VAL       EXTRACT NEXT DIGIT
      CLB 
      DIV DIVSR 
      STB VAL 
      SZA 
      ISZ LDING     WORRY ABOUT LEADING 0'S 
      LDB LDING 
      SZB,RSS 
      JMP XCV4      IGNORE THEM 
      ISZ FDIG
      SSA           IN CASE OF -DIVISOR 
      CMA,INA 
      ADA B60       MAKE ASCII CHARACTER
      JSB XPUT
      JMP XCVAS,I   EOB, LOSE EXIT
XCV4  CLB 
      LDA DIVSR     FIND NEXT DIGIT POSITION
      DIV RADIX 
      SZA 
      JMP XCV3
      STA LDING 
      LDA FDIG
      SZA 
      JMP *+4 
      LDA B60 
      JSB XPUT
      JMP XCVAS,I 
      ISZ XCVAS 
      JMP XCVAS,I 
      HED CONSTANTS,LINKS,STORAGE & MESSAGES
.10   DEC 10
.13   DEC 13
.2    DEC 2 
.20   DEC 20
.4    DEC 4 
.5    DEC 5 
.56   DEC 56
.64   DEC 64
.M24  DEC -24 
.M57  DEC -57 
ABORT ASC 6,$FTN-ABORTED
B110  OCT 110 
B210  OCT 210 
B410  OCT 410 
B55   OCT 55
B6    OCT 6 
B60   OCT 60
BNAME ASC 3,        BLANK FILE NAME 
DIVSR NOP           DIVISOR FOR XDCAS 
ERR   ASC 6,FMP ERROR  -
ERR#  ASC 2,0000    5 DIGIT FMP ERROR 
      OCT 30040      CODE STUFFED HERE
      ASC 1,
FNAME ASC 3,        FILE NAME STUFFED HERE
FDIG  NOP           HOLDS DIGITS FOR XDCAS
GOPTS OCT 425       GTFIL OPTIONS 
LDING NOP           LEADING ZEROS FOR XDCAS 
M400  OCT -400
PBUFF BSS 5         BUFFER FOR RMPAR PARAMETERS 
PNT01 DEF ERR#      LINK TO FMP ERROR # IN ERROR MSG. 
PNT06 DEF BNAME     LINK TO BLANK FILE NAME 
PNT07 DEF AI        LINK TO 1ST GTFIL ARRAY IN COMMON 
RADIX NOP           NUMBER BASE FOR XDCAS 
SEG1  ASC 3,FTN1
VAL   NOP           ACCUMULATOR FOR XDCAS 
XDADR NOP           DESTINATION BUFFER ADDRESS
XDCNT NOP           DESTINATION CHARACTER COUNT 
XDLNG NOP           DESTINATION CHARACTER LENGTH
      END FTN0