Mostly minor style modifications to be ready for cloning with EMCAL
[u/mrichter/AliRoot.git] / 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"