*CATALOG NO. 705004 SIGMA 5/7 F4LIB 9DEXP
* SDS SIGMA 7 FORTRAN IV - 9DEXP  (F4LIB)                      05/24/68
*
*  DOUBLE PRECISION EXPONENTIAL                                 9DEXP
*  DOUBLE PRECISION NEGATIVE POWER OF TWO                       7DEXP2
*  DOUBLE PRECISION POSITIVE POWER OF TWO                       7DEXP1
*
         SYSTEM   SIG7FDP
         SPACE    3
*  IF A HIGH SPEED MAP-REENTRANT PROCEDURE IS DESIRED, SET R TO 2.
*  IF A NON-MAP-REENTRANT PROCEDURE IS DESIRED, SET R TO 1.
*
R        SET      2                 HI-SPEED, REENTRANT ONLY VIA MAP
         SPACE    3
         CSECT      0
         SPACE    3
*  CONTEXT
*
1A2      BOUND    8
1A3      SPACE    3
*  CONSTANTS
*
BIG      DATA     X'46000000',X'80000000' TO SCALE INTEGER AND ROUND
C1MC2    DATA     X'42AEAC4F',X'BD4C20D9' 174.67308,-179.87169
MLN2INV  DATA     X'BEE8EAB8',X'9AD47D02' -1/LN(2)
P00      DATA,8   FL'1513.9067990543389159'
P01      DATA,8   FL'20.202065651286927228'
P02      DATA,8   FL'-0.023093347753750233624'
Q00      DATA,8   FL'4368.2116627275584985'
Q01      DATA,8   FL'233.18421142748162379'
OPN      FSL,R10  R8
         FAL,R10  R8
HALF     DATA,8   FL'0.5',FL'-0.5'  +- 0.5
TABLE    DATA,8  FL'2',FL'-2',FL'4',FL'-1',FL'8',FL'-.5',FL'16',FL'-.25'
FLZRO    DATA,8   FL'0'             FLOATING ZERO                       EXP
FLONE    DATA,8   FL'1'             FLOATING ONE                        EXP
         PAGE
*   THIS RUN TIME ROUTINE HAS BEEN COMPLETELY REWRITTEN TO FIX
*   SIDR SIG7-2986. WHEN EXPOENTATION IS CALLED FOR,  COBOL FORCES
*   FLOATING POINT DOUBLE PERCISION  OPERANDS AND USES THE  FORTRAN
*   ROUTINES  9DLOG AND 9DEXP  TO ACCOMPLISH THE EXPOENTIATION.
*     LET
*     X =  V1 ** V2
*
*     LN (X) =   V2 * LN (V1)
*
*     X =  ANTILOG ( V2 * LN (V1))
*
*          IT IS  NOT  POSIBLE  BY THIS METHOD  TO RAISE  A NEGATIVE
*          NUMBER TO A POWER  AS THE  LOG OF A NEGATIVE NUMBER IS
*          UNDEFINED. HOWEVER  IN EQUATION  (1) IT IS POSSIBLE FOR
*          V1 TO BE NEGATIVE  PROVIDED V2 IS AN INTERGER. THIS
*          ROUTINE  LETS  V1 BE  NEGATIVE WHEN  V2 IS AN INTERGER.
*
*   THE FORTRAN ROUTINE 9DLOG  AND 9DEXP ARE USED TO PERFORM THE
*   EXPOENTATION
*
*   V1  IS IN R8,R9   V2  IS IN  R12,R13  ENTRY IS VIA  R11             C:EXP
*     R8,R9  CONTAIN  THE ANSWER AT  EXIT.                              C:EXP
*   ALL REFERENCES TO R6 AND R8 WERE CHANGED IN JUNE 1971
*   TO BE COMPATIBLE WITH CHANGES FOR VARIABLE RECORDS
*   FORMERLY V1 WAS IN R6,R7
*   NOW V1 IS IN R8,R9
*                                                                       C:EXP
         DEF      C:EXP
C:EXP    STW,11   RETURN            SAVE RETURN                         C:EXP
         FAL,8    FLZRO                                                 EXP
         BEZ      BR12              BASE IS ZERO                        EXP
         FAL,12   FLZRO                                                 EXP
         BEZ      BR13              EXP = 0                             EXP
BR0      RES      0                                                     EXP
         STD,12   SPOWER            SAVE POWER                          C:EXP
         LI,R6    0                                                     C:EXP
         STW,R6   SIGNER            INITILIZE SIGN SWITCH TO (NEG)      C:EXP
         MTW,0    R8                TEST VARIABLE                       C:EXP
         BCS,1    BR1               BRANCH IF NEGATIVE                  C:EXP
         LD,R8    R8                STORE IN R8 FOR CALL TO 9DLOG       C:EXP
         MTW,1    SIGNER            SET SIGN SWITCH TO (POS)            C:EXP
         B        BR5                                                   C:EXP
BR1      LCD,R8   R8                STORE POSITIVE VALUE IN R8          C:EXP
         LAD,12   12                GET ABSOLUTE VALUE OF POWER         C:EXP
*   THE FOLLOWING TEST THE POWER  FOR BEING AN  INTERGER  ODD OR        C:EXP
*   EVEN                                                                C:EXP
         LB,6     12                USE CHARACTERISTIC TO               C:EXP
         AI,6     -62               DETERMINE HOW MANY POSITIONS        C:EXP
         SLS,6    2                 TO SHIFT  FLOATING NUMBER           C:EXP
         AI,6     -1                                                    C:EXP
         SLD,12   0,6               SHIFT                               C:EXP
         OR,12    NOBIT             TEST IF ODD OR EVEN                 C:EXP
         BCS,1    %+2               BRANCH IF ODD                       C:EXP
         MTW,1    SIGNER            SET SIGN SWITCH TO (POS)            C:EXP
         SLD,12   1                 SHIFT ONE MORE                      C:EXP
         OR,13    NOBIT             ARE ANY BITS ON                     C:EXP
         BNE      BR4               YES BRANCH                          C:EXP
         OR,12    NOBIT             ARE ANY BITS ON                     C:EXP
         BE       BR5               NO BRANCH                           C:EXP
