| 0caf84a5 |
1 | ! -*- F90 -*- |
| 2 | |
| 3 | |
| 4 | ! $Log$ |
| 5 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 6 | ! Changes for new CTEQ code/AB sets |
| 7 | ! |
| 8 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 9 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 10 | ! adding pftopdg, etc. |
| 11 | ! |
| 12 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 13 | ! Initial CVS import of the LHAPDF code and data sets |
| 14 | ! |
| 15 | ! Revision 1.1.1.1 1996/04/01 15:02:05 mclareni |
| 16 | ! Mathlib gen |
| 17 | ! |
| 18 | ! |
| 19 | FUNCTION DDILOG_LHA(X) |
| 20 | implicit real*8 (a-h,o-z) |
| 21 | DIMENSION C(0:19) |
| 22 | PARAMETER (Z1 = 1d0, HF = Z1/2d0) |
| 23 | PARAMETER (PI = 3.14159265358979324D0) |
| 24 | PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12) |
| 25 | |
| 26 | DATA C( 0) / 0.42996693560813697D0/ |
| 27 | DATA C( 1) / 0.40975987533077105D0/ |
| 28 | DATA C( 2) /-0.01858843665014592D0/ |
| 29 | DATA C( 3) / 0.00145751084062268D0/ |
| 30 | DATA C( 4) /-0.00014304184442340D0/ |
| 31 | DATA C( 5) / 0.00001588415541880D0/ |
| 32 | DATA C( 6) /-0.00000190784959387D0/ |
| 33 | DATA C( 7) / 0.00000024195180854D0/ |
| 34 | DATA C( 8) /-0.00000003193341274D0/ |
| 35 | DATA C( 9) / 0.00000000434545063D0/ |
| 36 | DATA C(10) /-0.00000000060578480D0/ |
| 37 | DATA C(11) / 0.00000000008612098D0/ |
| 38 | DATA C(12) /-0.00000000001244332D0/ |
| 39 | DATA C(13) / 0.00000000000182256D0/ |
| 40 | DATA C(14) /-0.00000000000027007D0/ |
| 41 | DATA C(15) / 0.00000000000004042D0/ |
| 42 | DATA C(16) /-0.00000000000000610D0/ |
| 43 | DATA C(17) / 0.00000000000000093D0/ |
| 44 | DATA C(18) /-0.00000000000000014D0/ |
| 45 | DATA C(19) /+0.00000000000000002D0/ |
| 46 | |
| 47 | IF(X .EQ. 1d0) THEN |
| 48 | H=PI6 |
| 49 | ELSEIF(X .EQ. -1d0) THEN |
| 50 | H=-PI12 |
| 51 | ELSE |
| 52 | T=-X |
| 53 | IF(T .LE. -2d0) THEN |
| 54 | Y=-1/(1d0+T) |
| 55 | S=1d0 |
| 56 | A=-PI3+HF*(LOG(-T)**2-LOG(1d0+1d0/T)**2) |
| 57 | ELSEIF(T .LT. -1d0) THEN |
| 58 | Y=-1d0-T |
| 59 | S=-1d0 |
| 60 | A=LOG(-T) |
| 61 | A=-PI6+A*(A+LOG(1d0+1d0/T)) |
| 62 | ELSE IF(T .LE. -HF) THEN |
| 63 | Y=-(1d0+T)/T |
| 64 | S=1d0 |
| 65 | A=LOG(-T) |
| 66 | A=-PI6+A*(-HF*A+LOG(1d0+T)) |
| 67 | ELSE IF(T .LT. 0) THEN |
| 68 | Y=-T/(1d0+T) |
| 69 | S=-1d0 |
| 70 | A=HF*LOG(1d0+T)**2 |
| 71 | ELSE IF(T .LE. 1d0) THEN |
| 72 | Y=T |
| 73 | S=1d0 |
| 74 | A=0d0 |
| 75 | ELSE |
| 76 | Y=1d0/T |
| 77 | S=-1d0 |
| 78 | A=PI6+HF*LOG(T)**2 |
| 79 | ENDIF |
| 80 | H=Y+Y-1 |
| 81 | ALFA=H+H |
| 82 | B1=0 |
| 83 | B2=0 |
| 84 | DO 1 I = 19,0,-1 |
| 85 | B0=C(I)+ALFA*B1-B2 |
| 86 | B2=B1 |
| 87 | 1 B1=B0 |
| 88 | H=-(S*(B0-H*B2)+A) |
| 89 | ENDIF |
| 90 | DDILOG_LHA=H |
| 91 | RETURN |
| 92 | END |
| 93 | ! |
| 94 | ! $Id: Sqcdnum.f 365 2008-09-02 09:12:20Z buckley $ |
| 95 | ! |
| 96 | ! $Log$ |
| 97 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 98 | ! Changes for new CTEQ code/AB sets |
| 99 | ! |
| 100 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 101 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 102 | ! adding pftopdg, etc. |
| 103 | ! |
| 104 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 105 | ! Initial CVS import of the LHAPDF code and data sets |
| 106 | ! |
| 107 | ! Revision 1.1.1.1 1996/04/01 15:02:13 mclareni |
| 108 | ! Mathlib gen |
| 109 | ! |
| 110 | ! |
| 111 | FUNCTION DGAUSS_LHA(F,A,B,EPS) |
| 112 | |
| 113 | implicit real*8 (a-h,o-z) |
| 114 | CHARACTER NAME*(*) |
| 115 | PARAMETER (NAME = 'DGAUSS_LHA') |
| 116 | DIMENSION W(12),X(12) |
| 117 | PARAMETER (Z1 = 1d0, HF = Z1/2d0, CST = 5d0*Z1/1000d0) |
| 118 | DATA X & |
| 119 | & /0.96028985649753623168356086856947D0, & |
| 120 | & 0.79666647741362673959155393647583D0, & |
| 121 | & 0.52553240991632898581773904918925D0, & |
| 122 | & 0.18343464249564980493947614236018D0, & |
| 123 | & 0.98940093499164993259615417345033D0, & |
| 124 | & 0.94457502307323257607798841553461D0, & |
| 125 | & 0.86563120238783174388046789771239D0, & |
| 126 | & 0.75540440835500303389510119484744D0, & |
| 127 | & 0.61787624440264374844667176404879D0, & |
| 128 | & 0.45801677765722738634241944298358D0, & |
| 129 | & 0.28160355077925891323046050146050D0, & |
| 130 | & 0.95012509837637440185319335424958D-1/ |
| 131 | |
| 132 | DATA W & |
| 133 | & /0.10122853629037625915253135430996D0, & |
| 134 | & 0.22238103445337447054435599442624D0, & |
| 135 | & 0.31370664587788728733796220198660D0, & |
| 136 | & 0.36268378337836198296515044927720D0, & |
| 137 | & 0.27152459411754094851780572456018D-1, & |
| 138 | & 0.62253523938647892862843836994378D-1, & |
| 139 | & 0.95158511682492784809925107602246D-1, & |
| 140 | & 0.12462897125553387205247628219202D0, & |
| 141 | & 0.14959598881657673208150173054748D0, & |
| 142 | & 0.16915651939500253818931207903036D0, & |
| 143 | & 0.18260341504492358886676366796922D0, & |
| 144 | & 0.18945061045506849628539672320828D0/ |
| 145 | |
| 146 | H=0 |
| 147 | IF(B .EQ. A) GO TO 99 |
| 148 | CONST=CST/ABS(B-A) |
| 149 | BB=A |
| 150 | 1 AA=BB |
| 151 | BB=B |
| 152 | 2 C1=HF*(BB+AA) |
| 153 | C2=HF*(BB-AA) |
| 154 | S8=0 |
| 155 | DO 3 I = 1,4 |
| 156 | U=C2*X(I) |
| 157 | 3 S8=S8+W(I)*(F(C1+U)+F(C1-U)) |
| 158 | S16=0 |
| 159 | DO 4 I = 5,12 |
| 160 | U=C2*X(I) |
| 161 | 4 S16=S16+W(I)*(F(C1+U)+F(C1-U)) |
| 162 | S16=C2*S16 |
| 163 | IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN |
| 164 | H=H+S16 |
| 165 | IF(BB .NE. B) GO TO 1 |
| 166 | ELSE |
| 167 | BB=C1 |
| 168 | IF(1+CONST*ABS(C2) .NE. 1) GO TO 2 |
| 169 | H=0 |
| 170 | write(*,*) NAME,'D103.1','TOO HIGH ACCURACY REQUIRED' |
| 171 | GO TO 99 |
| 172 | END IF |
| 173 | 99 DGAUSS_LHA=H |
| 174 | RETURN |
| 175 | END |
| 176 | |
| 177 | SUBROUTINE VZERO_LHA (A,N) |
| 178 | ! |
| 179 | ! CERN PROGLIB# F121 VZERO .VERSION KERNFOR 4.40 940929 |
| 180 | ! ORIG. 01/07/71, modif. 24/05/87 to set integer zero |
| 181 | ! modif. 25/05/94 to depend on QINTZERO |
| 182 | ! |
| 183 | DIMENSION A(*) |
| 184 | IF (N.LE.0) RETURN |
| 185 | DO 9 I= 1,N |
| 186 | 9 A(I)= 0d0 |
| 187 | RETURN |
| 188 | END |
| 189 | |
| 190 | ! |
| 191 | ! $Id: Sqcdnum.f 365 2008-09-02 09:12:20Z buckley $ |
| 192 | ! |
| 193 | ! $Log$ |
| 194 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 195 | ! Changes for new CTEQ code/AB sets |
| 196 | ! |
| 197 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 198 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 199 | ! adding pftopdg, etc. |
| 200 | ! |
| 201 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 202 | ! Initial CVS import of the LHAPDF code and data sets |
| 203 | ! |
| 204 | ! Revision 1.1.1.1 1996/02/15 17:49:49 mclareni |
| 205 | ! Kernlib |
| 206 | ! |
| 207 | ! |
| 208 | FUNCTION LENOCC_LHA (CHV) |
| 209 | ! |
| 210 | ! CERN PROGLIB# M507 LENOCC .VERSION KERNFOR 4.21 890323 |
| 211 | ! ORIG. March 85, A.Petrilli, re-write 21/02/89, JZ |
| 212 | ! |
| 213 | !- Find last non-blank character in CHV |
| 214 | |
| 215 | CHARACTER CHV*(*) |
| 216 | |
| 217 | N = LEN(CHV) |
| 218 | |
| 219 | DO 17 JJ= N,1,-1 |
| 220 | IF (CHV(JJ:JJ).NE.' ') GO TO 99 |
| 221 | 17 END DO |
| 222 | JJ = 0 |
| 223 | |
| 224 | 99 LENOCC_LHA = JJ |
| 225 | RETURN |
| 226 | END |
| 227 | ! |
| 228 | ! $Id: Sqcdnum.f 365 2008-09-02 09:12:20Z buckley $ |
| 229 | ! |
| 230 | ! $Log$ |
| 231 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 232 | ! Changes for new CTEQ code/AB sets |
| 233 | ! |
| 234 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 235 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 236 | ! adding pftopdg, etc. |
| 237 | ! |
| 238 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 239 | ! Initial CVS import of the LHAPDF code and data sets |
| 240 | ! |
| 241 | ! Revision 1.1.1.1 1996/02/15 17:49:43 mclareni |
| 242 | ! Kernlib |
| 243 | ! |
| 244 | ! |
| 245 | SUBROUTINE CLTOU_LHA (CHV) |
| 246 | ! |
| 247 | ! CERN PROGLIB# M432 CLTOU .VERSION KERNFOR 4.21 890323 |
| 248 | ! ORIG. 11/02/86 A. PETRILLI |
| 249 | ! NEW 9/02/89 JZ, for speed |
| 250 | ! |
| 251 | !- Convert character string CHV from lower to upper case. |
| 252 | |
| 253 | CHARACTER CHV*(*) |
| 254 | DO 19 JJ=1,LEN(CHV) |
| 255 | J = ICHAR(CHV(JJ:JJ)) |
| 256 | IF (J.LT.97) EXIT |
| 257 | IF (J.GE.123) EXIT |
| 258 | CHV(JJ:JJ) = CHAR(J-32) |
| 259 | 19 END DO |
| 260 | END |
| 261 | ! |
| 262 | SUBROUTINE TIMEX_LHA (T) |
| 263 | ! |
| 264 | ! CERN PROGLIB# Z007 TIMEX DUMMY .VERSION KERNFOR 4.05 821202 |
| 265 | ! |
| 266 | !- DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE |
| 267 | |
| 268 | T = 9. |
| 269 | RETURN |
| 270 | END |
| 271 | ! |
| 272 | ! $Id: Sqcdnum.f 365 2008-09-02 09:12:20Z buckley $ |
| 273 | ! |
| 274 | ! $Log$ |
| 275 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 276 | ! Changes for new CTEQ code/AB sets |
| 277 | ! |
| 278 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 279 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 280 | ! adding pftopdg, etc. |
| 281 | ! |
| 282 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 283 | ! Initial CVS import of the LHAPDF code and data sets |
| 284 | ! |
| 285 | ! Revision 1.1.1.1 1996/02/15 17:49:44 mclareni |
| 286 | ! Kernlib |
| 287 | ! |
| 288 | ! |
| 289 | SUBROUTINE FLPSOR_LHA(A,N) |
| 290 | ! |
| 291 | ! CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113 |
| 292 | ! ORIG. 29/04/78 |
| 293 | ! |
| 294 | ! SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY |
| 295 | ! INCREASING VALUES |
| 296 | ! |
| 297 | !- PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78 |
| 298 | ! |
| 299 | DIMENSION A(N) |
| 300 | COMMON /SLATE/ LT(20),RT(20) |
| 301 | INTEGER R,RT |
| 302 | ! |
| 303 | LEVEL=1 |
| 304 | LT(1)=1 |
| 305 | RT(1)=N |
| 306 | 10 L=LT(LEVEL) |
| 307 | R=RT(LEVEL) |
| 308 | LEVEL=LEVEL-1 |
| 309 | 20 IF(R.GT.L) GO TO 200 |
| 310 | IF(LEVEL.LE.0) THEN |
| 311 | GO TO 50 |
| 312 | ELSE |
| 313 | GO TO 10 |
| 314 | ENDIF |
| 315 | ! |
| 316 | ! SUBDIVIDE THE INTERVAL L,R |
| 317 | ! L : LOWER LIMIT OF THE INTERVAL (INPUT) |
| 318 | ! R : UPPER LIMIT OF THE INTERVAL (INPUT) |
| 319 | ! J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT) |
| 320 | ! I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT) |
| 321 | ! |
| 322 | 200 I=L |
| 323 | J=R |
| 324 | M=(L+R)/2 |
| 325 | X=A(M) |
| 326 | 220 IF(A(I).GE.X) GO TO 230 |
| 327 | I=I+1 |
| 328 | GO TO 220 |
| 329 | 230 IF(A(J).LE.X) GO TO 231 |
| 330 | J=J-1 |
| 331 | GO TO 230 |
| 332 | ! |
| 333 | 231 IF(I.GT.J) GO TO 232 |
| 334 | W=A(I) |
| 335 | A(I)=A(J) |
| 336 | A(J)=W |
| 337 | I=I+1 |
| 338 | J=J-1 |
| 339 | IF(I.LE.J) GO TO 220 |
| 340 | ! |
| 341 | 232 LEVEL=LEVEL+1 |
| 342 | IF((R-I).GE.(J-L)) GO TO 30 |
| 343 | LT(LEVEL)=L |
| 344 | RT(LEVEL)=J |
| 345 | L=I |
| 346 | GO TO 20 |
| 347 | 30 LT(LEVEL)=I |
| 348 | RT(LEVEL)=R |
| 349 | R=J |
| 350 | GO TO 20 |
| 351 | 50 RETURN |
| 352 | END |
| 353 | |
| 354 | SUBROUTINE DATIMH_LHA (ND,NT) |
| 355 | ! |
| 356 | ! CERN PROGLIB# Z007 DATIMH DUMMY .VERSION KERNFOR 4.03 821008 |
| 357 | ! |
| 358 | !- DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE |
| 359 | |
| 360 | DIMENSION ND(9), NT(9) |
| 361 | ! DIMENSION M(8) |
| 362 | |
| 363 | do i=1,9 |
| 364 | ND(i)=0 |
| 365 | NT(i)=0 |
| 366 | enddo |
| 367 | ! CALL UBLOW (8H29/09/79,M,8) |
| 368 | ! CALL UBUNCH (M,ND,8) |
| 369 | ! CALL UBLOW (8H12.00.00,M,8) |
| 370 | ! CALL UBUNCH (M,NT,8) |
| 371 | RETURN |
| 372 | END |
| 373 | !*********************************************************************** |
| 374 | ! these next added from CERNLIB to allow some photon and pion sets to wo |
| 375 | ! nothing to do with QCDNUM mrw 9/12/2004 |
| 376 | !*********************************************************************** |
| 377 | !* |
| 378 | ! $Id: Sqcdnum.f 365 2008-09-02 09:12:20Z buckley $ |
| 379 | ! |
| 380 | ! $Log$ |
| 381 | ! Revision 1.3 2005/12/02 14:50:54 whalley |
| 382 | ! Changes for new CTEQ code/AB sets |
| 383 | ! |
| 384 | ! Revision 1.2 2005/10/18 10:34:52 whalley |
| 385 | ! small changes from cdf/d0 comments - renamubg conflicting name |
| 386 | ! adding pftopdg, etc. |
| 387 | ! |
| 388 | ! Revision 1.1.1.1 2005/05/06 14:54:44 whalley |
| 389 | ! Initial CVS import of the LHAPDF code and data sets |
| 390 | ! |
| 391 | ! Revision 1.1.1.1 1996/02/15 17:48:17 mclareni |
| 392 | ! Kernlib |
| 393 | ! |
| 394 | ! |
| 395 | DOUBLE PRECISION FUNCTION DGAMMA_LHA(X) |
| 396 | LOGICAL MFLAG,RFLAG |
| 397 | REAL SX |
| 398 | DOUBLE PRECISION X,U,F,ZERO,ONE,THREE,FOUR,PI |
| 399 | DOUBLE PRECISION C(0:24),H,ALFA,B0,B1,B2 |
| 400 | DATA ZERO /0.0D0/, ONE /1.0D0/, THREE /3.0D0/, FOUR /4.0D0/ |
| 401 | !#if defined(CERNLIB_NUMHIPRE) |
| 402 | ! DATA NC /24/ |
| 403 | ! DATA PI /3.14159 26535 89793 23846 26433 83D0/ |
| 404 | ! DATA C( 0) /3.65738 77250 83382 43849 88068 39D0/ |
| 405 | ! DATA C( 1) /1.95754 34566 61268 26928 33742 26D0/ |
| 406 | ! DATA C( 2) / .33829 71138 26160 38915 58510 73D0/ |
| 407 | ! DATA C( 3) / .04208 95127 65575 49198 51083 97D0/ |
| 408 | ! DATA C( 4) / .00428 76504 82129 08770 04289 08D0/ |
| 409 | ! DATA C( 5) / .00036 52121 69294 61767 02198 22D0/ |
| 410 | ! DATA C( 6) / .00002 74006 42226 42200 27170 66D0/ |
| 411 | ! DATA C( 7) / .00000 18124 02333 65124 44603 05D0/ |
| 412 | ! DATA C( 8) / .00000 01096 57758 65997 06993 06D0/ |
| 413 | ! DATA C( 9) / .00000 00059 87184 04552 00046 95D0/ |
| 414 | ! DATA C(10) / .00000 00003 07690 80535 24777 71D0/ |
| 415 | ! DATA C(11) / .00000 00000 14317 93029 61915 76D0/ |
| 416 | ! DATA C(12) / .00000 00000 00651 08773 34803 70D0/ |
| 417 | ! DATA C(13) / .00000 00000 00025 95849 89822 28D0/ |
| 418 | ! DATA C(14) / .00000 00000 00001 10789 38922 59D0/ |
| 419 | ! DATA C(15) / .00000 00000 00000 03547 43620 17D0/ |
| 420 | ! DATA C(16) / .00000 00000 00000 00168 86075 04D0/ |
| 421 | ! DATA C(17) / .00000 00000 00000 00002 73543 58D0/ |
| 422 | ! DATA C(18) / .00000 00000 00000 00000 30297 74D0/ |
| 423 | ! DATA C(19) /-.00000 00000 00000 00000 00571 22D0/ |
| 424 | ! DATA C(20) / .00000 00000 00000 00000 00090 77D0/ |
| 425 | ! DATA C(21) /-.00000 00000 00000 00000 00005 05D0/ |
| 426 | ! DATA C(22) / .00000 00000 00000 00000 00000 41D0/ |
| 427 | ! DATA C(23) /-.00000 00000 00000 00000 00000 03D0/ |
| 428 | ! DATA C(24) / .00000 00000 00000 00000 00000 01D0/ |
| 429 | !#endif |
| 430 | !#if defined(CERNLIB_NUMLOPRE) |
| 431 | DATA NC /15/ |
| 432 | DATA PI /3.14159265358979324D0/ |
| 433 | DATA C( 0) /3.65738772508338244D0/ |
| 434 | DATA C( 1) /1.95754345666126827D0/ |
| 435 | DATA C( 2) / .33829711382616039D0/ |
| 436 | DATA C( 3) / .04208951276557549D0/ |
| 437 | DATA C( 4) / .00428765048212909D0/ |
| 438 | DATA C( 5) / .00036521216929462D0/ |
| 439 | DATA C( 6) / .00002740064222642D0/ |
| 440 | DATA C( 7) / .00000181240233365D0/ |
| 441 | DATA C( 8) / .00000010965775866D0/ |
| 442 | DATA C( 9) / .00000000598718405D0/ |
| 443 | DATA C(10) / .00000000030769081D0/ |
| 444 | DATA C(11) / .00000000001431793D0/ |
| 445 | DATA C(12) / .00000000000065109D0/ |
| 446 | DATA C(13) / .00000000000002596D0/ |
| 447 | DATA C(14) / .00000000000000111D0/ |
| 448 | DATA C(15) / .00000000000000004D0/ |
| 449 | !#endif |
| 450 | U=X |
| 451 | IF(X .LE. ZERO) THEN |
| 452 | IF(X .EQ. INT(X)) THEN |
| 453 | CALL KERMTR_LHA('C305.1',LGFILE,MFLAG,RFLAG) |
| 454 | IF(MFLAG) THEN |
| 455 | SX=X |
| 456 | IF(LGFILE .EQ. 0) THEN |
| 457 | WRITE(*,100) SX |
| 458 | ELSE |
| 459 | WRITE(LGFILE,100) SX |
| 460 | END IF |
| 461 | END IF |
| 462 | IF(.NOT.RFLAG) CALL ABEND_LHA |
| 463 | DGAMMA_LHA=ZERO |
| 464 | RETURN |
| 465 | ELSE |
| 466 | U=ONE-U |
| 467 | END IF |
| 468 | END IF |
| 469 | F=ONE |
| 470 | IF(U .LT. THREE) THEN |
| 471 | DO 1 I = 1,INT(FOUR-U) |
| 472 | F=F/U |
| 473 | 1 U=U+ONE |
| 474 | ELSE |
| 475 | DO 2 I = 1,INT(U-THREE) |
| 476 | U=U-ONE |
| 477 | 2 F=F*U |
| 478 | END IF |
| 479 | U=U-THREE |
| 480 | H=U+U-ONE |
| 481 | ALFA=H+H |
| 482 | B1=ZERO |
| 483 | B2=ZERO |
| 484 | DO 3 I = NC,0,-1 |
| 485 | B0=C(I)+ALFA*B1-B2 |
| 486 | B2=B1 |
| 487 | 3 B1=B0 |
| 488 | U=F*(B0-H*B2) |
| 489 | IF(X .LT. ZERO) U=PI/(SIN(PI*X)*U) |
| 490 | DGAMMA_LHA=U |
| 491 | RETURN |
| 492 | 100 FORMAT(1X,'DGAMMA ... ARGUMENT IS NON-POSITIVE INTEGER = ',E15.1) |
| 493 | END |
| 494 | !======================================================================= |
| 495 | SUBROUTINE KERSET_LHA(ERCODE,LGFILE,LIMITM,LIMITR) |
| 496 | PARAMETER(KOUNTE = 28) |
| 497 | CHARACTER*6 ERCODE, CODE(KOUNTE) |
| 498 | LOGICAL MFLAG, RFLAG |
| 499 | INTEGER KNTM(KOUNTE), KNTR(KOUNTE) |
| 500 | DATA LOGF / 0 / |
| 501 | DATA CODE(1), KNTM(1), KNTR(1) / 'C204.1', 100, 100 / |
| 502 | DATA CODE(2), KNTM(2), KNTR(2) / 'C204.2', 100, 100 / |
| 503 | DATA CODE(3), KNTM(3), KNTR(3) / 'C204.3', 100, 100 / |
| 504 | DATA CODE(4), KNTM(4), KNTR(4) / 'C205.1', 100, 100 / |
| 505 | DATA CODE(5), KNTM(5), KNTR(5) / 'C205.2', 100, 100 / |
| 506 | DATA CODE(6), KNTM(6), KNTR(6) / 'C205.3', 100, 100 / |
| 507 | DATA CODE(7), KNTM(7), KNTR(7) / 'C305.1', 100, 100 / |
| 508 | DATA CODE(8), KNTM(8), KNTR(8) / 'C308.1', 100, 100 / |
| 509 | DATA CODE(9), KNTM(9), KNTR(9) / 'C312.1', 100, 100 / |
| 510 | DATA CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 / |
| 511 | DATA CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 / |
| 512 | DATA CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 / |
| 513 | DATA CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 / |
| 514 | DATA CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 / |
| 515 | DATA CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 / |
| 516 | DATA CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 / |
| 517 | DATA CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 / |
| 518 | DATA CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 / |
| 519 | DATA CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 / |
| 520 | DATA CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 / |
| 521 | DATA CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 / |
| 522 | DATA CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 / |
| 523 | DATA CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100, 0 / |
| 524 | DATA CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100, 0 / |
| 525 | DATA CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100, 0 / |
| 526 | DATA CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100, 0 / |
| 527 | DATA CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 / |
| 528 | DATA CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 / |
| 529 | LOGF = LGFILE |
| 530 | IF(ERCODE .EQ. ' ') THEN |
| 531 | L = 0 |
| 532 | ELSE |
| 533 | DO 10 L = 1, 6 |
| 534 | IF(ERCODE(1:L) .EQ. ERCODE) GOTO 12 |
| 535 | 10 CONTINUE |
| 536 | 12 CONTINUE |
| 537 | ENDIF |
| 538 | DO 14 I = 1, KOUNTE |
| 539 | IF(L .EQ. 0) GOTO 13 |
| 540 | IF(CODE(I)(1:L) .NE. ERCODE(1:L)) GOTO 14 |
| 541 | 13 KNTM(I) = LIMITM |
| 542 | KNTR(I) = LIMITR |
| 543 | 14 CONTINUE |
| 544 | RETURN |
| 545 | ENTRY KERMTR_LHA(ERCODE,LOG,MFLAG,RFLAG) |
| 546 | LOG = LOGF |
| 547 | DO 20 I = 1, KOUNTE |
| 548 | IF(ERCODE .EQ. CODE(I)) GOTO 21 |
| 549 | 20 CONTINUE |
| 550 | WRITE(*,1000) ERCODE |
| 551 | CALL ABEND_LHA |
| 552 | RETURN |
| 553 | 21 RFLAG = KNTR(I) .GE. 1 |
| 554 | IF(RFLAG .AND. (KNTR(I) .LT. 100)) KNTR(I) = KNTR(I) - 1 |
| 555 | MFLAG = KNTM(I) .GE. 1 |
| 556 | IF(MFLAG .AND. (KNTM(I) .LT. 100)) KNTM(I) = KNTM(I) - 1 |
| 557 | IF(.NOT. RFLAG) THEN |
| 558 | IF(LOGF .LT. 1) THEN |
| 559 | WRITE(*,1001) CODE(I) |
| 560 | ELSE |
| 561 | WRITE(LOGF,1001) CODE(I) |
| 562 | ENDIF |
| 563 | ENDIF |
| 564 | IF(MFLAG .AND. RFLAG) THEN |
| 565 | IF(LOGF .LT. 1) THEN |
| 566 | WRITE(*,1002) CODE(I) |
| 567 | ELSE |
| 568 | WRITE(LOGF,1002) CODE(I) |
| 569 | ENDIF |
| 570 | ENDIF |
| 571 | RETURN |
| 572 | 1000 FORMAT(' KERNLIB LIBRARY ERROR. ' / & |
| 573 | & ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR', & |
| 574 | & ' ERROR MONITOR. RUN ABORTED.') |
| 575 | 1001 FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ', & |
| 576 | & 'CONDITION ',A6) |
| 577 | 1002 FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6) |
| 578 | END |
| 579 | !======================================================================= |
| 580 | SUBROUTINE ABEND_LHA |
| 581 | ! |
| 582 | ! CERN PROGLIB# Z035 ABEND .VERSION KERNVAX 1.10 811126 |
| 583 | |
| 584 | STOP '*** ABEND ***' |
| 585 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame