*
* $Id: pairpak.s,v 1.1 1996/05/06 15:33:29 mclareni Exp $
*
* $Log: pairpak.s,v $
* Revision 1.1  1996/05/06 15:33:29  mclareni
* Move CDC assembler routines expair and pairpak from isatape to utils/cdc
*
* Revision 1.2  1996/04/26 09:52:27  mclareni
* To prepare for new versions of isajet, change the isajet directory to code
* and the isajet714 directory to isajet, as for other packages.
* Modify all #includes and the main Imakefile to cater for this.
*
* Revision 1.1.1.1  1996/03/08 17:27:54  mclareni
* Isajet714
*
*
#include "isajet/pilot.h"
#if defined(CERNLIB_CDCPACK)
          IDENT  PAIRPAK
* 7/7/75  FIXED BUG THAT CAUSED NUMBERS OF FORM  N*2**-31 (1.LE.N.LT.2)
* TO BE PACKED WITH ZERO EXPONENT BITS, HENCE TO BE INCORRECTLY CALLED
* INTEGERS BY EXPAIR.  AT THE EXPENSE OF SHIFTING RANGE OF 23-BIT
* PRECISION PACKING TO 2**32 TO 2**-30 (WHERE IT WAS INTENDED TO BE
* FROM 2**31 TO 2**-31), FIX KEEPS FORMAT COMPATIBLE WITH PREVIOUS
* VERSION OF PAIRPAK, AND EXPAIR DOES NOT NEED TO BE CHANGED.
* VERSION OF 25 MARCH 75, PRESERVES DISTINCTION BETWEEN +ZERO AND -ZERO
* CALL PAIRPAK(W1,W2,OUTW,IALARM) PACKS W1, W2 IN LEFT, RIGHT HALVES OF
* OUTW, RESPECTIVELY.
* ALSO SETS IALARM = 0 IF W1, W2 WERE BOTH OKAY, MEANING EITHER
* INTEGERS OR DEFINITE AND FINITE REALS. SETS IALARM = 1 IF W1 WAS
* INFINITE OR INDEFINITE, IALARM = 2 IF W2 WAS SO, IALARM = 3 IF BOTH
* W1 AND W2 WERE SO.
*
* IF EXPONENT BITS ARE ALL 0 (OR ALL 1 IF NUMBER IS NEGATIVE), IT IS
* CALLED AN INTEGER AND CHOPPED TO ITS LOWEST 23 BITS (PLUS SIGN)
* REALS IN RANGE 2**-31 TO 2**31 IN MAGNITUDE ARE COMPRESSED TO GIVE 24
* BITS SIGNIFICANCE.  REALS OUTSIDE THIS RANGE HAVE 13 SIGNIFICANT BITS.
* ZEROES, INFINITIES AND INDEFINITES ARE PRESERVED WITH PROPER SIGN.
*
* WORKS FOR RUN OR FTN CALLING SEQ. IF ASSEMBLED UNDER CORRESPONDING
* COMPILER
*
* J. KOPP, BROOKHAVEN NATIONAL LABORATORY, 22 MARCH 1975
*
          ENTRY  PAIRPAK
+VFD42/7HPAIRPAK,18/4
PAIRPAK   DATA   0
          IFLE   *F,1
          SA1   B1            FETCH FIRST ARG. = W1
          ELSE
          SA2    A1+1         GET LOC W2 TO X2
          SA3    A1+2         LOC OUTW
          SA1    X1           FETCH FIRST ARG = W1
          ENDIF
          SB6    1            ALARM BIT FOR ARG1
          MX6    0            TOTAL ALARMS TO DATE
          RJ     TRIMUP       TEST W1 FOR REAL OR INTEGER AND NEATEN UP
          BX7    X1           W1 TO GO IN LEFT HALF
          IFLE   *F,1
          SA1    B2           FETCH SECOND ARG = W2
          ELSE
          SA1    X2           FETCH SECOND ARG = W2
          ENDIF
          SB6    B6+B6        ALARM BIT FOR ARG2
          RJ     TRIMUP       PERFORM THE TESTING AND PURIFICATION
          LX1    30           MOVE FROM LEFT HALF TO RIGHT HALF
          BX7    X7+X1
          IFLE   *F,1
          SA6    B4
          SA7   B3
          ELSE
          SA1    A3+1         FETCH LOC IALARM
          SA7    X3
          SA6    X1           DELIVER ALARM
          ENDIF
          JP     PAIRPAK