BR4      MTW,1    SIGNER            POWER IS NOT AN INTERGER            C:EXP
         LCD,8    8                 REVERSE SIGN OF VARIBABLE TO (NEG)  C:EXP
BR5      BAL,6    9DLOG             TAKE LOG                            C:EXP
         FML,8    SPOWER            MULTIPLY BY POWER                   C:EXP
         BAL,6    9DEXP             TAKE  ANTI LOG                      C:EXP
         LW,6     SIGNER            TEST SIGNER                         C:EXP
         BNE      BR7               BRANCH  DO NOT  REVERSE             C:EXP
         LCD,R8   R8                REVERSE SIGN                        C:EXP
         B        BR8                                                   C:EXP
BR7      LD,R8    R8                DONT REVERSE SIGN                   C:EXP
BR8      LW,R6    R8
         AND,R6   FRACTN            R6 = FRACTION FROM R8
         CI,R9    0                 TEST R9 TO SEE IF ROUNDING NECESSARY
         BE       *RETURN           R9 = 0, EXIT
         BG       BR10
BR9      CI,R9    -256              R9 < 0                              EXP
         BLE      *RETURN
         CW,R6    FRACTN              IF > -16,
         BE       BR9C
         AI,R8    1                   ADD 1 TO R8 AND SET R9 TO 0
         B        BR11                UNLESS FRACTION = FFFFFF
BR9C     AW,R8    L(X'00100001')      IN WHICH CASE ADD 100001 TO R8
         B        BR11                (E.G., WHERE 16 = 41FFFFFF)
BR10     CI,R9    256               R9 > 0                              EXP
         BGE      *RETURN
         CI,R6    0                   IF < 16, SET R9 TO ZERO
         BE       *RETURN             UNLESS FRACTION = 000000
BR11     LI,R9    0                   (E.G., WHERE -16 = BE000000+)
         B        *RETURN
BR12     FAL,12   FLZRO             CHECK EXPONENT                      EXP
         BGZ      *RETURN           0 ** A = 0
         BLZ      BR0               0 ** (-A) = MAX                     EXP
BR13     LD,8     FLONE             A ** 0 = 1                          EXP
         B        *RETURN                                               EXP
         BOUND    8                                                     C:EXP
SPOWER   RES      2                                                     C:EXP
SIGNER   RES      1                                                     C:EXP
NOBIT    DATA     0                                                     C:EXP
RETURN   RES      1                                                     C:EXP
FRACTN   DATA     X'00FFFFFF'       FRACTION OF FLOATING POINT NUMBER
         PAGE
9DEXP    RES      0                 MAIN ENTRY, USED BY 9CDEXP, 9CDSIN
         CLM,R8   C1MC2             CHECK RANGE
         BCR,6       2A10
         BCS,4    1A1               UNDERFLOW
         BAL,R2      9ERROR
         GEN,16,4,1,1,10 -2,6,1,0,1 DP OVERFLOW, LEVEL 6 ERROR
         TEXT     '9DEXP'           ROUTINE NAME
1A1      SD,R8    R8                SET UNDERFLOW RESULT TO 0.0D0
         B        0,R6              RETURN
2A10     RES       0
         AI,R8       0
         BGEZ      4A10
         FML,R8   MLN2INV           X=-X/LN(2)
         SPACE    3
7DEXP2   RES      0                 NEGATIVE POWER OF 2.0 ENTRY
*                                   USED BY 9RWRDD
         LI,R2      1
        B        6A10
4A10       RES         0
         FML,R8     LN2INV
         SPACE    3
7DEXP1   RES      0                 POSITIVE POWER OF 2.0 ENTRY
*                                   USED BY 9DSINH, 9PWRDD
         LI,R2      0
6A10       RES     0
         STD,R8     8T0,RS
         LFI      1                 SET UNNORMALIZED
         FAL,R8   BIG               SCALE INTEGER
         LI,R9    0                 CLEAR FRACTION
         LFI      0                 RESET UNNORMALIZED
         LW,R12   R8                COPY J
         SFS,R8   6                 NORMALIZE
         FSL,R8   8T0,RS            -U, POST SHIFTS
         STD,R8   8T0,RS            COPY -U
         FML,R8       8T0,RS
         STD,R8   8T2,RS            COPY V
         LD,R10   8T2,RS            COPY V
         FAL,R10  Q01               RATIONAL
         FML,R10  8T2,RS
         FAL,R10  Q00
         FML,R8   P02
         FSL,R8   P01               APPROXIMATION
         FML,R8   8T2,RS
         FSL,R8   P00
         FML,R8   8T0,RS
8A1      EXU      OPN,R2            -+ U
         FDL,R8   R10               +- (2.0 ** (+-U) )/2.0 -+ 0.5
         FAL,R8   HALF,R2           +- (2.0 ** (+-U) )/2.0
         LI,R13   0                 CLEAR
         SLD,R12  -2                J/4
         SCS,R13  3                 MOD(J/4)*2
         AW,R2    R13               INDEX TO TABLE
         SLD,R12  -8                POSITION J/4 TO EXPONENT
         AW,R8    R13               16.0**( +- J/4)
9A1      FML,R8   TABLE,R2          FINAL FACTOR
9A3      B        0,R6              RETURN
         SPACE    3
*  APPROXIMATE TIMING IN MICROSECONDS
*
*  X > 174.67308             9      TO ENTER ERROR REPORTER
*  X < -179.4969            12      TO RETURN 0.0D0
*  OTHER X (AVG.)          184      217 IF REENTRANT
*  7DEXP2                  173      190 IF REENTRANT
*  7DEXP1                  172      189 IF REENTRANT
         SPACE    3
         BOUND    8
8T0    DATA    0
8T1    DATA    0
8T2    DATA    0
8T3    DATA    0
8T4    DATA    0
8T5    DATA    0
8T6    DATA    0
8T7    DATA    0
8T8    DATA    0
8T9    DATA    0
8T10   DATA    0
8T11   DATA    0
8T12   DATA    0
8T13   DATA    0
8T14   DATA    0            15
8T15   DATA    0            15
8T16   DATA    0            15
8T17   DATA    0            15
         PAGE
