Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / dzebra / dzmap.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1999/05/18 15:55:22  fca
6 * AliRoot sources
7 *
8 * Revision 1.2  1996/04/24 17:26:12  mclareni
9 * Extend the include file cleanup to dzebra, rz and tq, and also add
10 * dependencies in some cases.
11 *
12 * Revision 1.1.1.1  1996/03/06 10:47:07  mclareni
13 * Zebra
14 *
15 *
16 *------------------------------------------------------------
17 #include "zebra/pilot.h"
18 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
19 #include "zebra/debugvf1.inc"
20 #endif
21       SUBROUTINE DZMAP
22 #include "zebra/bankparq.inc"
23 #include "zebra/divparq.inc"
24 #include "zebra/storparq.inc"
25 #include "zebra/mqsys.inc"
26 #include "zebra/qequ.inc"
27 #include "zebra/mzcn.inc"
28 #include "zebra/zbcd.inc"
29 #include "zebra/zbcdk.inc"
30 #include "zebra/zunit.inc"
31 #include "zebra/dzc1.inc"
32
33
34       PARAMETER ( NLMAPQ = 7 )
35       PARAMETER ( ISIDEQ = 6 )
36       PARAMETER ( ILINKQ = 15)
37       PARAMETER ( NLINKQ = 14)
38       PARAMETER ( IMAD1Q = 1 , IMAD2Q= 8)
39       PARAMETER ( IMTG1Q = 9 , IMTG2Q= 9)
40       PARAMETER ( IMID1Q = 10, IMID2Q= 13)
41
42       CHARACTER CHROUT*(*),CHSTAK*6
43       PARAMETER (CHROUT = 'DZMAP' )
44
45 #include "zebra/q_jbit.inc"
46
47 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
48 #include "zebra/debugvf2.inc"
49 #endif
50
51
52       CHSTAK          = CQSTAK(MCQSIQ:)
53       CQSTAK(MCQSIQ:) = CHROUT
54
55       IDOPT  = IFLOPT(MPOSDQ)
56
57
58       IF (LN.GT.0)      THEN
59           CALL MZCHLN(NCHEKQ,LN)
60           IF (IQFOUL.NE.0)                                 GO TO 998
61       ELSE
62           CALL MZCHLS(NCHEKQ,LS)
63           IF (IQFOUL.NE.0)                                 GO TO 998
64       ENDIF
65
66       IF (IQND.LT.0) THEN
67           IF (IFLOPT(MPOSHQ).NE.0) THEN
68
69 #if !defined(CERNLIB_OCTMAP)
70               WRITE(CQLINE,
71      W         '(1X,''(*HO*'',1X,I8,''('',Z8,
72      W          '') -- HOLE of '',I8,'' words'')') IQLN,(IQLN+LQSTOR)
73 #else
74               WRITE(CQLINE,
75      W         '(1X,''(*HO*'',1X,I8,''('',O8,
76      W          '') -- HOLE of '',I8,'' words'')') IQLN,(IQLN+LQSTOR)
77 #endif
78 *              MAP addresses are in BYTES
79 #if !defined(CERNLIB_WORDMAP)
80      W                                                               *4
81 #endif
82      W          ,-IQND
83
84               CALL DZTEXT(0,CDUMMQ,1)
85           ENDIF
86           LX = IQNX
87                                                            GO TO 999
88       ELSE
89           LS = IQLS
90           NL = IQNL
91           NS = IQNS
92           ND = IQND
93           LX = IQNX
94       ENDIF
95
96       IF (IFLOPT(MPOSKQ).EQ.0)         THEN
97           JDROP  = JBIT(IQ(KQS+IQLS),IQDROP)
98       ELSE
99           JDROP  = 0
100       ENDIF
101       MARKD  = 0
102       IF (JDROP.EQ.0)                  THEN
103           IF(IFLOPT(MPOSDQ).NE.0)          THEN
104               MARKD = JRSBYT(0,IQ(KQS+LS),IQMARK,1)
105               IFLOPT(MPOSDQ) = 0
106           ENDIF
107           IF(IFLOPT(MPOSCQ).NE.0)          THEN
108               MARKD = JRSBYT(0,IQ(KQS+LS),IQCRIT,1) + MARKD
109           ENDIF
110           IF (MARKD+IFLOPT(MPOSFQ).NE.0)       THEN
111               IFLOPT(MPOSDQ) = 1
112               CALL DZSHPR(LS,0,0,0,0)
113                                                            GO TO 999
114           ENDIF
115           IF (MARKD+IFLOPT(MPOSEQ).NE.0)       THEN
116               IFLOPT(MPOSDQ) = 1
117               CALL DZSHPR(LS,0,0,0,-1)
118                                                            GO TO 999
119           ENDIF
120       ENDIF
121
122       CALL DZBKHD
123       IF (IQUEST(1).NE.0)                                  GO TO 998
124
125
126       IF (NL.EQ.0)                                         GO TO 999
127
128
129       CQLINE = '      . LINKS'
130       LAST   = LS - NL
131       L      = LAST
132
133       DO 43 J=1,NL
134           IF (LQ(L+KQS).NE.0)                              GO TO 44
135    43 L = L+1
136    44 NP= LS - L
137
138       IF (NP.EQ.0)                                         GO TO 999
139
140       IF (NP.GT.NLMAPQ)                 THEN
141           CQLINE(ISIDEQ+1:ISIDEQ+1) = '+'
142           NP    = NLMAPQ
143       ENDIF
144
145       IF (JDROP.NE.0) CQLINE(ISIDEQ:ISIDEQ+1) = '**'
146
147       L = LS + KQS
148       DO 50  J=1,NP
149           I       = (J-1)*NLINKQ + ILINKQ
150           LINK    = LQ (L-J)
151           WRITE(CQLINE(I+IMAD1Q:I+IMAD2Q),'(I8)') LINK
152           IF (LINK.EQ.LNULL)                               GO TO 50
153           CALL MZCHLS(NCHEKQ,LINK)
154           WRITE(CQLINE(I+IMID1Q:I+IMID2Q),'(A4)') IQID
155
156           IF (IQFOUL.EQ.0)                 THEN
157               IF (JBIT(IQ(KQS+LINK),IQDROP).NE.0)   THEN
158                   CQLINE(I+IMTG1Q:I+IMTG2Q) = '('
159                   IF (JDROP.EQ.0) CQLINE(ISIDEQ+1:ISIDEQ+1) = 'F'
160                   IF (IQND.LT.0)  CQLINE(I+IMID1Q:I+IMID2Q) = '*HO*'
161               ELSE
162                   IF (JDROP.NE.0.AND.J.LE.NS.AND.J.GT.1)        THEN
163                       CQLINE(ISIDEQ+1:ISIDEQ+1) = 'F'
164                   ENDIF
165               ENDIF
166           ELSEIF (IQFOUL.GT.0)             THEN
167               IF (J.LE.NS)                     THEN
168                   CQLINE(I+IMID1Q:I+IMID2Q) = '****'
169                   CQLINE(ISIDEQ+1:ISIDEQ+1) = 'F'
170               ELSE
171                   CQLINE(I+IMID1Q:I+IMID2Q) = '-'
172               ENDIF
173           ELSE
174               CQLINE(I+IMID1Q:I+IMID2Q) = '****'
175               CQLINE(ISIDEQ+1:ISIDEQ+1) = 'F'
176           ENDIF
177
178    50 CONTINUE
179
180
181       CALL DZTEXT(0,CDUMMQ,1)
182
183                                                            GO TO 999
184
185   998 IQUEST(1) = 1
186
187   999 IFLOPT(MPOSDQ) = IDOPT
188       CQSTAK(MCQSIQ:) = CHSTAK
189       END