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

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1  1998/09/25 09:32:14  mclareni
   6 * Modifications for the Mklinux port flagged by CERNLIB_PPC
   7 *
   8 * Revision 1.1.1.1  1996/02/15 17:50:20  mclareni
   9 * Kernlib
  10 *
  11 *
  12       SUBROUTINE UBUNCH (MS,MT,NCHP)
  13 C
  14 C CERN PROGLIB# M409    UBUNCH          .VERSION KERNLNX  1.02  940511
  15 C ORIG. 03/02/89 K.M.STORR
  16 C
  17
  18       DIMENSION    MS(99), MT(99), NCHP(9)
  19       data iblan1/x'20202020'/
  20       data mask1/x'ff000000'/
  21
  22       NCH = NCHP(1)
  23       IF   (NCH)             91,39,11
  24    11 NWT    = ishftr (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      +          ISHFTR (AND(MS(JS+2),MASK1), 8)),
  35      +          ISHFTR (IAND(MS(JS+3),MASK1),16)),
  36      +          ISHFTR      (MS(JS+4),       24) )
  37    24 JS = JS + 4
  38
  39       IF (NTRAIL.EQ.0)       RETURN
  40
  41 C--                Pack the trailing word
  42
  43    31 MWD = IBLAN1
  44       JS  = NCH
  45
  46       DO 34 JT=1,NTRAIL
  47       MWD = OR (ISHFTR(MWD,8), AND(MS(JS),MASK1))
  48    34 JS  = JS - 1
  49       MT(NWT+1) = MWD
  50    39 RETURN
  51
  52    91 CALL ABEND
  53       END