* SDS SIGMA 5/7 FORTRAN IV - 9ERROR (F4LIB)      #705065    3/7/68
*
*     9 E R R O R     -     MATH LIBRARY ERROR REPORTING SUBROUTINE
*
*              WHEN IMPROPER ARGUMENTS CAUSE OVERFLOW, LOSS OF
*              SIGNIFICANCE, OR UNDEFINED RESULTS IN A MATH ROUTINE,
*              THE MATH ROUTINE CALLS 9ERROR, WHICH DOES 3 THINGS:
*
*              1.  PREPARE A DEFAULT RESULT IN THE APPROPRIATE
*                  REGISTER.
*
*              2.  CONSTRUCT AN ERROR MESSAGE EXPLAINING BOTH THE
*                  CAUSE OF THE ERROR AND THE RECOVERY.
*
*              3.  CALL 7ERROR, WHICH WILL PRINT THE MESSAGE AND
*                  THEN DECIDE, ON THE BASIS OF THE SEVERITY,
*                  WHETHER TO ABORT OR RETURN TO THE USER (OF THE
*                  MATH ROUTINE) WITH THE DEFAULT RESULT.
*
*              CALLING SEQUENCE:  (LL)  =  EXIT FROM MATH ROUTINE
*                                 BAL,LE   9ERROR
*                                 GEN,16,4,1,1,10     -N,SEV,D,C,DEF
*                                 TEXT     'MATHNAME'
*
*              WHERE:  N   =  CODE NUMBER FOR FIRST PART OF MESSAGE
*                      SEV =  ERROR SEVERITY
*                      D   =  1 IF PRECISION IS DOUBLE
*                      C   =  1 IF COMPLEX (OR DOUBLE COMPLEX)
*                      DEF =  CODE NUMBER FOR DEFAULT RESULT
*                                        AND SECOND PART OF MESSAGE
*
*                      VALUES FOR N AND DEF ARE EXPLAINED BELOW
*
*              9ERROR RETURNS DIRECTLY TO THE CALLER OF THE MATH
*              ROUTINE.  THUS IT USES LE ONLY TO LOCATE THE ARGS.
*
*              NOTE: THE NAME 9ERROR IS MISLEADING; IT SHOULD HAVE
*              BEEN CALLED 7MERROR (MATH ERROR ROUTINE), SINCE IT IS
*              ONLY REFERENCED BY OTHER LIBRARY ROUTINES.  THIS NAME
*              IS A CARRY-OVER FROM THE 9300.
*
*
*     R E G I S T E R S    A N D    P A R A M E T E R S
*
LA       EQU      4                 LINK, ALPHA
LL       EQU      6                 LINK, LIBRARY
AD       EQU      8                 ACCUMULATOR, DOUBLE
AD0      EQU      AD                ACCUMULATOR, DOUBLE - WORD 1
AR       EQU      AD                ACCUMULATOR, REAL
AC       EQU      AD                ACCUMULATOR, COMPLEX
AK0      EQU      AD                ACCUMULATOR, KOMPLEX - WORD 1
AD1      EQU      AD+1              ACCUMULATOR, DOUBLE - WORD 2
AI       EQU      AD1               ACCUMULATOR, INTEGER
AK2      EQU      AK0+2             ACCUMULATOR, KOMPLEX - WORD 3
*
OVNEG    EQU      X'002'            OVERFLOW NEGATIVE BIT
OVINT    EQU      X'004'            OVERFLOW POSITIVE BIT
DEFMASK  EQU      X'3FF'            ALL DEFAULT BITS
DBIT     EQU      X'800'            DOUBLE BIT
*
*              ALTERS REGISTERS 2,4,6,8-11
*              PRESERVES REGISTERS 0,1,3,5,7,12-15
         PAGE                       DHO
*
9ERROR   BAL,LA   XCHALPHA          SAVE THE ALPHA REGISTERS
         LW,10     0,LE         PICK UP 'GEN'  CODE  WORD ARG
         LW,EN    LE
         AI,EN    1                 EN = LE+1 = LOC OF ENTRY NAME
*
*              NOW:  (EL) = (LL) = LOC OF CALL ON MATH ROUTINE
*                    (EN) = LOCATION OF 'TEXT' NAME OF MATH ROUTINE
*                    LE IS NO LONGER NEEDED
*
         BAL,LE   7ERRHEAD          PRINT ERROR HEADING
         LCH,BL      10           GET N (CODE  NUMBER)
         LW,BL    MSG1-1,BL         GET POINTER TO ERROR MESSAGE
         LB,NC    BL                GET CHAR CNT FROM 1ST BYTE OF PNTR
         BAL,LE   7PAC              PRINT FIRST PART OF MESSAGE
*
         CI,10     DEFMASK       DOES DEFAULT  CODE=  0
         BANZ     1E1               NO, MUST BE 1, 2, OR 4
*
*              DEF = 0:  NO SIGNIFICANCE; RESULT = 0
*
         LI,AD0   0                 AD0 = AR = AC0 = AK0 = 0
         LI,AD1   0                 AD1 =      AC1 = AK1 = 0
         LI,BL    BA(NOSIGMSG)
         BAL,LE   7PRQ              PRINT NO SIGNIFICANCE MESSAGE
         B        1E5               FINISH UP
*
1E1      LI,BL    BA(OVFLOMSG)      PRINT OVERFLOW MESSAGE (OK FOR
         BAL,LE   7PRQ                POSITIVE, NEGATIVE, AND INTEGER)
*
       CI,10    OVNEG     DOES DEF = 2
         BAZ      1E2               NO, MUST BE 1 OR 4
*
*              DEF = 2:  OVERFLOW; RESULT = MAXIMUM NEGATIVE
*
         LCD,AD   LARGEPOS          AD = AR = AC = AK0,1 = LARGE NEG
         LI,BL    BA(NEGMSG)        TACK ON 'NEGATIVE' TO END OF
         BAL,LE   7PRQ                 OVERFLOW MESSAGE.
         B        1E3               GO INVOKE OVERFLOW
