Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzout.F
CommitLineData
fe4da5cc 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
12C- Processor up transfer
13
14C 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"
21C-------------- 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
49C---- 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
59C-- Account time
60
61#if defined(CERNLIB_JZTIME)
62#include "zebra/jztimout.inc"
63#endif
64
65C---- 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
79C-- 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
92C--- 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
113C---- 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"