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

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1997/09/02 14:27:03  mclareni
   6 * WINNT correction
   7 *
   8 * Revision 1.1.1.1  1996/02/15 17:50:24  mclareni
   9 * Kernlib
  10 *
  11 *
  12 #ifndef CERNLIB_QF2C
  13       SUBROUTINE UBUNCH (MS,MT,NCHP)
  14 C
  15 C CERN PROGLIB# M409    UBUNCH          .VERSION KERNDOS  1.00  920624
  16 C ORIG. 03/02/89 K.M.STORR
  17 C
  18
  19       DIMENSION    MS(99), MT(99), NCHP(9)
  20       PARAMETER    (IBLANK = X'20202020')
  21       PARAMETER    (MASK1  = X'000000FF')
  22
  23 #include "kerngen/q_andor.inc"
  24 #include "kerngen/q_shift.inc"
  25
  26       NCH = NCHP(1)
  27       IF   (NCH)             91,39,11
  28    11 NWT    = ishft (NCH,-2)
  29       NTRAIL = IAND (NCH,3)
  30       JS     = 0
  31       IF (NWT.EQ.0)          GO TO 31
  32
  33 C--                Pack the initial complete words
  34
  35       DO 24  JT=1,NWT
  36 #ifndef CERNLIB_QF2C
  37       MT(JT) = IOR (IOR (IOR (
  38      +                  IAND(MS(JS+1),MASK1),
  39      +           ishft (IAND(MS(JS+2),MASK1), 8)),
  40      +           ishft (IAND(MS(JS+3),MASK1),16)),
  41      +           ishft      (MS(JS+4),       24) )
  42 #else
  43       MT(JT) = OR (OR (OR (
  44      +                  AND(MS(JS+1),MASK1),
  45      +           LshIft (AND(MS(JS+2),MASK1), 8)),
  46      +           LshIft (AND(MS(JS+3),MASK1),16)),
  47      +           LshIft     (MS(JS+4),       24) )
  48 #endif
  49    24 JS = JS + 4
  50
  51       IF (NTRAIL.EQ.0)       RETURN
  52
  53 C--                Pack the trailing word
  54
  55    31 MWD = IBLANK
  56       JS  = NCH
  57
  58       DO 34 JT=1,NTRAIL
  59 #ifndef CERNLIB_QF2C
  60       MWD = IOR (ishft(MWD,8), IAND(MS(JS),MASK1))
  61 #else
  62       MWD = OR (LshIft(MWD,8), AND(MS(JS),MASK1))
  63 #endif
  64    34 JS  = JS - 1
  65       MT(NWT+1) = MWD
  66    39 RETURN
  67
  68    91 CALL ABEND
  69       END
  70 #endif