*
*              DEF = 1 OR 4:  OVERFLOW; RESULT = MAXIMUM
*
1E2      LD,AD    LARGEPOS          AD = AR = AC = AK0,1 = AI =
*                                     LARGE POSITIVE VALUE
         CI,10    OVINT             DOES DEF = 4
         BANZ     1E5               YES, INTEGER OVERFLOW, ALL SET
*
*              DEF = 1 OR 2.  AD = AR = LARGE POS OR NEG VALUE
*
*              SINCE THE TRAP HANDLER (IN 9INITIAL) DOESN'T CARE
*              WHETHER THE OPERATION IS SINGLE OR DOUBLE PRECISION,
*              IT DOESN'T MATTER HOW WE INVOKE IT.  IF IT WAS DOUBLE,
*              THE 'MAXIMUM' RETURNED IS NOT A TRUE MAXIMUM, BUT
*              IT'S CLOSE.
*
1E3      FMS,AR   LARGEPOS          INVOKE OVERFLOW
*
1E5      LI,CH    '.'
         BAL,LE   7PRC              PUT PERIOD ON END OF MESSAGE
*
        STH,10     ES
         SLS,ES   -28               GET ERROR SEVERITY INTO ES
         LI,BL    BA(8MSGBUF)       POINTER TO CONSTRUCTED MESSAGE
         LD,AK2   AK0               IN CASE DBL CPX, AK2,3 = AK0,1
         BAL,LE   7ERRTEXT          PRINT MESSAGE & ABORT OR RETURN
         BAL,LA   XCHALPHA          RESTORE THE ALPHA REGISTERS
*
*              NOW RETURN, NOT TO THE MATH ROUTINE, BUT TO THE USER OF
*              THE MATH ROUTINE.  IN THE CASE OF A STANDARD DRIVER
*              (SUCH AS SQRT) THIS WILL EXIT BACK THREE LEVELS.
*
         B        0,LL              EXIT
         PAGE
*
*              SAVE/RESTORE THE ALPHA REGISTERS
*
*              HOPEFULLY, THERE CAN BE NO CONFLICT BETWEEN THIS USE
*              OF 8TALPHA AND THAT OF THE I/O PACKAGE, SINCE THEY
*              CANT EVER BE IN USE AT THE SAME TIME.
*
XCHALPHA XW,1     8TALPHA+0
         XW,3     8TALPHA+1
         XW,5     8TALPHA+2
         XW,7     8TALPHA+3
         B        0,LA
         PAGE
*
*              THE MESSAGE PROC IS USED TO GENERATE A TABLE OF
*              POINTERS TO ERROR MESSAGES.
*
MESSAGE  CNAME
         PROC
LF       GEN,8,5,19     AF(2)-AF(1),0,AF(1)
         PEND
*
*              THE CODE NUMBER N IS USED TO SELECT ONE OF THE
*              FOLLOWING POINTERS.  EACH POINTER CONTAINS A CHARACTER
*              COUNT IN THE FIRST 8 BITS AND A BYTE LOCATION IN THE
*              LAST 19 BITS.  N MAY RANGE FROM 1 TO 9, WITH
*              CORRESPONDING MESSAGES, AS SHOWN BELOW.
*
*                  START    END+1         MESSAGE
*                  -----    -----         -------
MSG1     MESSAGE  BA(M1)+0,BA(M3)+1  'ZERO OR NEGATIVE ARGUMENT'
MSG2     MESSAGE  BA(M3)+1,BA(M5)+0  'MAGNITUDE OF ARGUMENT TOO LARGE'
MSG3     MESSAGE  BA(M5)+0,BA(M6)+2  'ZERO ARGUMENTS'
MSG4     MESSAGE  BA(M2)+0,BA(M3)+1  'NEGATIVE ARGUMENT'
MSG5     MESSAGE  BA(M6)+2,BA(M7)+0  'ZERO TO NON-POSITIVE POWER'
MSG6     MESSAGE  BA(M4)+2,BA(M5)+0  'ARGUMENT TOO LARGE'
MSG7     MESSAGE  BA(M5)+0,BA(M6)+1  'ZERO ARGUMENT'
MSG8     MESSAGE  BA(M7)+0,BA(M8)+1  'SINGULARITY AT +OR- I'
MSG9     MESSAGE  BA(M8)+1,BA(M9)+3  'NEGATIVE TO NON-INTEGRAL POWER'
*
*              THESE MESSAGE STRINGS ARE PACKED TOGETHER TO SAVE
*              SPACE.  THE POINTERS ABOVE DEFINE THE RANGE OF EACH
*              MESSAGE.
*
M1       TEXT     'ZERO OR '
M2       TEXT     'NEGATIVE ARGUMEN'
M3       TEXT     'TMAGNITUDE O'
M4       TEXT     'F ARGUMENT TOO LARGE'
M5       TEXT     'ZERO ARGUMEN'
M6       TEXT     'TSZERO TO NON-POSITIVE POWER'
M7       TEXT     'SINGULARITY AT +OR- '
M8       TEXT     'INEGATIVE TO NON-INTEGRAL PO'
M9       TEXT     'WER'
         PAGE
*
*              EACH OF THE ABOVE MESSAGES IS FOLLOWED BY ONE OF THE
*              FOLLOWING MESSAGES, AS DETERMINED BY THE VALUE OF DEF.
*
*              DEF = 0: NO SIGNIFICANCE; RESULT = ZERO.
*                    1: POSITIVE OVERFLOW; RESULT = MAXIMUM.
*                    2: NEGATIVE OVERFLOW; RESULT = MAXIMUM NEGATIVE.
*                    4: INTEGER OVERFLOW; RESULT = MAXIMUM.
*
NOSIGMSG TEXTC    ', NO SIGNIFICANCE; RESULT = ZERO'
OVFLOMSG TEXTC    ', OVERFLOW; RESULT = MAXIMUM'
NEGMSG   TEXTC    ' NEGATIVE'
*
         BOUND    8
