MINICERN/packlib/kernlib/kerngen/tcgens/sungs/ubunch.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:50:22  mclareni
   6 * Kernlib
   7 *
   8 *
   9       SUBROUTINE UBUNCH (MS,MT,NCHP)
  10 C
  11 C CERN PROGLIB# M409    UBUNCH          .VERSION KERNSUN  1.06  920511
  12 C ORIG. 22/09/88, JZ
  13 C
  14
  15       DIMENSION    MS(99), MT(99), NCHP(9)
  16 C-  - PARAMETER    (IBLAN1 = X'20202020')
  17       PARAMETER    (IBLAN1 =  538976288 )
  18 C-  - PARAMETER    (MASK1  = X'FF000000')
  19       PARAMETER    (MASK1  =  -16777216 )
  20
  21
  22       NCH = NCHP(1)
  23       IF   (NCH)             91,39,11
  24    11 NWT    = RSHIFT (NCH,2)
  25       NTRAIL = AND (NCH,3)
  26       JS     = 0
  27       IF (NWT.EQ.0)          GO TO 31
  28
  29 C--                Pack the initial complete words
  30
  31       DO 24  JT=1,NWT
  32       MT(JT) = OR (OR (OR (
  33      +                   AND(MS(JS+1),MASK1),
  34 #if defined(CERNLIB_BUGLRSHFT)
  35      +            ishft (AND(MS(JS+2),MASK1), -8)),
  36      +            ishft (AND(MS(JS+3),MASK1),-16)),
  37      +            ishft     (MS(JS+4),       -24) )
  38 #endif
  39 #if !defined(CERNLIB_BUGLRSHFT)
  40      +           lrshft (AND(MS(JS+2),MASK1), 8)),
  41      +           lrshft (AND(MS(JS+3),MASK1),16)),
  42      +           lrshft     (MS(JS+4),       24) )
  43 #endif
  44    24 JS = JS + 4
  45
  46       IF (NTRAIL.EQ.0)       RETURN
  47
  48 C--                Pack the trailing word
  49
  50    31 MWD = IBLAN1
  51       JS  = NCH
  52
  53       DO 34 JT=1,NTRAIL
  54 #if defined(CERNLIB_BUGLRSHFT)
  55       MWD = OR (ishft(MWD,-8), AND(MS(JS),MASK1))
  56 #endif
  57 #if !defined(CERNLIB_BUGLRSHFT)
  58       MWD = OR (lrshft(MWD,8), AND(MS(JS),MASK1))
  59 #endif
  60    34 JS  = JS - 1
  61       MT(NWT+1) = MWD
  62    39 RETURN
  63
  64    91 CALL ABEND
  65       END