MINICERN/packlib/zebra/fq/fzoapk.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:10:44  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:14  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13 #if defined(CERNLIB_FZALFA)
  14       SUBROUTINE FZOAPK (LBUFCP,LBUFEP)
  15
  16 C-    Unpack the set of words LQ(LBUFC) to LQ(LBUFE-1) at most
  17 C-    into LQ(LUPKA) to LQ(LUPKE-1) at most;
  18 C-    service routine to FZOASC.
  19
  20 C-    Return LUPKE the adr of the first word after the unpack vector.
  21 C-    For each word unpacked recognise the type and store 8 numbers:
  22 C-
  23 C-           normal number          repetition N+1 times
  24 C-         L + 0  type            L + 0  -43 to signal repeat
  25 C-           + 1  sub-type          + 1  N for N+2 numbers in all
  26 C-           + 2  bits 26-30
  27 C-           + 3  bits 21-25
  28 C-           ...
  29 C-           + 7  bits  1- 5
  30
  31 #include "zebra/zstate.inc"
  32 #include "zebra/mqsysh.inc"
  33 C--------------    End CDE                             --------------
  34       DIMENSION    LBUFCP(9), LBUFEP(9)
  35
  36       EQUIVALENCE (LUPKA,IQUEST(93)), (LUPKE, IQUEST(94))
  37
  38
  39 #include "zebra/q_jbyt.inc"
  40
  41
  42       LBUFC = LBUFCP(1)
  43       LBUFE = LBUFEP(1)
  44       LUPK  = LUPKA
  45       LUPKE = LUPKE - 10
  46 #if defined(CERNLIB_QDEVZE)
  47       IF (NQDEVZ.NE.0)  CALL VZERO (LQ(LUPK),LUPKE+8-LUPK)
  48 #endif
  49
  50    11 IWORD = LQ(LBUFC)
  51       LBUFC = LBUFC + 1
  52       JTYPS = 0
  53       M31   = JBYT (IWORD,31,2)
  54
  55 C--                Short cut if integer 0->9
  56
  57       IF (M31.NE.0)                GO TO 14
  58       IF (IWORD.GE.10)             GO TO 14
  59           JTYPE = 0
  60           JTYPS = IWORD + 26
  61           LQ(LUPK+7) = IWORD
  62           GO TO 38
  63    14 CONTINUE
  64
  65 C--                Unpack all bytes
  66
  67       LQ(LUPK+2) = JBYT (IWORD,26,5)
  68       LQ(LUPK+3) = JBYT (IWORD,21,5)
  69       LQ(LUPK+4) = JBYT (IWORD,16,5)
  70       LQ(LUPK+5) = JBYT (IWORD,11,5)
  71       LQ(LUPK+6) = JBYT (IWORD, 6,5)
  72       LQ(LUPK+7) = JBYT (IWORD, 1,5)
  73
  74 C--                Type : small +ve integer
  75
  76       IF (M31.NE.0)                GO TO 21
  77       IF (LQ(LUPK+2).NE.0)         GO TO 31
  78       JTYPE = 5
  79       DO 16  J=3,6
  80       IF (LQ(LUPK+J).NE.0)         GO TO 38
  81    16 JTYPS = JTYPS + 1
  82       GO TO 38
  83
  84 C--                Type : small negative integer
  85
  86    21 IF (M31.NE.3)                GO TO 31
  87       IF (LQ(LUPK+2).NE.31)        GO TO 31
  88       JTYPE = 6
  89       DO 24  J=3,6
  90       IF (LQ(LUPK+J).NE.31)        GO TO 38
  91    24 JTYPS = JTYPS + 1
  92       GO TO 38
  93
  94 C--                Type : normal words, check short mantissa
  95
  96    31 JTYPE = M31 + 1
  97       DO 36  J=7,4,-1
  98       IF (LQ(LUPK+J).NE.0)         GO TO 38
  99    36 JTYPS = JTYPS + 1
 100
 101 C--                Store Main type and sub-type, check repeat
 102
 103    38 LQ(LUPK)   = JTYPE
 104       LQ(LUPK+1) = JTYPS
 105       LUPK = LUPK + 8
 106       IF (LBUFC.EQ.LBUFE)          GO TO 49
 107       IF (LQ(LBUFC).EQ.IWORD)      GO TO 61
 108    39 IF (LUPK.LT.LUPKE)           GO TO 11
 109
 110    49 LQ(LUPK) = -1
 111       LUPKE = LUPK
 112       RETURN
 113
 114 C----              Check set of identical words
 115
 116    61 NL = LBUFE - LBUFC - 1
 117       NC = 0
 118       DO 63  J=1,NL
 119       IF (LQ(LBUFC+J).NE.IWORD)    GO TO 64
 120    63 NC = NC + 1
 121
 122    64 IF     (NC.LT.2)  THEN
 123           IF (JTYPE.EQ.0)          GO TO 39
 124         ENDIF
 125       LQ(LUPK)   = -43
 126       LQ(LUPK+1) = NC
 127       LUPKE = LUPK + 2
 128       RETURN
 129       END
 130 *      ==================================================
 131 #include "zebra/qcardl.inc"
 132 #endif