LARGEPOS DATA     X'7FFFFFFF',X'7FFFFFFF'
8MSGBUF  RES      32
8TALPHA  RES      16
8ABORTEX DATA     0
8ABRTSEV DATA     8
8TERROR  RES      16
* SDS SIGMA 5/7 FORTRAN IV - 7ERROR (F4LIB)      #705066    4/19/68
*
*
*     R U N - T I M E   E R R O R   R O U T I N E S
*
*
*             7 E R R O R           PRINT ERROR HEADING AND MESSAGE
*
*             7 E R R H E A D       PRINT ERROR HEADING
*
*             7 E R R T E X T       PRINT ERROR MESSAGE
*
*             7 E R R M A R K       PRINT ERROR, AND MARK CHARACTER
*
*             7 E R R I N I T       INITIALIZE ERROR MESSAGE BUFFER
*
*             7 P R C               PRINT CHARACTER
*
*             7 P R Q               PRINT QUOTE
*
*             7 P A C               PRINT ALPHAMERIC WITH COUNT
*
*             7 P H C               PRINT HEXADECIMAL WITH COUNT
*
*             7 P R L               PRINT LINE (ERROR MESSAGE BUFFER)
*
*             7 B U F O U T         PRINT BUFFER
*
*             7 B U F O U T C       PRINT BUFFER CONTAINING COUNT
         PAGE
*
*     A S S E M B L Y   P A R A M E T E R S
*
*
*     PROCS
*
          LOCAL     8ABRTSEV,8ABORTEX,8MSGBUF,8TERROR
*
GET      CNAME                      GET,P    Q
         PROC
LF       EQU      %                     IF P AND Q DIFFERENT REGS,
         DO       CF(2)~=AF(1)          GENERATE 'LW,P    Q'
         LW,CF(2) AF(1)
         FIN
         PEND
*
*     REGISTERS
*
X        EQU      1                 GENERAL INDEX REGISTER
LE       EQU      2                 LINK TO ALL ERROR ROUTINES
EN       EQU      5                 ERROR NAME
EL       EQU      6                 ERROR LOCATION
ES       EQU      4                 ERROR SEVERITY
BL       EQU      3                 BUFFER LOCATION
BB       EQU      3                 BUFFER BEGINNING
BP       EQU      5                 BUFFER POINTER
BE       EQU      7                 BUFFER END
AH       EQU      6                 ACCUMULATOR-HEX
NC       EQU      7                 NUMBER OF CHARACTERS
CH       EQU      4                 CHARACTER
R3        EQU       BL
*
*     MISCELLANEOUS PARAMETERS
*
NRCHARS  EQU      108               MAX. LINE LENGTH (7ERRMARK)
ADDRMASK EQU      X'0001FFFF'       ADDRESS FIELD MASK
         PAGE                       SPO
*
*     R U N - T I M E   E R R O R   R O U T I N E S
*
*
*     OUTPUT ERROR HEADING
*
*              EL =      ERROR LOC
*              EN =      ADR OF 1ST WORD OF 2-WORD ERROR NAME
*              BAL,LE    7ERRHEAD
*
*
*        PRINTS TWO LINES ON THE 'DO' DEVICE: A BLANK LINE, AND A
*        LINE PROCLAIMING A FORTRAN RUN TIME ERROR.  THIS LINE
*        CONTAINS THE 8-CHARACTER NAME SPECIFIED BY EN, AND THE
*        LOCATION SPECIFIED BY EL.
7ERRHEAD STW,LE   HEADLE            SAVE LINK
         STW,X    SAVEX             SAVE X
         STW,EL   SAVEEL            SAVE EL
         STW,NC   SAVENC            SAVE NC
*
*        M:WRITE  M:DO,(BUF,BLANKS),(SIZE,1),(WAIT)
*
         CAL1,1   BLANKFPT          OUTPUT BLANK LINE
         BAL,LE   7ERRINIT          INITIALIZE MESSAGE BUFFER
         LI,BL    BA(HEADMSG1)      BUILD 1ST PART OF MESSAGE
         BAL,LE   7PRQ
         GET,BL   EN                BUILD ERROR NAME
         SLS,BL   2
         LI,NC    8
         BAL,LE   7PAC
         LI,BL    BA(HEADMSG2)
         BAL,LE   7PRQ
         GET,EL   AH                BUILD ERROR LOCATION
         AND,EL   =ADDRMASK
         LI,NC    5
         BAL,LE   7PHC
         LI,BL    BA(HEADMSG3)
         BAL,LE   7PRQ
         BAL,LE   7PRL              PRINT THE MESSAGE
         LW,X     SAVEX             RESTORE X
         LW,EL    SAVEEL            RESTORE EL
         LW,NC    SAVENC            RESTORE NC
         B       *HEADLE            EXIT
