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

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1  1998/09/25 09:32:12  mclareni
   6 * Modifications for the Mklinux port flagged by CERNLIB_PPC
   7 *
   8 * Revision 1.1.1.1  1996/02/15 17:50:19  mclareni
   9 * Kernlib
  10 *
  11 *
  12       SUBROUTINE UBLOW (MS,MT,NCHP)
  13 C
  14 C CERN PROGLIB# M409    UBLOW           .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'00202020'/
  20       data mask1/x'ff000000'/
  21
  22       NCH = NCHP(1)
  23       IF   (NCH)             91, 29, 11
  24    11 NWS    = ishftr (NCH,2)
  25       NTRAIL = AND (NCH,3)
  26       JT     = 0
  27       IF (NWS.EQ.0)          GO TO 26
  28
  29 C--                Unpack the initial complete words
  30
  31       DO 24 JS=1,NWS
  32       MWD      = MS(JS)
  33       MT(JT+1) = OR (IBLAN1,AND(MASK1,MWD))
  34       MT(JT+2) = OR (IBLAN1,AND(MASK1,LSHIFT(MWD,8)))
  35       MT(JT+3) = OR (IBLAN1,AND(MASK1,LSHIFT(MWD,16)))
  36       MT(JT+4) = OR (IBLAN1,          LSHIFT(MWD,24) )
  37    24 JT = JT + 4
  38
  39       IF (NTRAIL.EQ.0)       RETURN
  40
  41 C--                Unpack the trailing word
  42
  43    26 MWD = MS(NWS+1)
  44
  45       DO 28 JS=1,NTRAIL
  46       MT(JT+1) = OR (IBLAN1,AND(MASK1,MWD))
  47       MWD = LSHIFT (MWD,8)
  48    28 JT = JT + 1
  49    29 RETURN
  50
  51    91 CALL ABEND
  52       END