*
* TEST WORD IN X1 FOR REAL OR INTEGER, CHOP SUITABLY, RETURN IN LEFT
* HALF X1. ASSUMES FLOATING-POINT ARGUMENTS ARE NORMALIZED
* USES X0,X4,X6
TRIM2     MX0    29                REMOVE LOW 30 BITS AND CLEAR SIGN BIT
          LX0    59
          BX1    X1*X0
TRIM1     BX1    X1+X5             ATTACH SIGN BIT
TRIMUP    DATA   0
          MX5    0                 PREPARE + SIGN BIT IN X5
          PL     X1,TRIM3
          BX1    -X1               WORK WITH ABSOLUTE VALUE
          MX5    1                 SET SIGN BIT
TRIM3     OR      X1,TRIM3A        IF INFINITE, SET ALARM BIT + PROCEED
          DF     X1,TRIM3B         SAME IF INDEFINITE
TRIM3A    SX6     B6+X6            SET ALARM BIT, INPUT INF. OR INDEF.
TRIM3B    MX0    12                LOOK AT EXPONENT FIELD
          BX4    X1*X0
          ZR     X4,TRIM4          IF EXP. FIELD ZERO HAVE AN INTEGER
          UX4    B5,X1             UNPACK
          LX4    1                 SQUEEZE NORMALIZE BIT OUT OF CHAR.
          BX4    -X0*X4
* (7/7/75 - CONSTANT ADDED BELOW CHANGED TO 77 FROM 78.  THIS KEEPS THE
* FORMAT SAME AS BEFORE, WHERE WE ADDED 78 BUT A BUG CAUSED PACKED
* RESULT TO HAVE EXPONENT 1 LESS THAN INTENDED)
          SB5    B5+77             ADD OUR OWN BIAS
          GE     B0,B5,TRIM7
          SB7    63
          GE     B5,B7,TRIM7       SAME IF OVERFLOW, INFINITE, INDEF.
          PX1    B5,X4             REPACK WITH OUR OWN EXPONENT BIAS
* THE FOLLOWING LEFT SHIFT WILL PUT 6600 EXPONENT BIAS BIT IN LOW END
* WHERE IT WILL BE TRIMMED OFF.
          LX1    5     IDEA IS TO SHORTEN EXP. FIELD TO 6 BITS (WITH...
          JP  TRIM2    RESTRICTION OF ALLOWED RANGE) TO GAIN 6 SIGNIF
*                      BITS TOTAL
TRIM4     LX1    30                INTEGER
          MX0    7                 CHOP LEFT 7 BITS, MAX INTEGER 23 BITS
          BX1    -X0*X1
          JP     TRIM2             ATTACH SIGN
* REAL OUT OF ALLOWED RANGE FOR SPECIAL EXPONENT BIAS WHICH ALLOWS
* SAVING EXTRA SIGNIFICANT BITS.  PACK BELOW DUMMY EXPONENT 63 WHICH
* SERVES AS A FLAG FOR OUT-OF-RANGE (INCLUDING INFINITE AND INDEF) REALS
TRIM7     UX1    B5,X1             GET BACK ORIGINAL 6600 EXPONENT
          PX1    B5,X4             PACK WITH LOPPED CHARACTERISTIC
          AX1    6            PACK BELOW DUMMY EXPONENT 63
          MX0    7
          BX1    X1+X0
          JP     TRIM2
          END
#endif