HEADMSG1 TEXTC    'COBOL   RUN-TIME ERROR IN'''
HEADMSG2 TEXTC    ''' CALLED AT LOC X'''
HEADMSG3 TEXTC    '''.'
         PAGE
*
*     OUTPUT ERROR HEADING AND MESSAGE
*
*              EL =      ERROR LOC
*              EN =      ADR OF 1ST WORD OF 2-WORD ERROR NAME
*              BL =      BA(TEXTC  'ERROR MESSAGE')
*              ES =      ERROR SEVERITY LEVEL
*              BAL,LE    7ERROR
*
*        COMBINES THE FUNCTIONS OF 7ERRHEAD AND 7ERRTEXT.
*
7ERROR   LCI      3
         STM,LE   LEBLES            SAVE LINK, BL, ES
         BAL,LE   7ERRHEAD          OUTPUT ERROR HEADING
         LCI      3
         LM,LE    LEBLES            RESTORE LINK, BL, ES
*        FALLS INTO 7ERRTEXT        OUTPUT ERROR MESSAGE AND EXIT
*
*        .....
         PAGE
*
*     OUTPUT ERROR MESSAGE
*
*              BL =      BA(TEXTC  'ERROR MESSAGE')
*              ES =      ERROR SEVERITY LEVEL
*              BAL,LE    7ERRTEXT
*
*        PRINTS THE ERROR MESSAGE, THEN DETERMINES WHETHER TO
*        ABORT THE JOB OR RETURN, BASED ON THE ERROR SEVERITY.
*        A SEVERITY LEVEL OF 15 IS ALWAYS SUFFICIENTLY HIGH TO
*        CAUSE THE JOB TO ABORT.
*
7ERRTEXT STW,LE   TEXTLE            SAVE LINK
         STW,X    SAVEX             SAVE X
         STW,NC   SAVENC            SAVE NC
         BAL,LE   7BUFOUTC          OUTPUT ERROR MESSAGE
*
*        M:WRITE  M:DO,(BUF,BLANKS),(SIZE,1),(WAIT)
*
         CAL1,1   BLANKFPT          OUTPUT BLANK LINE
         LW,X     SAVEX             RESTORE X
         LW,NC    SAVENC            RESTORE NC
         CW,ES    8ABRTSEV          TEST SEVERITY
         BL      *TEXTLE
         LW,LE    8ABORTEX          IF ALTERNATE ABORT LOC GIVEN,
         BNEZ     0,LE                  GO TO IT
*
*        M:XXX
         CAL1,9   3                 ABORT
         PAGE
*
*     OUTPUT ERROR AND MARK CHARACTER
*
*              BB =      BA(BEGINNING OF BUFFER)
*              BP =      BA(MARK-CHARACTER)
*              BE =      BA(END OF BUFFER)
*              BAL,LE    7ERRMARK
*
*        PRINTS ALL OR PART OF THE BUFFER BOUNDED BY BB AND BE,
*        FOLLOWED BY A LINE CONTAING A VERTICAL BAR BENEATH THE
*        ERRONEOUS CHAR, WHOSE POSITION IS GIVEN BY BP.
*
7ERRMARK STW,LE   MARKLE            SAVE LINK
         SW,BP    BB                BP := P-M
         CI,BP    NRCHARS
         BGE      1Z1
         SW,BE    BB                P-M<108:  BE:=N-M+1
         AI,BE    1
         CI,BE    NRCHARS
         BG       1Z2               IF N-M+1>108,  BE:=108 AND PRINT
         B        1Z3               N-M+1<=108: PRINT
1Z1      AW,BP    BB                P-M>=108: BP:=P
         LW,BB    BE                BB:=N-107
         AI,BB    1-NRCHARS
         SW,BP    BB                BP:=P-(N-107)
         CI,BP    NRCHARS/2
         BGE      1Z2               IF P-(N-107)>=54, BE:=108 AND PRINT
         AW,BB    BP                P-(N-107)<54: BB:=P-54,
         AI,BB    -NRCHARS/2
         LI,BP    NRCHARS/2                  BP:=54.
1Z2      LI,BE    NRCHARS           BE:=108
1Z3      GET,BL   BB                PRINT BEGINNING AT (BB)
         GET,NC   BE                (BE) CHARACTERS
          BAL,LE    7PAC         BUILD MESSAGE
          BAL,LE    7PRL          PRINT LINE
         CI,BP    0                 (BP) = NR OF BLANKS BEFORE MARK
         BEZ      1Z5               SKIP IF (BP)=0
         LI,CH    ' '
1Z4      BAL,LE   7PRC              BUILD (BP) BLANKS
         BDR,BP   1Z4
1Z5      LI,CH    '|'               BUILD MARK CHAR
         BAL,LE   7PRC
         LW,LE    MARKLE            RESTORE LINK
         B        7PRL              PRINT MARK LINE AND EXIT
         PAGE
*
*     PRINT CHARACTER
*
*              CH =      CHARACTER
*              BAL,LE    7PRC
*
*        INSERTS THE GIVEN CHARACTER INTO THE ERROR MESSAGE BUFFER.
*
7PRC     MTB,1    8MSGBUF           BUMP CHAR COUNT
         LB,X     8MSGBUF           X := CHAR COUNT
         STB,CH   8MSGBUF,X         PUT CHAR INTO BUFFER
         B        0,LE              EXIT
         PAGE
*
*     PRINT QUOTE
*
*              BL =      BA(TEXTC  'QUOTE STRING')
*              BAL,LE    7PRQ
*
*        INSERTS THE GIVEN QUOTE STRING INTO THE ERROR MESSAGE BUFFER.
*
7PRQ     LB,NC    0,BL              NC := 1ST BYTE = CHAR COUNT
         AI,BL    1                 BL := LOC OF 1ST CHAR
*        FALLS INTO 7PAC            PRINT STRING AND EXIT
*
*        .....
         PAGE
*
*     PRINT ALPHAMERIC WITH COUNT
*
*              BL =      BA(1ST CHAR OF STRING)
*              NC =      NUMBER OF CHARS IN STRING
*              BAL,LE    7PAC
*
*        INSERTS THE STRING INTO THE ERROR MESSAGE BUFFER.
*
7PAC     STW,LE   PACLE             SAVE LINK
         CI,NC    0                 IF CHAR COUNT =0,
         BEZ      0,LE                  EXIT
2Z1      LB,CH    0,BL              GET NEXT CHAR
         BAL,LE   7PRC              PRINT IT
         AI,BL    1                 BUMP CHAR LOC
         BDR,NC   2Z1               COUNT CHARS
         B       *PACLE             EXIT
         PAGE
*
*     PRINT HEX WITH COUNT
*
*              AH =      HEXADECIMAL VALUE
*              NC =      NUMBER OF HEX DIGITS
*              BAL,LE    7PHC
*
*        CONVERTS THE HEX VALUE (RIGHT JUSTIFIED) INTO NC EBCDIC
*        CHARACTERS AND INSERTS THEM INTO THE ERROR MESSAGE BUFFER.
*
7PHC     STW,LE   PHCLE             SAVE LINK
         LCW,X    NC                COMPUTE SHIFT AMOUNT
         BEZ      0,LE              EXIT IF DIGIT COUNT =0
         SLS,X    2
         STW,AH   PHCAH             SAVE HEX VALUE
         SLS,AH   32,X              POSITION VALUE
3Z1      SCS,AH   4                 GET NEXT HEX DIGIT
         LW,CH    AH
         AND,CH   =X'F'
         AI,CH    '0'               CONVERT IT TO EBCDIC
         CI,CH    '9'
         BLE      3Z2
         AI,CH    -X'39'
3Z2      BAL,LE   7PRC              PRINT IT
         BDR,NC   3Z1               COUNT DIGITS
         LW,AH    PHCAH             RESTORE VALUE
         B       *PHCLE             EXIT
         PAGE
*
*     PRINT LINE
*
*              BAL,LE    7PRL
*
*        PRINTS THE ERROR MESSAGE BUFFER ON THE 'DO' DEVICE, THEN
*        RE-INITIALIZES THE ERROR MESSAGE BUFFER.
*
7PRL     STW,LE   PRLLE             SAVE LINK
         LI,BL    BA(8MSGBUF)       OUTPUT ERROR MESSAGE BUFFER
         BAL,LE   7BUFOUTC          *
         LW,LE    PRLLE             RESTORE LINK
*        FALLS INTO 7ERRINIT        INITIALIZE MESSAGE BUFFER AND EXIT
*
*        .....
         PAGE
*
*     INITIALIZE ERROR MESSAGE BUFFER
*
*              BAL,LE    7ERRINIT
*
*        INITIALIZES THE ERROR MESSAGE BUFFER TO THE EMPTY STATE.
*
7ERRINIT LI,X     0
         STB,X    8MSGBUF           CLEAR CHAR COUNT OF MESSAGE BUFFER
         B        0,LE              EXIT
         PAGE
*
*     OUTPUT BUFFER CONTAINING COUNT
*
*              BL =      BA(TEXTC  'QUOTE STRING')
*              BAL,LE    7BUFOUTC
*
*        PRINTS THE QUOTE STRING ON THE 'DO' DEVICE.
*
7BUFOUTC LB,NC    0,BL              NC := 1ST BYTE = CHAR COUNT
         AI,BL    1                 BL := LOC OF 1ST CHAR
*        FALLS INTO 7BUFOUT
*
*        ****
*
*        OUTPUT  BUFFER
*                 BL =  BA(1ST CHAR OF STRING)
*                 NC =  NUMBER OF CHARS IN STRING
*                 BAL,LE   7BUFOUT
*
*        PRINTS THE STRING ON THE 'DO' DEVICE
*
7BUFOUT  LW,X     BL
         AND,X    =3                X := BYTE DISPLACEMENT
         SLS,BL   -2                BL := WORD ADR
*        M:WRITE  M:DO,(BUF,*BL),*BL),(BTD,**),(SIZE,*NC),(WAIT)
         CAL1,1   WRITEFPT
*
         SLS,BL   2                 RESTORE BL
         OR,BL    X
         B        0,LE              EXIT
*
         PAGE
*
*     T E M P S
*
HEADLE   EQU      8TERROR+0         7ERRHEAD LINK
TEXTLE   EQU      8TERROR+1         7ERRTEXT LINK
MARKLE   EQU      8TERROR+2         7ERRMARK LINK
PACLE    EQU      8TERROR+3         7PAC LINK
PHCAH    EQU      8TERROR+5         7PHC VALUE
PHCLE    EQU      8TERROR+4         7PHC LINK
PRLLE    EQU      8TERROR+6         7PRL LINK
LEBLES   EQU      8TERROR+7         LE, BL, ES (FOR 7ERROR) - 3 WORDS
SAVEX    EQU      8TERROR+10        X TEMP
SAVEEL   EQU      8TERROR+11        EL TEMP
SAVENC   EQU      8TERROR+12        NC TEMP
         PAGE
*
*
*
*        BPM  FILE PARAMETER TABLES
*
WRITEFPT GEN,1,7,7,17    0,X'11',0,M:DO      M:WRITE  M:DO,;
         GEN,8,17,3,4    X'34',0,1,0                  (WAIT),;
         GEN,1,31        1,BL                         (BUF,*BL),;
         GEN,1,31        1,NC                         (SIZE,*NC),;
         GEN,1,31        1,X                         (BTD,*X)
*
BLANKFPT GEN,8,7,17      X'11',0,M:DO        M:WRITE  7:DO,;
         GEN,8,17,3,4    X'30',0,1,0                  (WAIT),;
         GEN,15,17       0,BLANKS                     (BUF,BLANKS),;
         GEN,15,17       0,1                          (SIZE,1)
*
         REF      M:DO
*
BLANKS    TEXTC     '   '
8TERROR      RES      13
        BOUND      8
8MSGBUF     RES     28
8TINIT     RES    7
8ABORTEX     DATA     0
8ABRTSEV     DATA    8
         PAGE
*CATALOG NO. 705002 SIGMA 5/7 F4LIB 9DLOG
*  SDS SIGMA 7 FORTRAN IV -  9DLOG (F4LIB)                      06/26/67
*
*  DOUBLE PRECISION NATURAL LOGARITHM                           9DLOG
*  DOUBLE PRECISION BASE 2 LOGARITHM                            7DLOG2
*  DOUBLE PRECISION NATURAL LOGARITHM (SPECIAL)                 7DLOG
*  DOUBLE PRECISION NATURAL LOGARITHM (SPECIAL)                 7DLOG1
*
         SPACE    3
*  IF A HIGH SPEED MAP-REENTRANT PROCEDURE IS DESIRED, SET R TO 2.
*  IF A NON-MAP-REENTRANT PROCEDURE IS DESIRED, SET R TO 1.
*
R        SET      2                 HI-SPEED, REENTRANT ONLY VIA MAP
*
R2       EQU      2                 LINK TO 9ERROR
R6       EQU      6                 LINK
R8       EQU      8                 DOUBLE PRECISION
R9       EQU      R8+1                ACCUMULATOR
R10      EQU      10                DOUBLE
R11      EQU      R10+1               TEMP
R12      EQU      12                DOUBLE
R13      EQU      R12+1               TEMP
         SPACE    3
*  CONTEXT
*
1A2      BOUND    8
RS       EQU      0                 NO USE OF STACK
1A3      SPACE    3
*  CONSTANTS
*
LN2INV   DATA     X'41171547',X'652B82FE' 1.44269504088896341=1/LN(2)
FOURRT2  DATA     X'415A8279',X'99FCEF32' 5.65685424949238019=4RT(2)
C6       DATA     X'437C60DA',X'FF254B2A' 1990.05346598213023
C5       DATA     X'432176F9',X'A61B2FED' 535.435949426841753
C4       DATA     X'42A427D5',X'CF33479E' 164.155606222171279
C3       DATA     X'4234C2EA',X'CF2396D6' 52.7613954030883501
C2       DATA     X'4212776C',X'516A782D' 18.4664965519843255
C1       DATA     X'417B1C27',X'70E727E0' 7.69437355139461230
C0       DATA     X'415C551D',X'94AE0BFD' 5.77078016355585460
D4       DATA     X'403920FC',X'72219AEB' .223159578193740481
D3       DATA     X'40492475',X'F6A71ECB' .285712597578022078
D2       DATA     X'40666666',X'6BBA27A8' .400000001240327858
D1       DATA     X'40AAAAAA',X'AAAA50E8' .666666666666347771
TWO      DATA,8   FL'2.0'
LN2      DATA     X'40B17217',X'F7D1CF7A' .693147180559945309=LN(2)
HLFQTR   DATA     X'800000',X'400000' 0.5,0.25 B7
C0C1     DATA     X'411185F1',X'40E9CA3B' 1.095,1/1.095=0.913242
ONE      DATA,8   FL'1.0'           1.0D0
MASK     DATA     X'80FFFFFF'       MANTISSA
X44      DATA     X'44000000'       EXPONENT
ATETH    DATA     X'200000'         0.125 B7
         SPACE    3
7DLOG2   RES      0                 LOG BASE 2.0 ENTRY
*                                   USED BY 9DLOG10, 9PWRDD
         AI,R6    X'80000'          INDICATE LOG BASE 2
         GOTO,R   1A2,1A1
1A1      SPACE    3
9DLOG    RES      0                 MAIN ENTRY
1A3      LFI      0                 SET FF=0, POST SHIFTS POSSIBLE
         CLM,R8   C0C1              X:1.095,1/1.095
         BCS,6    3A1               BRANCH IF OUTSIDE INTERVAL
         LD,R10   R8                COPY X
         FSL,R8   HALF              X-1.0D0
         FSL,R8   HALF                RETAINING SIGNIFICANCE
         FAL,R10  ONE               X+1.0D0
         SPACE    3
7DLOG    RES      0                 SPECIAL ENTRY FOR 9CDATAN
         FDL,R8   R10               Z=(X-1)/(X+1)
         STD,R8   8T0,RS            COPY Z
2A1      FML,R8   8T0,RS            Y=Z*Z
         STD,R8   8T2,RS            COPY Y
         FML,R8   D4                P
         FAL,R8   D3                 O
         FML,R8   8T2,RS              LY-
         FAL,R8   D2                  NOMIAL
         FML,R8   8T2,RS                OF
         FAL,R8   D1                      ODD
         FML,R8   8T2,RS                    POWERS
         FAL,R8     TWO                  OF
         FML,R8    8T0,RS                     Z
2A3      BDR,R6   0,R6              RETURN IF NATURAL LOGARITHM
         FML,R8   LN2INV            CONVERT TO BASE 2.0
         B        1,R6              RETURN, BDR HAS REDUCED R6 BY 1
         SPACE    3
7DLOG1   RES      0                 SPECIAL ENTRY
3A1      LB,R12   R8                EN=EXPONENT
         SLS,R12  10                SCALE B21
         AND,R8   MASK              EM=MANTISSA
         GOTO,R   3A3,3A2
3A2      BGZ      3A3
1A0      BAL,R2   9ERROR            ENTER ERROR REPORTER
         GEN,16,4,1,1,10 -1,7,1,0,2 DP NEG OVERFLOW, LEVEL 7 ERROR
         TEXT     '9DLOG'           ROUTINE NAME
3A3      RES      0                 PLACE
         CLM,R8   HLFQTR            EM : 0.5,0.25
         BCR,1    6A1               BRANCH IF 0.5 <= EM < 1.0
         BCR,4    5A1               BRANCH IF 0.25 <= EM < 0.5
         CW,R8    ATETH             EM : 0.125
         BGE      4A1               BRANCH IF 0.125 <= EM < 0.25
         SLD,R8   2                 EM=EM*4.0D0
         AI,R12   -X'10380'         REMOVE BIAS, SUBTRACT 3.5
         B        7A1               PROCEED
4A1      SLD,R8   1                 EM=EM*2.0D0
         AI,R12   -X'10280'         REMOVE BIAS, SUBTRACT 2.5
         B        7A1               PROCEED
5A1      AI,R12   -X'10180'         REMOVE BIAS, SUBTRACT 1.5
         B        7A1               PROCEED
6A1      SLD,R8   -1                EM=EM*0.5D0
         AI,R12   -X'10080'         REMOVE BIAS, SUBTRACT 0.5
7A1      EOR,R12  X44               INSERT EXPONENT
         SFS,R12  5                 NORMALIZE
         AD,R8    FOURRT2           EM+4*SQRT(2.)
         LCD,R10  FOURRT2           -4*SQRT(2.)
         FDL,R10  R8                Y-0.5D0
         FAL,R10  HALF              Y
         STD,R10  8T0,RS            COPY Y
         FML,R10  8T0,RS            Z=Y*Y
         STD,R10  8T2,RS            COPY Z
         LI,R13   0                 CLEAR LSH OF EN
         LD,R8    C6                POLYNOMIAL
7A       DO       6                   EXPANSION
         FML,R8   8T2,RS
         FAL,R8   C6+7A+7A
         FIN
         FML,R8   8T0,RS
         FAL,R8   R12               DLOG2(X)
7A3      BIR,R6   0,R6              RETURN IF LOG BASE 2
         FML,R8   LN2               CONVERT TO NATURAL LOGARITHM
         B        -1,R6             RETURN, BIR HAS INCREASED R6 BY 1
         SPACE    3
*  APPROXIMATE TIMING IN MICROSECONDS
*
*  X<=0.0                    6      TO ENTER ERROR REPORTER
*  .913242<=X<=1.095       140      170 IF REENTRANT
*  OTHER X                 199      232 IF REENTRANT
*  LOG BASE 2.0, 7DLOG2
*  .913242<=X<=1.095       153      168 IF REENTRANT
*  OTHER X                 195      211 IF REENTRANT
*  7DLOG                    93      107 IF REENTRANT
         SPACE    3
         END
