MINICERN/packlib/zebra/dzebra/dzchv1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/24 17:26:07  mclareni
   6 * Extend the include file cleanup to dzebra, rz and tq, and also add
   7 * dependencies in some cases.
   8 *
   9 * Revision 1.1.1.1  1996/03/06 10:47:06  mclareni
  10 * Zebra
  11 *
  12 *
  13 *-----------------------------------------------------------
  14 #include "zebra/pilot.h"
  15       SUBROUTINE DZCHV1 (LBEGIN,LEND,IXQUES,ISUM)
  16 #if defined(CERNLIB_QMCRY)
  17 CDIR$ INTEGER=64
  18 #endif
  19 #include "zebra/mqsys.inc"
  20 #include "zebra/zbcdch.inc"
  21 #include "zebra/zbcdk.inc"
  22 #include "zebra/zunit.inc"
  23 #include "zebra/dzc1.inc"
  24 #include "zebra/questparq.inc"
  25 #include "zebra/storparq.inc"
  26       INTEGER ISUM(*)
  27       PARAMETER ( NFIELD =  4 )
  28 *       32 BIT MACHINES
  29 #if defined(CERNLIB_B32)
  30       PARAMETER ( NBITS  =  8 )
  31 *       36 BIT MACHINE
  32 #endif
  33 #if defined(CERNLIB_B36)
  34       PARAMETER ( NBITS  =  9 )
  35 *       60 BIT MACHINE
  36 #endif
  37 #if defined(CERNLIB_B60)
  38       PARAMETER ( NBITS  = 15 )
  39 *       64 BIT MACHINE
  40 #endif
  41 #if defined(CERNLIB_B64)
  42       PARAMETER ( NBITS  = 16 )
  43 #endif
  44       PARAMETER ( NWMAX  = 2**(NBITS*(NFIELD-1)-1) )
  45       INTEGER IFIELD(NFIELD)
  46
  47       CHARACTER CHROUT*(*),CHSTAK*6
  48       PARAMETER (CHROUT = 'DZCHV1')
  49
  50 #include "zebra/q_jbyt.inc"
  51
  52 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  53 #include "zebra/debugvf2.inc"
  54 #endif
  55
  56
  57
  58
  59       CHSTAK          = CQSTAK(MCQSIQ:)
  60       CQSTAK(MCQSIQ:) = CHROUT
  61
  62       NWTOT  = LEND - LBEGIN + 1
  63       IF (NWTOT.GT.NWMAX)              THEN
  64           WRITE(CQINFO,'(2I10)') NWTOT,NWMAX
  65           CALL DZTEXT(MCHV1Q,CDUMMQ,0)
  66           IQUEST(1) = 1
  67                                                            GO TO 999
  68       ENDIF
  69
  70       IF (IXQUES.NE.0) THEN
  71           DO 10 JF=1,NFIELD
  72    10     IFIELD(JF) = IQUEST(IXQUES+JF)
  73       ELSE
  74           DO 20 JF=1,NFIELD
  75    20     IFIELD(JF) = 0
  76       ENDIF
  77
  78
  79       DO 100 JW=LBEGIN,LEND
  80           DO 100 JF=1,NFIELD
  81               JFIELD=JBYT(LQ(JW),(JF-1)*NBITS+1,NBITS)
  82   100     IFIELD (JF) = IFIELD(JF) + JFIELD
  83
  84       IF (IXQUES.EQ.0) THEN
  85           JCARRY = 0
  86
  87           DO 200 JF=1,NFIELD
  88               IFIELD (JF) = IFIELD(JF) + JCARRY
  89               JCARRY = IFIELD(JF)/2**NBITS
  90           IFIELD (JF) = IFIELD(JF) - JCARRY*(2**NBITS)
  91   200     CALL SBYT(IFIELD(JF),ISUM(1),(JF-1)*NBITS+1,NBITS)
  92           ISUM(2) = JCARRY
  93       ELSE
  94           DO 300 JF=1,4
  95   300     IQUEST(IXQUES+JF) = IFIELD(JF)
  96       ENDIF
  97
  98   999 CQSTAK(MCQSIQ:) = CHSTAK
  99       RETURN
 100       END