MINICERN/packlib/zebra/jz91/jzin.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.3  1996/04/24 17:26:30  mclareni
   6 * Extend the include file cleanup to dzebra, rz and tq, and also add
   7 * dependencies in some cases.
   8 *
   9 * Revision 1.2  1996/04/18 16:11:05  mclareni
  10 * Incorporate changes from J.Zoll for version 3.77
  11 *
  12 * Revision 1.1.1.1  1996/03/06 10:47:17  mclareni
  13 * Zebra
  14 *
  15 *
  16 #include "zebra/pilot.h"
  17       SUBROUTINE JZIN (CHPA1,IPA2,IPA3,IPA4)
  18
  19 C-    Processor down transfer
  20
  21 C-     CHPA1  processor ID in A4
  22 C-      IPA2  = 0  no further down transfer
  23 C-            = 1 yes further down transfer
  24 C-      IPA3  NAN = number of processor constants
  25 C-      IPA4  extra features
  26 C-   IPA4(2)  NCR = number of conditions to be recorded
  27 C-   IPA4(3)  NLS = number of wsp links to be saved
  28 C-   IPA4(4)  NDS = number of wsp data words to be saved
  29
  30 #include "zebra/zstate.inc"
  31 #include "zebra/zunit.inc"
  32 #include "zebra/zvfaut.inc"
  33 #include "zebra/mqsys.inc"
  34 #include "zebra/jzuc.inc"
  35 #include "zebra/jzc.inc"
  36 C--------------    END CDE                             -----------------  ------
  37       DIMENSION    IPA2(7),IPA3(7),IPA4(7)
  38       CHARACTER    CHPA1*4
  39 #if defined(CERNLIB_A4)
  40       CHARACTER    CHIAM*4
  41 #endif
  42 #if defined(CERNLIB_A8)
  43       CHARACTER    CHIAM*8
  44 #endif
  45 #if defined(CERNLIB_EQUHOLCH)
  46       EQUIVALENCE (CHIAM, IAMID)
  47 #endif
  48
  49       DIMENSION    MMJZFO(5)
  50       PARAMETER   (MXREOD = 2097152)
  51 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  52       DIMENSION    NAMESR(2)
  53       DATA  NAMESR / 4HJZIN, 4H     /
  54 #endif
  55 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  56       DATA  NAMESR / 6HJZIN   /
  57 #endif
  58 #if !defined(CERNLIB_QTRHOLL)
  59       CHARACTER    NAMESR*8
  60       PARAMETER   (NAMESR = 'JZIN    ')
  61 #endif
  62       DATA  MMJZFO / 4HJZFO, 0, 0, 1, 2 /
  63
  64 #include "zebra/q_jbit.inc"
  65
  66 #include "zebra/qtraceq.inc"
  67 #include "zebra/qstorjz.inc"
  68 #if defined(CERNLIB_QDEBUG)
  69       IF (IQVSTA.NE.0)       CALL ZVAUTX
  70 #endif
  71
  72       CHIAM  = CHPA1
  73 #if !defined(CERNLIB_EQUHOLCH)
  74       CALL UCTOH (CHIAM, IAMID,4,4)
  75 #endif
  76       IAFLDW = IPA2(1)
  77       MINIT  = 7
  78       IF (LQSV.EQ.0)               GO TO 21
  79
  80 C----              Remember present state
  81
  82       IQ(KQS+LQJZ+2*JQLEV+2) = NQLINK
  83       IQ(KQS+LQJZ+2*JQLEV+3) = LQSTA(KQT+1)
  84
  85       N = IQ(KQS+LQSV+3)
  86       IF (N.NE.0) CALL UCOPY (LQ(KQS+NQREF+1),LQ(KQS+LQSV-N-3),N)
  87       N = IQ(KQS+LQSV+4)
  88       IF (N.NE.0)  THEN
  89           L = LQAN + IQ(KQS+LQAN)
  90           CALL UCOPY (LQ(KQS+NQLINK+1),IQ(KQS+L+1),N)
  91         ENDIF
  92
  93 #if defined(CERNLIB_JZTIME)
  94 #include "zebra/jztimin.inc"
  95 #endif
  96
  97 C----              Find SV bank
  98
  99    21 L = LQ(KQS+LQJZ-4)
 100       IF (L.EQ.0)                  GO TO 24
 101       J = IUCOMP (IAMID,IQ(KQS+L+2),IQ(KQS+L+1))
 102       IF (J.EQ.0)                  GO TO 24
 103       LQSV = LQ(KQS+L-J)
 104       GO TO 25
 105
 106    24 LQSV   = LZFIND (IXSTJZ,LQ(KQS+LQJZ-3), IAMID,1)
 107       IF (LQSV.EQ.0)               GO TO 81
 108    25 IQ(KQS+LQSV+2) = IQ(KQS+LQSV+2) + 1
 109       LCD  = LQSV + JQNACC
 110       LQAN = LCD + IQ(KQS+LCD) + 1
 111
 112 C--                Copy flags
 113
 114 #if defined(CERNLIB_QDEBUG)
 115       CALL VZERO (JQFLAG,JQMFLW)
 116       L = LQAN + IQ(KQS+LQAN) + 1 + IQ(KQS+LQSV+4)
 117       N = IQ(KQS+L)
 118       IF (N.NE.0)  CALL UCOPY (IQ(KQS+L+1),JQFLAG,N)
 119
 120       IF (JBIT(JQLLEV,9).NE.0)  WRITE (IQLOG,9024) JQLEV,NQME(1),
 121      +                          IQ(KQS+LQSV+1),IQ(KQS+LQSV+2)
 122
 123  9024 FORMAT (/' =======  JZIN   level',I2,', "',A4,' down to "',A4,
 124      FI8,'th entry')
 125 #endif
 126
 127       JQEALL = JQEALL + 1
 128       IF (JQEALL.EQ.0)             GO TO 71
 129
 130 C----              Step level
 131
 132    31 NQME(1) = IQ(KQS+LQSV+1)
 133       JQLEV   = JQLEV + 1
 134       IF (JQLEV.GT.JQMLEV)         GO TO 91
 135       J     = LQJZ - JQLEV - 6
 136       LQDW  = LQ(KQS+J)
 137       LQUP  = LQ(KQS+J+1)
 138       J     = J - JQMLEV
 139       LQ(KQS+J) = LQSV
 140       IQUEST(1) = MINIT
 141       IF (IAFLDW.NE.0)             GO TO 37
 142       LQDW = 0
 143 #include "zebra/qtrace99.inc"
 144       RETURN
 145
 146 C--                Clear the down call bank
 147
 148    37 IF (JQLEV.EQ.JQMLEV)         GO TO 92
 149       CALL VZERO (LQ(KQS+LQDW-JQCBNL),JQCBNL)
 150       CALL VZERO (IQ(KQS+LQDW+1),     JQCBND)
 151       IQ(KQS+LQDW) = MSBYT (0, IQ(KQS+LQDW),1,18)
 152       GO TO 999
 153
 154 C----              Re-order SV structure every now and then
 155
 156    71 JQREOD = MIN (4*JQREOD,MXREOD)
 157       JQEALL = -JQREOD
 158       IF (JQREOD.GE.MXREOD)        GO TO 31
 159       L = LQ(KQS+LQJZ-3)
 160       CALL ZTOPSY (IXSTJZ,L)
 161       CALL ZSORTI (IXSTJZ,L,2)
 162       CALL ZTOPSY (IXSTJZ,L)
 163       NPR  = NZBANK (IXSTJZ,L)
 164       INC  = 10
 165
 166       LFO = LQ(KQS+LQJZ-4)
 167       IF (LFO.EQ.0)                GO TO 72
 168       IF (NPR.LE.IQ(KQS+LFO-1))       GO TO 74
 169       CALL MZDROP (IXSTJZ,IQ(KQS+LFO), '.')
 170       INC = 4
 171
 172    72 MMJZFO(2) = NPR + INC
 173       MMJZFO(4) = MMJZFO(2) + 1
 174       CALL MZLIFT (IXDVJZ,LFO,LQJZ,-4,MMJZFO,0)
 175       JQREOD = 512
 176       JQEALL = -JQREOD
 177
 178    74 IQ(KQS+LFO+1) = NPR
 179       J = 0
 180       L = LQJZ - 3
 181    75 L = LQ(KQS+L)
 182       IF (L.EQ.0)                  GO TO 31
 183       J = J + 1
 184       LQ(KQS+LFO-J)   = L
 185       IQ(KQS+LFO+J+1) = IQ(KQS+L+1)
 186       GO TO 75
 187
 188 C----              Processor not yet initialized
 189
 190    81 IANAN = IPA3(1)
 191       IANCR = 10
 192       IANLSV = 0
 193       IANDSV = 0
 194
 195       N = IPA4(1)
 196       IF (N.GE.0)  THEN
 197           N =  MIN (N,3)
 198           CALL UCOPY (IPA4(2),IANCR,N)
 199         ENDIF
 200       CALL JZLIFT
 201       MINIT = IQUEST(1)
 202       LQSV  = IQUEST(2)
 203
 204       LFO = LQ(KQS+LQJZ-4)
 205       IF (LFO.EQ.0)                GO TO 25
 206       NFO = IQ(KQS+LFO+1) + 1
 207       IF (NFO.GE.IQ(KQS+LFO-1))       GO TO 25
 208       LQ(KQS+LFO-NFO)   = LQSV
 209       IQ(KQS+LFO+NFO+1) = IAMID
 210       IQ(KQS+LFO+1)     = NFO
 211       GO TO 25
 212
 213 C----              JQMLEV exeeded
 214
 215    92 NQCASE = 1
 216    91 NQCASE = NQCASE + 1
 217       NQFATA = 3
 218       IQUEST(11) = IAMID
 219       IQUEST(12) = IAFLDW
 220       IQUEST(13) = JQLEV
 221 #include "zebra/qtofatal.inc"
 222       END
 223 *      ==================================================
 224 #include "zebra/qcardl.inc"