[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzout.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/03/06 10:47:16  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE JZOUT (CHPA1)

C-    Processor up transfer

C     CHPA1   processor ID in A4

#include "zebra/zstate.inc"
#include "zebra/zunit.inc"
#include "zebra/mqsys.inc"
#include "zebra/jzuc.inc"
#include "zebra/jzc.inc"
C--------------    END CDE                             -----------------  ------
      CHARACTER    CHPA1*4
#if defined(CERNLIB_A4)
      CHARACTER    CHIAM*4
#endif
#if defined(CERNLIB_A8)
      CHARACTER    CHIAM*8
#endif
#if defined(CERNLIB_EQUHOLCH)
      EQUIVALENCE (CHIAM, IAMID)
#endif
#if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
      DIMENSION    NAMESR(2)
      DATA  NAMESR / 4HJZOU, 4HT    /
#endif
#if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
      DATA  NAMESR / 6HJZOUT  /
#endif
#if !defined(CERNLIB_QTRHOLL)
      CHARACTER    NAMESR*8
      PARAMETER   (NAMESR = 'JZOUT   ')
#endif

#include "zebra/q_jbit.inc"

#include "zebra/qtraceq.inc"
#include "zebra/qstorjz.inc"

C----              Check matching ID's

      CHIAM  = CHPA1
      IF (CHIAM.NE.'??? ')  THEN
#if !defined(CERNLIB_EQUHOLCH)
          CALL UCTOH (CHIAM, IAMID,4,4)
#endif
          IF (NQME(1).NE.IAMID)        GO TO 91
        ENDIF

C--                Account time

#if defined(CERNLIB_JZTIME)
#include "zebra/jztimout.inc"
#endif

C----              Step level back

      IF (JQLEV.EQ.0)              GO TO 92
      LEVDW = JQLEV
      JQLEV = JQLEV - 1

      J    = LQJZ - JQLEV - 6
      LQDW = LQ(KQS+J)
      LQUP = LQ(KQS+J+1)
      J    = J - JQMLEV
      LQSV = LQ(KQS+J)
      LCD  = LQSV + JQNACC
      LQAN = LCD + IQ(KQS+LCD) + 1

C--                Copy flags

#if defined(CERNLIB_QDEBUG)
      CALL VZERO (JQFLAG,JQMFLW)
      L = LQAN + IQ(KQS+LQAN) + 1 + IQ(KQS+LQSV+4)
      N = IQ(KQS+L)
      IF (N.NE.0)  CALL UCOPY (IQ(KQS+L+1),JQFLAG,N)

      IF (JBIT(JQLLEV,13).NE.0)
     +         WRITE (IQLOG,9024) LEVDW,NQME(1),IQ(KQS+LQSV+1)
 9024 FORMAT ( ' =======  JZOUT  level',I2,', "',A4,'   up to "',A4)
#endif

C---               Work space for upper proc

      NQME(1) = IQ(KQS+LQSV+1)
      IF (JBIT(IQ(KQS+LQDW),15).NE.0)  THEN
          CALL SBIT0 (IQ(KQS+LQDW),15)
          GO TO 999
        ENDIF
      NLINK = IQ(KQS+LQJZ+2*JQLEV+2)
      NDATA = IQ(KQS+LQJZ+2*JQLEV+3)
      CALL MZWORK (IXSTJZ,LQ(KQS+NLINK+1),LQ(KQS+NDATA-1),0)

      N = IQ(KQS+LQSV+3)
      IF (N.NE.0) CALL UCOPY (LQ(KQS+LQSV-N-3),LQ(KQS+NQREF+1),N)
      N = IQ(KQS+LQSV+4)
      IF (N.EQ.0)                  GO TO 999
      L = LQAN + IQ(KQS+LQAN)
      CALL UCOPY (IQ(KQS+L+1),LQ(KQS+NQLINK+1),N)

#include "zebra/qtrace99.inc"
      RETURN

C----              ID mismatch

   92 NQCASE = 1
   91 NQCASE = NQCASE + 1
      NQFATA = 3
      IQUEST(11) = NQME(1)
      IQUEST(12) = IAMID
      IQUEST(13) = JQLEV
#include "zebra/qtofatal.inc"
      END
*      ==================================================
#include "zebra/qcardl.inc"
Commit	Line	Data
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
	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"