]>
Commit | Line | Data |
---|---|---|
3c5d1739 | 1 | * $Log$ |
2 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
3 | * Changes for new CTEQ code/AB sets | |
4 | * | |
5 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
6 | * small changes from cdf/d0 comments - renamubg conflicting name | |
7 | * adding pftopdg, etc. | |
8 | * | |
9 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
10 | * Initial CVS import of the LHAPDF code and data sets | |
11 | * | |
12 | * Revision 1.1.1.1 1996/04/01 15:02:05 mclareni | |
13 | * Mathlib gen | |
14 | * | |
15 | * | |
16 | FUNCTION DDILOG_LHA(X) | |
17 | implicit real*8 (a-h,o-z) | |
18 | DIMENSION C(0:19) | |
19 | PARAMETER (Z1 = 1d0, HF = Z1/2d0) | |
20 | PARAMETER (PI = 3.14159 26535 89793 24D0) | |
21 | PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12) | |
22 | ||
23 | DATA C( 0) / 0.42996 69356 08136 97D0/ | |
24 | DATA C( 1) / 0.40975 98753 30771 05D0/ | |
25 | DATA C( 2) /-0.01858 84366 50145 92D0/ | |
26 | DATA C( 3) / 0.00145 75108 40622 68D0/ | |
27 | DATA C( 4) /-0.00014 30418 44423 40D0/ | |
28 | DATA C( 5) / 0.00001 58841 55418 80D0/ | |
29 | DATA C( 6) /-0.00000 19078 49593 87D0/ | |
30 | DATA C( 7) / 0.00000 02419 51808 54D0/ | |
31 | DATA C( 8) /-0.00000 00319 33412 74D0/ | |
32 | DATA C( 9) / 0.00000 00043 45450 63D0/ | |
33 | DATA C(10) /-0.00000 00006 05784 80D0/ | |
34 | DATA C(11) / 0.00000 00000 86120 98D0/ | |
35 | DATA C(12) /-0.00000 00000 12443 32D0/ | |
36 | DATA C(13) / 0.00000 00000 01822 56D0/ | |
37 | DATA C(14) /-0.00000 00000 00270 07D0/ | |
38 | DATA C(15) / 0.00000 00000 00040 42D0/ | |
39 | DATA C(16) /-0.00000 00000 00006 10D0/ | |
40 | DATA C(17) / 0.00000 00000 00000 93D0/ | |
41 | DATA C(18) /-0.00000 00000 00000 14D0/ | |
42 | DATA C(19) /+0.00000 00000 00000 02D0/ | |
43 | ||
44 | IF(X .EQ. 1d0) THEN | |
45 | H=PI6 | |
46 | ELSEIF(X .EQ. -1d0) THEN | |
47 | H=-PI12 | |
48 | ELSE | |
49 | T=-X | |
50 | IF(T .LE. -2d0) THEN | |
51 | Y=-1/(1d0+T) | |
52 | S=1d0 | |
53 | A=-PI3+HF*(LOG(-T)**2-LOG(1d0+1d0/T)**2) | |
54 | ELSEIF(T .LT. -1d0) THEN | |
55 | Y=-1d0-T | |
56 | S=-1d0 | |
57 | A=LOG(-T) | |
58 | A=-PI6+A*(A+LOG(1d0+1d0/T)) | |
59 | ELSE IF(T .LE. -HF) THEN | |
60 | Y=-(1d0+T)/T | |
61 | S=1d0 | |
62 | A=LOG(-T) | |
63 | A=-PI6+A*(-HF*A+LOG(1d0+T)) | |
64 | ELSE IF(T .LT. 0) THEN | |
65 | Y=-T/(1d0+T) | |
66 | S=-1d0 | |
67 | A=HF*LOG(1d0+T)**2 | |
68 | ELSE IF(T .LE. 1d0) THEN | |
69 | Y=T | |
70 | S=1d0 | |
71 | A=0d0 | |
72 | ELSE | |
73 | Y=1d0/T | |
74 | S=-1d0 | |
75 | A=PI6+HF*LOG(T)**2 | |
76 | ENDIF | |
77 | H=Y+Y-1 | |
78 | ALFA=H+H | |
79 | B1=0 | |
80 | B2=0 | |
81 | DO 1 I = 19,0,-1 | |
82 | B0=C(I)+ALFA*B1-B2 | |
83 | B2=B1 | |
84 | 1 B1=B0 | |
85 | H=-(S*(B0-H*B2)+A) | |
86 | ENDIF | |
87 | DDILOG_LHA=H | |
88 | RETURN | |
89 | END | |
90 | * | |
91 | * $Id$ | |
92 | * | |
93 | * $Log$ | |
94 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
95 | * Changes for new CTEQ code/AB sets | |
96 | * | |
97 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
98 | * small changes from cdf/d0 comments - renamubg conflicting name | |
99 | * adding pftopdg, etc. | |
100 | * | |
101 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
102 | * Initial CVS import of the LHAPDF code and data sets | |
103 | * | |
104 | * Revision 1.1.1.1 1996/04/01 15:02:13 mclareni | |
105 | * Mathlib gen | |
106 | * | |
107 | * | |
108 | FUNCTION DGAUSS_LHA(F,A,B,EPS) | |
109 | ||
110 | implicit real*8 (a-h,o-z) | |
111 | CHARACTER NAME*(*) | |
112 | PARAMETER (NAME = 'DGAUSS_LHA') | |
113 | DIMENSION W(12),X(12) | |
114 | PARAMETER (Z1 = 1d0, HF = Z1/2d0, CST = 5d0*Z1/1000d0) | |
115 | DATA X | |
116 | 1 /0.96028 98564 97536 23168 35608 68569 47D0, | |
117 | 2 0.79666 64774 13626 73959 15539 36475 83D0, | |
118 | 3 0.52553 24099 16328 98581 77390 49189 25D0, | |
119 | 4 0.18343 46424 95649 80493 94761 42360 18D0, | |
120 | 5 0.98940 09349 91649 93259 61541 73450 33D0, | |
121 | 6 0.94457 50230 73232 57607 79884 15534 61D0, | |
122 | 7 0.86563 12023 87831 74388 04678 97712 39D0, | |
123 | 8 0.75540 44083 55003 03389 51011 94847 44D0, | |
124 | 9 0.61787 62444 02643 74844 66717 64048 79D0, | |
125 | A 0.45801 67776 57227 38634 24194 42983 58D0, | |
126 | B 0.28160 35507 79258 91323 04605 01460 50D0, | |
127 | C 0.95012 50983 76374 40185 31933 54249 58D-1/ | |
128 | ||
129 | DATA W | |
130 | 1 /0.10122 85362 90376 25915 25313 54309 96D0, | |
131 | 2 0.22238 10344 53374 47054 43559 94426 24D0, | |
132 | 3 0.31370 66458 77887 28733 79622 01986 60D0, | |
133 | 4 0.36268 37833 78361 98296 51504 49277 20D0, | |
134 | 5 0.27152 45941 17540 94851 78057 24560 18D-1, | |
135 | 6 0.62253 52393 86478 92862 84383 69943 78D-1, | |
136 | 7 0.95158 51168 24927 84809 92510 76022 46D-1, | |
137 | 8 0.12462 89712 55533 87205 24762 82192 02D0, | |
138 | 9 0.14959 59888 16576 73208 15017 30547 48D0, | |
139 | A 0.16915 65193 95002 53818 93120 79030 36D0, | |
140 | B 0.18260 34150 44923 58886 67636 67969 22D0, | |
141 | C 0.18945 06104 55068 49628 53967 23208 28D0/ | |
142 | ||
143 | H=0 | |
144 | IF(B .EQ. A) GO TO 99 | |
145 | CONST=CST/ABS(B-A) | |
146 | BB=A | |
147 | 1 AA=BB | |
148 | BB=B | |
149 | 2 C1=HF*(BB+AA) | |
150 | C2=HF*(BB-AA) | |
151 | S8=0 | |
152 | DO 3 I = 1,4 | |
153 | U=C2*X(I) | |
154 | 3 S8=S8+W(I)*(F(C1+U)+F(C1-U)) | |
155 | S16=0 | |
156 | DO 4 I = 5,12 | |
157 | U=C2*X(I) | |
158 | 4 S16=S16+W(I)*(F(C1+U)+F(C1-U)) | |
159 | S16=C2*S16 | |
160 | IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN | |
161 | H=H+S16 | |
162 | IF(BB .NE. B) GO TO 1 | |
163 | ELSE | |
164 | BB=C1 | |
165 | IF(1+CONST*ABS(C2) .NE. 1) GO TO 2 | |
166 | H=0 | |
167 | write(*,*) NAME,'D103.1','TOO HIGH ACCURACY REQUIRED' | |
168 | GO TO 99 | |
169 | END IF | |
170 | 99 DGAUSS_LHA=H | |
171 | RETURN | |
172 | END | |
173 | ||
174 | SUBROUTINE VZERO (A,N) | |
175 | C | |
176 | C CERN PROGLIB# F121 VZERO .VERSION KERNFOR 4.40 940929 | |
177 | C ORIG. 01/07/71, modif. 24/05/87 to set integer zero | |
178 | C modif. 25/05/94 to depend on QINTZERO | |
179 | C | |
180 | DIMENSION A(*) | |
181 | IF (N.LE.0) RETURN | |
182 | DO 9 I= 1,N | |
183 | 9 A(I)= 0d0 | |
184 | RETURN | |
185 | END | |
186 | ||
187 | * | |
188 | * $Id$ | |
189 | * | |
190 | * $Log$ | |
191 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
192 | * Changes for new CTEQ code/AB sets | |
193 | * | |
194 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
195 | * small changes from cdf/d0 comments - renamubg conflicting name | |
196 | * adding pftopdg, etc. | |
197 | * | |
198 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
199 | * Initial CVS import of the LHAPDF code and data sets | |
200 | * | |
201 | * Revision 1.1.1.1 1996/02/15 17:49:49 mclareni | |
202 | * Kernlib | |
203 | * | |
204 | * | |
205 | FUNCTION LENOCC_LHA (CHV) | |
206 | C | |
207 | C CERN PROGLIB# M507 LENOCC .VERSION KERNFOR 4.21 890323 | |
208 | C ORIG. March 85, A.Petrilli, re-write 21/02/89, JZ | |
209 | C | |
210 | C- Find last non-blank character in CHV | |
211 | ||
212 | CHARACTER CHV*(*) | |
213 | ||
214 | N = LEN(CHV) | |
215 | ||
216 | DO 17 JJ= N,1,-1 | |
217 | IF (CHV(JJ:JJ).NE.' ') GO TO 99 | |
218 | 17 CONTINUE | |
219 | JJ = 0 | |
220 | ||
221 | 99 LENOCC_LHA = JJ | |
222 | RETURN | |
223 | END | |
224 | * | |
225 | * $Id$ | |
226 | * | |
227 | * $Log$ | |
228 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
229 | * Changes for new CTEQ code/AB sets | |
230 | * | |
231 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
232 | * small changes from cdf/d0 comments - renamubg conflicting name | |
233 | * adding pftopdg, etc. | |
234 | * | |
235 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
236 | * Initial CVS import of the LHAPDF code and data sets | |
237 | * | |
238 | * Revision 1.1.1.1 1996/02/15 17:49:43 mclareni | |
239 | * Kernlib | |
240 | * | |
241 | * | |
242 | SUBROUTINE CLTOU_LHA (CHV) | |
243 | C | |
244 | C CERN PROGLIB# M432 CLTOU .VERSION KERNFOR 4.21 890323 | |
245 | C ORIG. 11/02/86 A. PETRILLI | |
246 | C NEW 9/02/89 JZ, for speed | |
247 | C | |
248 | C- Convert character string CHV from lower to upper case. | |
249 | ||
250 | CHARACTER CHV*(*) | |
251 | DO 19 JJ=1,LEN(CHV) | |
252 | J = ICHAR(CHV(JJ:JJ)) | |
253 | IF (J.LT.97) GO TO 19 | |
254 | IF (J.GE.123) GO TO 19 | |
255 | CHV(JJ:JJ) = CHAR(J-32) | |
256 | 19 CONTINUE | |
257 | END | |
258 | * | |
259 | SUBROUTINE TIMEX_LHA (T) | |
260 | C | |
261 | C CERN PROGLIB# Z007 TIMEX DUMMY .VERSION KERNFOR 4.05 821202 | |
262 | C | |
263 | C- DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE | |
264 | ||
265 | T = 9. | |
266 | RETURN | |
267 | END | |
268 | * | |
269 | * $Id$ | |
270 | * | |
271 | * $Log$ | |
272 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
273 | * Changes for new CTEQ code/AB sets | |
274 | * | |
275 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
276 | * small changes from cdf/d0 comments - renamubg conflicting name | |
277 | * adding pftopdg, etc. | |
278 | * | |
279 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
280 | * Initial CVS import of the LHAPDF code and data sets | |
281 | * | |
282 | * Revision 1.1.1.1 1996/02/15 17:49:44 mclareni | |
283 | * Kernlib | |
284 | * | |
285 | * | |
286 | SUBROUTINE FLPSOR_LHA(A,N) | |
287 | C | |
288 | C CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113 | |
289 | C ORIG. 29/04/78 | |
290 | C | |
291 | C SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY | |
292 | C INCREASING VALUES | |
293 | C | |
294 | C- PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78 | |
295 | C | |
296 | DIMENSION A(N) | |
297 | COMMON /SLATE/ LT(20),RT(20) | |
298 | INTEGER R,RT | |
299 | C | |
300 | LEVEL=1 | |
301 | LT(1)=1 | |
302 | RT(1)=N | |
303 | 10 L=LT(LEVEL) | |
304 | R=RT(LEVEL) | |
305 | LEVEL=LEVEL-1 | |
306 | 20 IF(R.GT.L) GO TO 200 | |
307 | IF(LEVEL) 50,50,10 | |
308 | C | |
309 | C SUBDIVIDE THE INTERVAL L,R | |
310 | C L : LOWER LIMIT OF THE INTERVAL (INPUT) | |
311 | C R : UPPER LIMIT OF THE INTERVAL (INPUT) | |
312 | C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT) | |
313 | C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT) | |
314 | C | |
315 | 200 I=L | |
316 | J=R | |
317 | M=(L+R)/2 | |
318 | X=A(M) | |
319 | 220 IF(A(I).GE.X) GO TO 230 | |
320 | I=I+1 | |
321 | GO TO 220 | |
322 | 230 IF(A(J).LE.X) GO TO 231 | |
323 | J=J-1 | |
324 | GO TO 230 | |
325 | C | |
326 | 231 IF(I.GT.J) GO TO 232 | |
327 | W=A(I) | |
328 | A(I)=A(J) | |
329 | A(J)=W | |
330 | I=I+1 | |
331 | J=J-1 | |
332 | IF(I.LE.J) GO TO 220 | |
333 | C | |
334 | 232 LEVEL=LEVEL+1 | |
335 | IF((R-I).GE.(J-L)) GO TO 30 | |
336 | LT(LEVEL)=L | |
337 | RT(LEVEL)=J | |
338 | L=I | |
339 | GO TO 20 | |
340 | 30 LT(LEVEL)=I | |
341 | RT(LEVEL)=R | |
342 | R=J | |
343 | GO TO 20 | |
344 | 50 RETURN | |
345 | END | |
346 | ||
347 | SUBROUTINE DATIMH_LHA (ND,NT) | |
348 | C | |
349 | C CERN PROGLIB# Z007 DATIMH DUMMY .VERSION KERNFOR 4.03 821008 | |
350 | C | |
351 | C- DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE | |
352 | ||
353 | DIMENSION ND(9), NT(9) | |
354 | * DIMENSION M(8) | |
355 | ||
356 | do i=1,9 | |
357 | ND(i)=0 | |
358 | NT(i)=0 | |
359 | enddo | |
360 | * CALL UBLOW (8H29/09/79,M,8) | |
361 | * CALL UBUNCH (M,ND,8) | |
362 | * CALL UBLOW (8H12.00.00,M,8) | |
363 | * CALL UBUNCH (M,NT,8) | |
364 | RETURN | |
365 | END | |
366 | c************************************************************************** | |
367 | c these next added from CERNLIB to allow some photon and pion sets to work | |
368 | c nothing to do with QCDNUM mrw 9/12/2004 | |
369 | c*************************************************************************8 | |
370 | c* | |
371 | * $Id$ | |
372 | * | |
373 | * $Log$ | |
374 | * Revision 1.3 2005/12/02 14:50:54 whalley | |
375 | * Changes for new CTEQ code/AB sets | |
376 | * | |
377 | * Revision 1.2 2005/10/18 10:34:52 whalley | |
378 | * small changes from cdf/d0 comments - renamubg conflicting name | |
379 | * adding pftopdg, etc. | |
380 | * | |
381 | * Revision 1.1.1.1 2005/05/06 14:54:44 whalley | |
382 | * Initial CVS import of the LHAPDF code and data sets | |
383 | * | |
384 | * Revision 1.1.1.1 1996/02/15 17:48:17 mclareni | |
385 | * Kernlib | |
386 | * | |
387 | * | |
388 | DOUBLE PRECISION FUNCTION DGAMMA_LHA(X) | |
389 | LOGICAL MFLAG,RFLAG | |
390 | REAL SX | |
391 | DOUBLE PRECISION X,U,F,ZERO,ONE,THREE,FOUR,PI | |
392 | DOUBLE PRECISION C(0:24),H,ALFA,B0,B1,B2 | |
393 | DATA ZERO /0.0D0/, ONE /1.0D0/, THREE /3.0D0/, FOUR /4.0D0/ | |
394 | c#if defined(CERNLIB_NUMHIPRE) | |
395 | c DATA NC /24/ | |
396 | c DATA PI /3.14159 26535 89793 23846 26433 83D0/ | |
397 | c DATA C( 0) /3.65738 77250 83382 43849 88068 39D0/ | |
398 | c DATA C( 1) /1.95754 34566 61268 26928 33742 26D0/ | |
399 | c DATA C( 2) / .33829 71138 26160 38915 58510 73D0/ | |
400 | c DATA C( 3) / .04208 95127 65575 49198 51083 97D0/ | |
401 | c DATA C( 4) / .00428 76504 82129 08770 04289 08D0/ | |
402 | c DATA C( 5) / .00036 52121 69294 61767 02198 22D0/ | |
403 | c DATA C( 6) / .00002 74006 42226 42200 27170 66D0/ | |
404 | c DATA C( 7) / .00000 18124 02333 65124 44603 05D0/ | |
405 | c DATA C( 8) / .00000 01096 57758 65997 06993 06D0/ | |
406 | c DATA C( 9) / .00000 00059 87184 04552 00046 95D0/ | |
407 | c DATA C(10) / .00000 00003 07690 80535 24777 71D0/ | |
408 | c DATA C(11) / .00000 00000 14317 93029 61915 76D0/ | |
409 | c DATA C(12) / .00000 00000 00651 08773 34803 70D0/ | |
410 | c DATA C(13) / .00000 00000 00025 95849 89822 28D0/ | |
411 | c DATA C(14) / .00000 00000 00001 10789 38922 59D0/ | |
412 | c DATA C(15) / .00000 00000 00000 03547 43620 17D0/ | |
413 | c DATA C(16) / .00000 00000 00000 00168 86075 04D0/ | |
414 | c DATA C(17) / .00000 00000 00000 00002 73543 58D0/ | |
415 | c DATA C(18) / .00000 00000 00000 00000 30297 74D0/ | |
416 | c DATA C(19) /-.00000 00000 00000 00000 00571 22D0/ | |
417 | c DATA C(20) / .00000 00000 00000 00000 00090 77D0/ | |
418 | c DATA C(21) /-.00000 00000 00000 00000 00005 05D0/ | |
419 | c DATA C(22) / .00000 00000 00000 00000 00000 41D0/ | |
420 | c DATA C(23) /-.00000 00000 00000 00000 00000 03D0/ | |
421 | c DATA C(24) / .00000 00000 00000 00000 00000 01D0/ | |
422 | c#endif | |
423 | c#if defined(CERNLIB_NUMLOPRE) | |
424 | DATA NC /15/ | |
425 | DATA PI /3.14159 26535 89793 24D0/ | |
426 | DATA C( 0) /3.65738 77250 83382 44D0/ | |
427 | DATA C( 1) /1.95754 34566 61268 27D0/ | |
428 | DATA C( 2) / .33829 71138 26160 39D0/ | |
429 | DATA C( 3) / .04208 95127 65575 49D0/ | |
430 | DATA C( 4) / .00428 76504 82129 09D0/ | |
431 | DATA C( 5) / .00036 52121 69294 62D0/ | |
432 | DATA C( 6) / .00002 74006 42226 42D0/ | |
433 | DATA C( 7) / .00000 18124 02333 65D0/ | |
434 | DATA C( 8) / .00000 01096 57758 66D0/ | |
435 | DATA C( 9) / .00000 00059 87184 05D0/ | |
436 | DATA C(10) / .00000 00003 07690 81D0/ | |
437 | DATA C(11) / .00000 00000 14317 93D0/ | |
438 | DATA C(12) / .00000 00000 00651 09D0/ | |
439 | DATA C(13) / .00000 00000 00025 96D0/ | |
440 | DATA C(14) / .00000 00000 00001 11D0/ | |
441 | DATA C(15) / .00000 00000 00000 04D0/ | |
442 | c#endif | |
443 | U=X | |
444 | IF(X .LE. ZERO) THEN | |
445 | IF(X .EQ. INT(X)) THEN | |
446 | CALL KERMTR_LHA('C305.1',LGFILE,MFLAG,RFLAG) | |
447 | IF(MFLAG) THEN | |
448 | SX=X | |
449 | IF(LGFILE .EQ. 0) THEN | |
450 | WRITE(*,100) SX | |
451 | ELSE | |
452 | WRITE(LGFILE,100) SX | |
453 | END IF | |
454 | END IF | |
455 | IF(.NOT.RFLAG) CALL ABEND_LHA | |
456 | DGAMMA_LHA=ZERO | |
457 | RETURN | |
458 | ELSE | |
459 | U=ONE-U | |
460 | END IF | |
461 | END IF | |
462 | F=ONE | |
463 | IF(U .LT. THREE) THEN | |
464 | DO 1 I = 1,INT(FOUR-U) | |
465 | F=F/U | |
466 | 1 U=U+ONE | |
467 | ELSE | |
468 | DO 2 I = 1,INT(U-THREE) | |
469 | U=U-ONE | |
470 | 2 F=F*U | |
471 | END IF | |
472 | U=U-THREE | |
473 | H=U+U-ONE | |
474 | ALFA=H+H | |
475 | B1=ZERO | |
476 | B2=ZERO | |
477 | DO 3 I = NC,0,-1 | |
478 | B0=C(I)+ALFA*B1-B2 | |
479 | B2=B1 | |
480 | 3 B1=B0 | |
481 | U=F*(B0-H*B2) | |
482 | IF(X .LT. ZERO) U=PI/(SIN(PI*X)*U) | |
483 | DGAMMA_LHA=U | |
484 | RETURN | |
485 | 100 FORMAT(1X,'DGAMMA ... ARGUMENT IS NON-POSITIVE INTEGER = ',E15.1) | |
486 | END | |
487 | c======================================================================== | |
488 | SUBROUTINE KERSET_LHA(ERCODE,LGFILE,LIMITM,LIMITR) | |
489 | PARAMETER(KOUNTE = 28) | |
490 | CHARACTER*6 ERCODE, CODE(KOUNTE) | |
491 | LOGICAL MFLAG, RFLAG | |
492 | INTEGER KNTM(KOUNTE), KNTR(KOUNTE) | |
493 | DATA LOGF / 0 / | |
494 | DATA CODE(1), KNTM(1), KNTR(1) / 'C204.1', 100, 100 / | |
495 | DATA CODE(2), KNTM(2), KNTR(2) / 'C204.2', 100, 100 / | |
496 | DATA CODE(3), KNTM(3), KNTR(3) / 'C204.3', 100, 100 / | |
497 | DATA CODE(4), KNTM(4), KNTR(4) / 'C205.1', 100, 100 / | |
498 | DATA CODE(5), KNTM(5), KNTR(5) / 'C205.2', 100, 100 / | |
499 | DATA CODE(6), KNTM(6), KNTR(6) / 'C205.3', 100, 100 / | |
500 | DATA CODE(7), KNTM(7), KNTR(7) / 'C305.1', 100, 100 / | |
501 | DATA CODE(8), KNTM(8), KNTR(8) / 'C308.1', 100, 100 / | |
502 | DATA CODE(9), KNTM(9), KNTR(9) / 'C312.1', 100, 100 / | |
503 | DATA CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 / | |
504 | DATA CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 / | |
505 | DATA CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 / | |
506 | DATA CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 / | |
507 | DATA CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 / | |
508 | DATA CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 / | |
509 | DATA CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 / | |
510 | DATA CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 / | |
511 | DATA CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 / | |
512 | DATA CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 / | |
513 | DATA CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 / | |
514 | DATA CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 / | |
515 | DATA CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 / | |
516 | DATA CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100, 0 / | |
517 | DATA CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100, 0 / | |
518 | DATA CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100, 0 / | |
519 | DATA CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100, 0 / | |
520 | DATA CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 / | |
521 | DATA CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 / | |
522 | LOGF = LGFILE | |
523 | IF(ERCODE .EQ. ' ') THEN | |
524 | L = 0 | |
525 | ELSE | |
526 | DO 10 L = 1, 6 | |
527 | IF(ERCODE(1:L) .EQ. ERCODE) GOTO 12 | |
528 | 10 CONTINUE | |
529 | 12 CONTINUE | |
530 | ENDIF | |
531 | DO 14 I = 1, KOUNTE | |
532 | IF(L .EQ. 0) GOTO 13 | |
533 | IF(CODE(I)(1:L) .NE. ERCODE(1:L)) GOTO 14 | |
534 | 13 KNTM(I) = LIMITM | |
535 | KNTR(I) = LIMITR | |
536 | 14 CONTINUE | |
537 | RETURN | |
538 | ENTRY KERMTR_LHA(ERCODE,LOG,MFLAG,RFLAG) | |
539 | LOG = LOGF | |
540 | DO 20 I = 1, KOUNTE | |
541 | IF(ERCODE .EQ. CODE(I)) GOTO 21 | |
542 | 20 CONTINUE | |
543 | WRITE(*,1000) ERCODE | |
544 | CALL ABEND_LHA | |
545 | RETURN | |
546 | 21 RFLAG = KNTR(I) .GE. 1 | |
547 | IF(RFLAG .AND. (KNTR(I) .LT. 100)) KNTR(I) = KNTR(I) - 1 | |
548 | MFLAG = KNTM(I) .GE. 1 | |
549 | IF(MFLAG .AND. (KNTM(I) .LT. 100)) KNTM(I) = KNTM(I) - 1 | |
550 | IF(.NOT. RFLAG) THEN | |
551 | IF(LOGF .LT. 1) THEN | |
552 | WRITE(*,1001) CODE(I) | |
553 | ELSE | |
554 | WRITE(LOGF,1001) CODE(I) | |
555 | ENDIF | |
556 | ENDIF | |
557 | IF(MFLAG .AND. RFLAG) THEN | |
558 | IF(LOGF .LT. 1) THEN | |
559 | WRITE(*,1002) CODE(I) | |
560 | ELSE | |
561 | WRITE(LOGF,1002) CODE(I) | |
562 | ENDIF | |
563 | ENDIF | |
564 | RETURN | |
565 | 1000 FORMAT(' KERNLIB LIBRARY ERROR. ' / | |
566 | + ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR', | |
567 | + ' ERROR MONITOR. RUN ABORTED.') | |
568 | 1001 FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ', | |
569 | + 'CONDITION ',A6) | |
570 | 1002 FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6) | |
571 | END | |
572 | c======================================================================== | |
573 | SUBROUTINE ABEND_LHA | |
574 | C | |
575 | C CERN PROGLIB# Z035 ABEND .VERSION KERNVAX 1.10 811126 | |
576 | ||
577 | STOP '*** ABEND ***' | |
578 | END |