MINICERN/packlib/zebra/jz91/jzout.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:16  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE JZOUT (CHPA1)
  11
  12 C-    Processor up transfer
  13
  14 C     CHPA1   processor ID in A4
  15
  16 #include "zebra/zstate.inc"
  17 #include "zebra/zunit.inc"
  18 #include "zebra/mqsys.inc"
  19 #include "zebra/jzuc.inc"
  20 #include "zebra/jzc.inc"
  21 C--------------    END CDE                             -----------------  ------
  22       CHARACTER    CHPA1*4
  23 #if defined(CERNLIB_A4)
  24       CHARACTER    CHIAM*4
  25 #endif
  26 #if defined(CERNLIB_A8)
  27       CHARACTER    CHIAM*8
  28 #endif
  29 #if defined(CERNLIB_EQUHOLCH)
  30       EQUIVALENCE (CHIAM, IAMID)
  31 #endif
  32 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  33       DIMENSION    NAMESR(2)
  34       DATA  NAMESR / 4HJZOU, 4HT    /
  35 #endif
  36 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  37       DATA  NAMESR / 6HJZOUT  /
  38 #endif
  39 #if !defined(CERNLIB_QTRHOLL)
  40       CHARACTER    NAMESR*8
  41       PARAMETER   (NAMESR = 'JZOUT   ')
  42 #endif
  43
  44 #include "zebra/q_jbit.inc"
  45
  46 #include "zebra/qtraceq.inc"
  47 #include "zebra/qstorjz.inc"
  48
  49 C----              Check matching ID's
  50
  51       CHIAM  = CHPA1
  52       IF (CHIAM.NE.'??? ')  THEN
  53 #if !defined(CERNLIB_EQUHOLCH)
  54           CALL UCTOH (CHIAM, IAMID,4,4)
  55 #endif
  56           IF (NQME(1).NE.IAMID)        GO TO 91
  57         ENDIF
  58
  59 C--                Account time
  60
  61 #if defined(CERNLIB_JZTIME)
  62 #include "zebra/jztimout.inc"
  63 #endif
  64
  65 C----              Step level back
  66
  67       IF (JQLEV.EQ.0)              GO TO 92
  68       LEVDW = JQLEV
  69       JQLEV = JQLEV - 1
  70
  71       J    = LQJZ - JQLEV - 6
  72       LQDW = LQ(KQS+J)
  73       LQUP = LQ(KQS+J+1)
  74       J    = J - JQMLEV
  75       LQSV = LQ(KQS+J)
  76       LCD  = LQSV + JQNACC
  77       LQAN = LCD + IQ(KQS+LCD) + 1
  78
  79 C--                Copy flags
  80
  81 #if defined(CERNLIB_QDEBUG)
  82       CALL VZERO (JQFLAG,JQMFLW)
  83       L = LQAN + IQ(KQS+LQAN) + 1 + IQ(KQS+LQSV+4)
  84       N = IQ(KQS+L)
  85       IF (N.NE.0)  CALL UCOPY (IQ(KQS+L+1),JQFLAG,N)
  86
  87       IF (JBIT(JQLLEV,13).NE.0)
  88      +         WRITE (IQLOG,9024) LEVDW,NQME(1),IQ(KQS+LQSV+1)
  89  9024 FORMAT ( ' =======  JZOUT  level',I2,', "',A4,'   up to "',A4)
  90 #endif
  91
  92 C---               Work space for upper proc
  93
  94       NQME(1) = IQ(KQS+LQSV+1)
  95       IF (JBIT(IQ(KQS+LQDW),15).NE.0)  THEN
  96           CALL SBIT0 (IQ(KQS+LQDW),15)
  97           GO TO 999
  98         ENDIF
  99       NLINK = IQ(KQS+LQJZ+2*JQLEV+2)
 100       NDATA = IQ(KQS+LQJZ+2*JQLEV+3)
 101       CALL MZWORK (IXSTJZ,LQ(KQS+NLINK+1),LQ(KQS+NDATA-1),0)
 102
 103       N = IQ(KQS+LQSV+3)
 104       IF (N.NE.0) CALL UCOPY (LQ(KQS+LQSV-N-3),LQ(KQS+NQREF+1),N)
 105       N = IQ(KQS+LQSV+4)
 106       IF (N.EQ.0)                  GO TO 999
 107       L = LQAN + IQ(KQS+LQAN)
 108       CALL UCOPY (IQ(KQS+L+1),LQ(KQS+NQLINK+1),N)
 109
 110 #include "zebra/qtrace99.inc"
 111       RETURN
 112
 113 C----              ID mismatch
 114
 115    92 NQCASE = 1
 116    91 NQCASE = NQCASE + 1
 117       NQFATA = 3
 118       IQUEST(11) = NQME(1)
 119       IQUEST(12) = IAMID
 120       IQUEST(13) = JQLEV
 121 #include "zebra/qtofatal.inc"
 122       END
 123 *      ==================================================
 124 #include "zebra/qcardl.inc"