MINICERN/packlib/zebra/mq/mzwork.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:12:10  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:18  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE MZWORK (IXSTOR,DFIRST,DLAST,IFLAGP)
  14
  15 C-    Allocate working space, user called
  16
  17 C-    IFLAG = -1  reset wsp empty
  18 C-             0  new wsp
  19 C-             1  vary both limits, keep common links
  20 C-             2  vary  only DLAST  limit, keep links and common data
  21 C-             3  reset only DFIRST limit, zero all links
  22 C-             4  vary  only DFIRST limit, keep common links
  23
  24 #include "zebra/zmach.inc"
  25 #include "zebra/zstate.inc"
  26 #include "zebra/zunit.inc"
  27 #include "zebra/zvfaut.inc"
  28 #include "zebra/mqsys.inc"
  29 C--------------    End CDE                             --------------
  30       INTEGER      DFIRST(9), DLAST(9), IFLAGP(9)
  31 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  32       DIMENSION    NAMESR(2)
  33       DATA  NAMESR / 4HMZWO, 4HRK   /
  34 #endif
  35 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  36       DATA  NAMESR / 6HMZWORK /
  37 #endif
  38 #if !defined(CERNLIB_QTRHOLL)
  39       CHARACTER    NAMESR*8
  40       PARAMETER   (NAMESR = 'MZWORK  ')
  41 #endif
  42
  43 #include "zebra/q_jbit.inc"
  44 #include "zebra/q_jbyt.inc"
  45 #include "zebra/q_locf.inc"
  46
  47       IFLAG = IFLAGP(1)
  48
  49 #include "zebra/qtrace.inc"
  50
  51 #include "zebra/qstore.inc"
  52 #if defined(CERNLIB_QDEBUG)
  53       IF (IQVSTA.NE.0)       CALL ZVAUTX
  54 #endif
  55
  56       IF (IFLAG.LT.0)              GO TO 61
  57
  58       NEWL  = LOCF (DFIRST(1)) - (LQSTOR+1)
  59       NEWD  = LOCF (DLAST(1))  -  LQSTOR
  60 #if defined(CERNLIB_APOLLO)
  61       NEWL  = RSHFT (IADDR(DFIRST(1)),2) - (LQSTOR+1)
  62       NEWD  = RSHFT (IADDR(DLAST(1)),2)  - LQSTOR
  63 #endif
  64       IF (IFLAG.GE.5)              GO TO 91
  65       IF (IFLAG.GE.3)  NEWD = LQSTA(1) - 1
  66       IF (IFLAG.EQ.2)  NEWL = NQLINK
  67
  68 C----              Check valid parameters
  69
  70       IF (NEWL.LT.NQREF)           GO TO 92
  71       IF (NEWD.LT.NEWL)            GO TO 93
  72       IF (IFLAG.GE.3)              GO TO 31
  73       IF (NEWD.GE.LQEND(KQT+2))       GO TO 94
  74
  75 C--                Check garbage collection
  76
  77       NQRESV = LQSTA(KQT+2) - NQMINR - NEWD
  78       IF (NQRESV.GT.0)             GO TO 31
  79       LQEND(KQT+1) = LQSTA(KQT+1)
  80       JQDIVI    = 2
  81       CALL MZRESV
  82       NQRESV = LQSTA(KQT+2) - NQMINR - NEWD
  83       CALL MZGAR1
  84
  85 C--                Clear new links
  86
  87    31 LA = NQREF
  88       IF (IFLAG.EQ.1)  LA = NQLINK
  89       IF (IFLAG.EQ.2)  LA = NQLINK
  90       IF (IFLAG.EQ.4)  LA = NQLINK
  91       N  = NEWL - LA
  92       IF (N.GT.0)  CALL VZERO (LQ(KQS+LA+1),N)
  93
  94 C--                Clear new data words
  95
  96 #if defined(CERNLIB_QDEBUG)
  97       IF (IFLAG.GE.3)              GO TO 71
  98       IF (JBYT(IQDBUG,4,2).EQ.0)   GO TO 71
  99       IF   (IFLAG.LT.2)  THEN
 100           LA = NEWL  + 1
 101         ELSE
 102           LA = LQSTA(KQT+1)
 103         ENDIF
 104
 105       LE = NEWD
 106       IF (JBIT(IQDBUG,5).NE.0)  LE=LQSTA(KQT+2) - 1
 107       IF (LE.LT.LA)                GO TO 71
 108
 109       DO 38  L=LA,LE
 110    38 LQ(KQS+L) = IQNIL + L
 111 #endif
 112       GO TO 71
 113
 114 C----              Reset empty working space
 115
 116    61 NEWL = NQREF
 117       NEWD = NQREF
 118 #if defined(CERNLIB_QDEBUG)
 119       IF (IFLAG.LT.-1)             GO TO 91
 120 #endif
 121
 122 C----              Set new limits
 123
 124    71 NQLINK  = NEWL
 125       IQTABV(KQT+5) = NQLINK
 126       IF (IFLAG.LT.3)  THEN
 127           LQSTA(KQT+1)  = NEWD + 1
 128           LQEND(KQT+1)  = NEWD + 1
 129         ENDIF
 130 #if defined(CERNLIB_QDEBPRI)
 131       IF (NQLOGL.GE.2)
 132      + WRITE (IQLOG,9071) JQSTOR,IFLAG,NQLINK,NEWD
 133  9071 FORMAT (' MZWORK-  Store',I3,' Flag=',I2,' Last Link/Data',2I7)
 134 #endif
 135 #include "zebra/qtrace99.inc"
 136       RETURN
 137
 138 C------            Error conditions
 139
 140    94 NQCASE = 1
 141    93 NQCASE = NQCASE + 1
 142    92 NQCASE = NQCASE + 1
 143    91 NQCASE = NQCASE + 1
 144       NQFATA = 4
 145       IQUEST(11) = NQREF
 146       IQUEST(12) = NEWL
 147       IQUEST(13) = NEWD
 148       IQUEST(14) = IFLAG
 149 #include "zebra/qtofatal.inc"
 150       END
 151 *      ==================================================
 152 #include "zebra/qcardl.inc"