Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / jz91 / jzlift.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1996/03/06 10:47:17  mclareni
6 * Zebra
7 *
8 *
9 #include "zebra/pilot.h"
10       SUBROUTINE JZLIFT
11
12 C-    Initialize processor SV bank for support variables
13
14 C-    Parameters in /JZC/ :
15 C-    IAM(1)  IAMID  = processor ID in A4
16 C-        2   IAFLDW = down-call flag
17 C-             0  no further down transfer
18 C-             1  with down transfer, level JQMLEV must not be reached
19 C-        3   IANAN  = number of processor constants
20 C-        4   IANCR  = number of conditions to be recorded
21 C-        5   IANLSV = number of wsp links to be saved
22 C-        6   IANDSV = number of wsp data words to be saved
23
24 #include "zebra/zstate.inc"
25 #include "zebra/zunit.inc"
26 #include "zebra/mqsysh.inc"
27 #include "zebra/jzuc.inc"
28 #include "zebra/jzc.inc"
29 C--------------    END CDE                             -----------------  ------
30       DIMENSION    IDPR(7)
31       EQUIVALENCE (IDPR(1),IAMID)
32
33       DIMENSION    MMSV(5)
34 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
35       DIMENSION    NAMESR(2)
36       DATA  NAMESR / 4HJZLI, 4HFT   /
37 #endif
38 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
39       DATA  NAMESR / 6HJZLIFT /
40 #endif
41 #if !defined(CERNLIB_QTRHOLL)
42       CHARACTER    NAMESR*8
43       PARAMETER   (NAMESR = 'JZLIFT  ')
44 #endif
45       DATA  MMSV   / 4HJZSV, -7, 0, -7, 0 /
46
47 #include "zebra/q_jbit.inc"
48
49 #include "zebra/qtraceq.inc"
50
51 C----              Create SV bank
52
53       IANCR   = MAX (IANCR,1)
54       MMSV(4) = JQNACC + IANCR + IANAN + IANDSV + 2
55       IANFL   = 0
56 #if defined(CERNLIB_QDEBUG)
57       LTFL   = LZFIND (IXSTJZ,LQ(KQS+LQJZ-2), IAMID,1)
58       IF (LTFL.NE.0)  IANFL = IQ(KQS+LTFL-1) - 1
59       MMSV(4) = MMSV(4) + IANFL
60 #endif
61       MMSV(2) = IANLSV + 3
62       CALL MZLIFT (IXDVJZ,LSV,LQJZ,-3,MMSV,0)
63       LCR = LSV + JQNACC
64       LAN = LCR + IANCR + 1
65 #if defined(CERNLIB_QDEBUG)
66       LFL = LAN + IANAN + 1 + IANDSV
67 #endif
68       CALL SBYT (JQLEV+1, IQ(KQS+LSV),1,8)
69       IQ(KQS+LSV+1) = IAMID
70       IQ(KQS+LSV+3) = IANLSV
71       IQ(KQS+LSV+4) = IANDSV
72
73       IQ(KQS+LCR) = IANCR
74       IQ(KQS+LAN) = IANAN
75       NANTL    = IANAN
76
77 C----              Find and copy JQAN title, if any
78
79       LTAN = LZFIND (IXSTJZ,LQ(KQS+LQJZ-1), IAMID,1)
80       IF (LTAN.NE.0)  THEN
81           NANTL = IQ(KQS+LTAN-1) - 1
82           N     = MIN (NANTL,IANAN)
83           CALL UCOPY (IQ(KQS+LTAN+2),IQ(KQS+LAN+1),N)
84           CALL SBIT1 (IQ(KQS+LSV),17)
85           CALL MZDROP (IXSTJZ,LTAN, '.')
86         ENDIF
87
88 C----              Find and copy JQFL flag titles, if any
89
90 #if defined(CERNLIB_QDEBUG)
91       IF (LTFL.NE.0)  THEN
92           LTFL = LZFIND (IXSTJZ,LQ(KQS+LQJZ-2), IAMID,1)
93           IF (IANFL.NE.0)
94      +      CALL UCOPY (IQ(KQS+LTFL+2),IQ(KQS+LFL+1),IANFL)
95           IQ(KQS+LFL) = IANFL
96           CALL MZDROP (IXSTJZ,LTFL, '.')
97         ENDIF
98 #endif
99
100 C----              Print and check discrepancies
101
102       LEV = JQLLEV
103       IF (IANAN.NE.NANTL)  LEV = LEV + 1
104
105       IF (LEV.GE.2)  WRITE (IQLOG,9042) IDPR
106  9042 FORMAT (/' JZLIFT.  Init of "',A4,
107      F ' with  IFDW,NAN,NCD,NLSV,NDSV,NFL =',6I4)
108
109       IF (IANAN.EQ.NANTL)          GO TO 47
110
111       IF (LEV.GE.2)  WRITE (IQLOG,9043) NANTL
112  9043 FORMAT (10X,'!!! NAN from title =',I8,' !!!')
113
114 C----              Exit
115
116    47 IQUEST(1) = -7
117       IQUEST(2) = LSV
118       IF (JBIT(IQ(KQS+LSV),17).EQ.0)  GO TO 999
119       IF (JQLLEV.GE.2)  WRITE (IQLOG,9048)
120  9048 FORMAT (10X,'with title.')
121       IQUEST(1) = 0
122 #include "zebra/qtrace99.inc"
123       RETURN
124       END
125 *      ==================================================
126 #include "zebra/qcardl.inc"