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

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:50:24  mclareni
   6 * Kernlib
   7 *
   8 *
   9       SUBROUTINE UBLOW (MS,MT,NCHP)
  10 C
  11 C CERN PROGLIB# M409    UBLOW           .VERSION KERNMPW  1.00  891208
  12 C ORIG. 12/12/83  JZ & FCA
  13 C
  14
  15       DIMENSION    MS(99), MT(99), NCHP(9)
  16       PARAMETER    (IBLAN1 = 2105376)
  17       PARAMETER    (MASK1  = -16777216)
  18
  19       IF(IAND(MS(2),65535).EQ.18) THEN
  20
  21 C--               Rare but nasty case, input as nH...
  22 C--               MPW FORTRAN makes a character out of it
  23
  24         CALL UCTOH1(MS,MT,NCHP)
  25         GO TO 29
  26       END IF
  27       NCH = NCHP(1)
  28       IF   (NCH)             91, 29, 11
  29    11 NWS    = ISHFT (NCH,-2)
  30       NTRAIL = IAND (NCH,3)
  31       JT     = 0
  32       IF (NWS.EQ.0)          GO TO 26
  33
  34 C--                Unpack the initial complete words
  35
  36       DO 24 JS=1,NWS
  37       MWD      = MS(JS)
  38       MT(JT+1) = IOR (IBLAN1,IAND(MASK1,MWD))
  39       MT(JT+2) = IOR (IBLAN1,IAND(MASK1,ISHFT(MWD, 8)))
  40       MT(JT+3) = IOR (IBLAN1,IAND(MASK1,ISHFT(MWD,16)))
  41       MT(JT+4) = IOR (IBLAN1,           ISHFT(MWD,24) )
  42    24 JT = JT + 4
  43
  44       IF (NTRAIL.EQ.0)       RETURN
  45
  46 C--                Unpack the trailing word
  47
  48    26 MWD = MS(NWS+1)
  49
  50       DO 28 JS=1,NTRAIL
  51       MT(JT+1) = IOR (IBLAN1,IAND(MASK1,MWD))
  52       MWD = ISHFT (MWD,8)
  53    28 JT = JT + 1
  54    29 RETURN
  55
  56    91 CALL ABEND
  57       END