1*DECK QC36J 2 SUBROUTINE QC36J (LUN, KPRINT, IPASS) 3C***BEGIN PROLOGUE QC36J 4C***SUBSIDIARY 5C***PURPOSE THIS IS A QUICK CHECK PROGRAM FOR THE SUBROUTINES RC3JJ, 6C RC3JM, AND RC6J, WHICH CALCULATE THE WIGNER COEFFICIENTS, 7C 3J AND 6J. 8C***LIBRARY SLATEC 9C***CATEGORY C19 10C***TYPE SINGLE PRECISION (QC36J-S, DQC36J-D) 11C***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, 6J COEFFICIENTS, 6J SYMBOLS, 12C CLEBSCH-GORDAN COEFFICIENTS, QUICK CHECK, 13C RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, 14C WIGNER COEFFICIENTS 15C***AUTHOR LOZIER, DANIEL W., (NIST) 16C MCCLAIN, MARJORIE A., (NIST) 17C SMITH, JOHN M., (NIST AND GEORGE MASON UNIVERSITY) 18C***REFERENCES MESSIAH, ALBERT., QUANTUM MECHANICS, VOLUME II, 19C NORTH-HOLLAND PUBLISHING COMPANY, 1963. 20C***ROUTINES CALLED NUMXER, R1MACH, RC3JJ, RC3JM, RC6J, XERCLR, XSETF 21C***REVISION HISTORY (YYMMDD) 22C 891129 DATE WRITTEN 23C 910415 Mixed type expressions eliminated; precision of output 24C formats made uniform for all tests; detail added to output 25C when KPRINT=2 and a test fails; name of quick check added 26C to output when KPRINT=3 or KPRINT=2 and a test fails; some 27C output formats modified for clarity or adherence to SLATEC 28C guidelines. These changes were done by D. W. Lozier. 29C 930115 Replaced direct calculation of 3j-6j symbols in tests 1, 2, 30C and 4 with values stored in data statements. This involved 31C removing all calls to subroutine RACAH. These changes were 32C made by M. McClain. 33C***END PROLOGUE QC36J 34C 35 INTEGER LUN, KPRINT, IPASS 36C 37 CHARACTER STRING*36, FMT*30, FMT2*13 38 INTEGER IPASS1, IPASS2, IPASS3, IPASS4, IPASS5, NDIM, IER, INDEX, 39 + I, FIRST, LAST, NSIG, NUMXER, NERR, IERJJ, IERJM 40 PARAMETER(NDIM=15) 41 REAL TOL, L1, L2, L3, M1, M2, M3, L1MIN, L1MAX, M2MIN, M2MAX, 42 + DIFF(NDIM), R1MACH, X, JJVAL, JMVAL, THRCOF(NDIM), 43 + SIXCOF(NDIM), R3JJ(8), R3JM(14), R6J(15) 44C 45 DATA R3JJ / 2.78886675511358515993E-1, 46 + -9.53462589245592315447E-2, 47 + -6.74199862463242086246E-2, 48 + 1.53311035167966641297E-1, 49 + -1.56446554693685969725E-1, 50 + 1.09945041215655051079E-1, 51 + -5.53623569313171943334E-2, 52 + 1.79983545113778583298E-2/ 53C 54 DATA R3JM / 2.09158973288615242614E-2, 55 + 8.53756555321524722127E-2, 56 + 9.08295370868692516943E-2, 57 + -3.89054377846499391700E-2, 58 + -6.63734970165680635691E-2, 59 + 6.49524040528389395031E-2, 60 + 2.15894310595403759392E-2, 61 + -7.78912711785239219992E-2, 62 + 3.59764371059543401880E-2, 63 + 5.47301500021263423079E-2, 64 + -7.59678665956761514629E-2, 65 + -2.19224445539892113776E-2, 66 + 1.01167744280772202424E-1, 67 + 7.34825726244719704696E-2/ 68C 69 DATA R6J / 3.49090513837329977746E-2, 70 + -3.74302503965979160859E-2, 71 + 1.89086639095956018415E-2, 72 + 7.34244825492864345709E-3, 73 + -2.35893518508179445858E-2, 74 + 1.91347695521543652000E-2, 75 + 1.28801739772417220844E-3, 76 + -1.93001836629052653977E-2, 77 + 1.67730594938288876974E-2, 78 + 5.50114727485094871674E-3, 79 + -2.13543979089683097421E-2, 80 + 3.46036445143538730828E-3, 81 + 2.52095005479558458604E-2, 82 + 1.48399056122171330285E-2, 83 + 2.70857768063318559724E-3/ 84C 85C***FIRST EXECUTABLE STATEMENT QC36J 86C 87C --- INITIALIZATION OF TESTS 88 TOL=100.0*R1MACH(3) 89 IF(KPRINT.GE.2)THEN 90 WRITE(LUN,*)' THIS IS QC36J, A TEST PROGRAM FOR THE ' // 91 + 'SINGLE PRECISION 3J6J PACKAGE.' 92 WRITE(LUN,*)' AN EXPLANATION OF THE VARIOUS ' // 93 + 'TESTS CAN BE FOUND IN THE PROGRAM COMMENTS.' 94 WRITE(LUN,*) 95 ENDIF 96C 97C --- FIND NUMBER OF SIGNIFICANT FIGURES FOR FORMATTING 98 X=1.0/3.0 99 WRITE(STRING,100)X 100 100 FORMAT(F35.25) 101 DO 200 I=1,35 102 IF(STRING(I:I).EQ.'3')THEN 103 FIRST=I 104 GOTO 300 105 ENDIF 106 200 CONTINUE 107 300 CONTINUE 108 DO 400 I=FIRST,35 109 IF(STRING(I:I).NE.'3')THEN 110 LAST=I-1 111 GOTO 500 112 ENDIF 113 400 CONTINUE 114 LAST=36 115 500 CONTINUE 116 NSIG=LAST-FIRST+1 117 FMT(1:16)='(1X,F5.1,T8,G35.' 118 WRITE(FMT(17:18),'(I2)')NSIG 119 FMT(19:27)=',T45,G35.' 120 WRITE(FMT(28:29),'(I2)')NSIG 121 FMT(30:30)=')' 122 FMT2(1:10)='(1X,A,G35.' 123 WRITE(FMT2(11:12),'(I2)')NSIG 124 FMT2(13:13)=')' 125C 126C --- TEST 1: COMPARE RC3JJ VALUES WITH FORMULA 127 IPASS1=1 128 L2=4.5 129 L3=3.5 130 M2=-3.5 131 M3=2.5 132 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) 133 IF(IER.NE.0)THEN 134 IPASS1=0 135 ELSE 136 DO 550 L1=L1MIN,L1MAX 137 INDEX=INT(L1-L1MIN)+1 138 M1=1.0 139 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JJ(INDEX)) 140 IF(DIFF(INDEX).GT.ABS(R3JJ(INDEX))*TOL)IPASS1=0 141 550 CONTINUE 142 ENDIF 143 IF(KPRINT.GE.3 .OR. (KPRINT.EQ.2.AND.IPASS1.EQ.0))THEN 144 WRITE(LUN,*)' TEST 1, RECURRENCE IN L1, COMPARE VALUES OF 3J ', 145 + 'CALCULATED BY RC3JJ TO' 146 WRITE(LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', 147 + 'MESSIAH''S QUANTUM MECHANICS' 148 WRITE(LUN,600)L2,L3 149 600 FORMAT(' L2 = ',F5.1,' L3 = ',F5.1) 150 WRITE(LUN,700)M1,M2,M3 151 700 FORMAT(' M1 = ',F5.1,' M2 = ',F5.1,' M3 = ',F5.1) 152 IF(IER.NE.0)THEN 153 WRITE(LUN,*)' ERROR RETURNED FROM SUBROUTINE ', 154 + 'RC3JJ: IER =',IER 155 ELSE 156 WRITE(LUN,800) 157 800 FORMAT(' L1',T31,' RC3JJ VALUE',T67,'FORMULA VALUE') 158 DO 900 L1=L1MIN,L1MAX 159 INDEX=INT(L1-L1MIN)+1 160 WRITE(LUN,FMT)L1,THRCOF(INDEX),R3JJ(INDEX) 161 IF(DIFF(INDEX).GT.ABS(R3JJ(INDEX))*TOL)THEN 162 WRITE(LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// 163 + 'TOLERANCE FOR L1 =',L1 164 ENDIF 165 900 CONTINUE 166 ENDIF 167 ENDIF 168 IF(IPASS1.EQ.0)THEN 169 IF(KPRINT.GE.1)THEN 170 WRITE(LUN,*)' ***** ***** TEST 1 FAILED ***** *****' 171 WRITE(LUN,*) 172 ENDIF 173 ELSE 174 IF(KPRINT.GE.2)THEN 175 WRITE(LUN,*)' ***** ***** TEST 1 PASSED ***** *****' 176 WRITE(LUN,*) 177 ENDIF 178 ENDIF 179C 180C --- TEST 2: COMPARE RC3JM VALUES WITH FORMULA 181 IPASS2=1 182 L1=8.0 183 L2=7.5 184 L3=6.5 185 M1=1.0 186 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 187 IF(IER.NE.0)THEN 188 IPASS2=0 189 ELSE 190 DO 950 M2=M2MIN,M2MAX 191 INDEX=INT(M2-M2MIN)+1 192 M3=-M1-M2 193 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JM(INDEX)) 194 IF(DIFF(INDEX).GT.ABS(R3JM(INDEX))*TOL)IPASS2=0 195 950 CONTINUE 196 ENDIF 197 IF(KPRINT.GE.3 .OR. (KPRINT.EQ.2.AND.IPASS2.EQ.0))THEN 198 WRITE(LUN,*)' TEST 2, RECURRENCE IN M2, COMPARE VALUES OF 3J ', 199 + 'CALCULATED BY RC3JM TO' 200 WRITE(LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', 201 + 'MESSIAH''S QUANTUM MECHANICS' 202 WRITE(LUN,1000)L1,L2,L3 203 1000 FORMAT(' L1 = ',F5.1,' L2 = ',F5.1,' L3 = ',F5.1) 204 WRITE(LUN,1100)M1 205 1100 FORMAT(' M1 = ',F5.1,' M3 = -(M1+M2)') 206 IF(IER.NE.0)THEN 207 WRITE(LUN,*)' ERROR RETURNED FROM SUBROUTINE ', 208 + 'RC3JM: IER =',IER 209 ELSE 210 WRITE(LUN,1200) 211 1200 FORMAT(' M2',T31,' RC3JM VALUE',T67,'FORMULA VALUE') 212 DO 1300 M2=M2MIN,M2MAX 213 INDEX=INT(M2-M2MIN)+1 214 WRITE(LUN,FMT)M2,THRCOF(INDEX),R3JM(INDEX) 215 IF(DIFF(INDEX).GT.ABS(R3JM(INDEX))*TOL)THEN 216 WRITE(LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// 217 + 'TOLERANCE FOR M2 =',M2 218 ENDIF 219 1300 CONTINUE 220 ENDIF 221 ENDIF 222 IF(IPASS2.EQ.0)THEN 223 IF(KPRINT.GE.1)THEN 224 WRITE(LUN,*)' ***** ***** TEST 2 FAILED ***** *****' 225 WRITE(LUN,*) 226 ENDIF 227 ELSE 228 IF(KPRINT.GE.2)THEN 229 WRITE(LUN,*)' ***** ***** TEST 2 PASSED ***** *****' 230 WRITE(LUN,*) 231 ENDIF 232 ENDIF 233C 234C --- TEST3: COMPARE COMMON VALUE OF RC3JJ AND RC3JM 235 IPASS3=1 236 L1=100.0 237 L2=2.0 238 L3=100.0 239 M1=-10.0 240 M2=0.0 241 M3=10.0 242 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IERJJ) 243 JJVAL=THRCOF(3) 244 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IERJM) 245 JMVAL=THRCOF(3) 246 IF(IERJJ.NE.0 .OR. IERJM.NE.0)THEN 247 IPASS3=0 248 ELSE 249 DIFF(1)=ABS(JJVAL-JMVAL) 250 IF(DIFF(1).GT.0.5*ABS(JJVAL+JMVAL)*TOL)IPASS3=0 251 ENDIF 252 IF(KPRINT.GE.3 .OR. (KPRINT.EQ.2.AND.IPASS3.EQ.0))THEN 253 WRITE(LUN,*)' TEST 3, COMPARE A COMMON VALUE CALCULATED BY ', 254 + 'BOTH RC3JJ AND RC3JM' 255 WRITE(LUN,*)' L1 = 100.0 L2 = 2.0 L3 = 100.0' 256 WRITE(LUN,*)' M1 = -10.0 M2 = 0.0 M3 = 10.0' 257 IF(IERJJ.NE.0)THEN 258 WRITE(LUN,*)' ERROR RETURNED FROM SUBROUTINE ', 259 + 'RC3JJ: IER =',IERJJ 260 ELSEIF(IERJM.NE.0)THEN 261 WRITE(LUN,*)' ERROR RETURNED FROM SUBROUTINE ', 262 + 'RC3JM: IER =',IERJM 263 ELSE 264 WRITE(LUN,FMT2)'RC3JJ VALUE =',JJVAL 265 WRITE(LUN,FMT2)'RC3JM VALUE =',JMVAL 266 IF(DIFF(1).GT.0.5*ABS(JJVAL+JMVAL)*TOL)THEN 267 WRITE(LUN,'(1X,A)')'DIFFERENCE EXCEEDS ERROR TOLERANCE' 268 ENDIF 269 ENDIF 270 ENDIF 271 IF(IPASS3.EQ.0)THEN 272 IF(KPRINT.GE.1)THEN 273 WRITE(LUN,*)' ***** ***** TEST 3 FAILED ***** *****' 274 WRITE(LUN,*) 275 ENDIF 276 ELSE 277 IF(KPRINT.GE.2)THEN 278 WRITE(LUN,*)' ***** ***** TEST 3 PASSED ***** *****' 279 WRITE(LUN,*) 280 ENDIF 281 ENDIF 282C 283C --- TEST 4: COMPARE RC6J VALUES WITH FORMULA 284 IPASS4=1 285 L2=8.0 286 L3=7.0 287 M1=6.5 288 M2=7.5 289 M3=7.5 290 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 291 IF(IER.NE.0)THEN 292 IPASS4=0 293 ELSE 294 DO 1310 L1=L1MIN,L1MAX 295 INDEX=INT(L1-L1MIN)+1 296 DIFF(INDEX)=ABS(SIXCOF(INDEX)-R6J(INDEX)) 297 IF(DIFF(INDEX).GT.ABS(R6J(INDEX))*TOL)IPASS4=0 298 1310 CONTINUE 299 ENDIF 300 IF(KPRINT.GE.3 .OR. (KPRINT.EQ.2.AND.IPASS4.EQ.0))THEN 301 WRITE(LUN,*)' TEST 4, RECURRENCE IN L1, COMPARE VALUES OF 6J ', 302 + 'CALCULATED BY RC6J TO' 303 WRITE(LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', 304 + 'MESSIAH''S QUANTUM MECHANICS' 305 WRITE(LUN,600)L2,L3 306 WRITE(LUN,700)M1,M2,M3 307 IF(IER.NE.0)THEN 308 WRITE(LUN,*)' ERROR RETURNED FROM SUBROUTINE ', 309 + 'RC6J: IER =',IER 310 ELSE 311 WRITE(LUN,1320) 312 1320 FORMAT(' L1',T32,' RC6J VALUE',T67,'FORMULA VALUE') 313 DO 1350 L1=L1MIN,L1MAX 314 INDEX=INT(L1-L1MIN)+1 315 WRITE(LUN,FMT)L1,SIXCOF(INDEX),R6J(INDEX) 316 IF(DIFF(INDEX).GT.ABS(R6J(INDEX))*TOL)THEN 317 WRITE(LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// 318 + 'TOLERANCE FOR L1 =',L1 319 ENDIF 320 1350 CONTINUE 321 ENDIF 322 ENDIF 323 IF(IPASS4.EQ.0)THEN 324 IF(KPRINT.GE.1)THEN 325 WRITE(LUN,*)' ***** ***** TEST 4 FAILED ***** *****' 326 WRITE(LUN,*) 327 ENDIF 328 ELSE 329 IF(KPRINT.GE.2)THEN 330 WRITE(LUN,*)' ***** ***** TEST 4 PASSED ***** *****' 331 WRITE(LUN,*) 332 ENDIF 333 ENDIF 334C 335C --- TEST 5: CHECK INVALID INPUT 336 IPASS5=1 337 IF(KPRINT.LE.2)THEN 338 CALL XSETF(0) 339 ELSE 340 CALL XSETF(-1) 341 ENDIF 342 IF(KPRINT.GE.3)WRITE(LUN,*)' TEST 5, CHECK FOR PROPER HANDLING ', 343 + 'OF INVALID INPUT' 344C --- RC3JJ: L2-ABS(M2) OR L3-ABS(M3) LESS THAN ZERO (IER=1) 345 L2=2.0 346 L3=100.0 347 M1=-6.0 348 M2=-4.0 349 M3=10.0 350 IF(KPRINT.GE.3)WRITE(LUN,*) 351 CALL XERCLR 352 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) 353 IF(NUMXER(NERR).NE.IER)IPASS5=0 354C --- RC3JJ: L2+ABS(M2) OR L3+ABS(M3) NOT INTEGER (IER=2) 355 L2=2.0 356 L3=99.5 357 M1=-10.0 358 M2=0.0 359 M3=10.0 360 IF(KPRINT.GE.3)WRITE(LUN,*) 361 CALL XERCLR 362 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) 363 IF(NUMXER(NERR).NE.IER)IPASS5=0 364C --- RC3JJ: L1MAX-L1MIN NOT INTEGER (IER=3) 365 L2=3.2 366 L3=4.5 367 M1=-1.3 368 M2=0.8 369 M3=0.5 370 IF(KPRINT.GE.3)WRITE(LUN,*) 371 CALL XERCLR 372 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) 373 IF(NUMXER(NERR).NE.IER)IPASS5=0 374C --- RC3JJ: L1MIN GREATER THAN L1MAX (IER=4) 375C (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) 376C --- RC3JJ: DIMENSION OF THRCOF TOO SMALL (IER=5) 377 L2=10.0 378 L3=150.0 379 M1=-10.0 380 M2=0.0 381 M3=10.0 382 IF(KPRINT.GE.3)WRITE(LUN,*) 383 CALL XERCLR 384 CALL RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) 385 IF(NUMXER(NERR).NE.IER)IPASS5=0 386C --- RC3JM: L1-ABS(M1) LESS THAN ZERO OR L1+ABS(M1) NOT INTEGER (IER=1) 387 L1=100.0 388 L2=2.0 389 L3=100.0 390 M1=150.0 391 IF(KPRINT.GE.3)WRITE(LUN,*) 392 CALL XERCLR 393 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 394 IF(NUMXER(NERR).NE.IER)IPASS5=0 395C --- RC3JM: L1, L2, L3 DO NOT SATISFY TRIANGULAR CONDITION (IER=2) 396 L1=20.0 397 L2=5.0 398 L3=10.0 399 M1=-10.0 400 IF(KPRINT.GE.3)WRITE(LUN,*) 401 CALL XERCLR 402 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 403 IF(NUMXER(NERR).NE.IER)IPASS5=0 404C --- RC3JM: L1+L2+L3 NOT INTEGER (IER=3) 405 L1=1.0 406 L2=1.3 407 L3=1.5 408 M1=0.0 409 IF(KPRINT.GE.3)WRITE(LUN,*) 410 CALL XERCLR 411 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 412 IF(NUMXER(NERR).NE.IER)IPASS5=0 413C --- RC3JM: M2MAX-M2MIN NOT INTEGER (IER=4) 414 L1=1.0 415 L2=1.3 416 L3=1.7 417 M1=0.0 418 IF(KPRINT.GE.3)WRITE(LUN,*) 419 CALL XERCLR 420 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 421 IF(NUMXER(NERR).NE.IER)IPASS5=0 422C --- RC3JM: M2MIN GREATER THAN M2MAX (IER=5) 423C (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) 424C --- RC3JM: DIMENSION OF THRCOF TOO SMALL (IER=6) 425 L1=100.0 426 L2=10.0 427 L3=110.0 428 M1=-10.0 429 IF(KPRINT.GE.3)WRITE(LUN,*) 430 CALL XERCLR 431 CALL RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) 432 IF(NUMXER(NERR).NE.IER)IPASS5=0 433C --- RC6J: L2+L3+L5+L6 OR L4+L2+L6 NOT INTEGER (IER=1) 434 L2=0.5 435 L3=1.0 436 M1=0.5 437 M2=2.0 438 M3=3.0 439 IF(KPRINT.GE.3)WRITE(LUN,*) 440 CALL XERCLR 441 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 442 IF(NUMXER(NERR).NE.IER)IPASS5=0 443C --- RC6J: L4, L2, L6 TRIANGULAR CONDITION NOT SATISFIED (IER=2) 444 L2=1.0 445 L3=3.0 446 M1=5.0 447 M2=6.0 448 M3=2.0 449 IF(KPRINT.GE.3)WRITE(LUN,*) 450 CALL XERCLR 451 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 452 IF(NUMXER(NERR).NE.IER)IPASS5=0 453C --- RC6J: L4, L5, L3 TRIANGULAR CONDITION NOT SATISFIED (IER=3) 454 L2=4.0 455 L3=1.0 456 M1=5.0 457 M2=3.0 458 M3=2.0 459 IF(KPRINT.GE.3)WRITE(LUN,*) 460 CALL XERCLR 461 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 462 IF(NUMXER(NERR).NE.IER)IPASS5=0 463C --- RC6J: L1MAX-L1MIN NOT INTEGER (IER=4) 464 L2=0.9 465 L3=0.5 466 M1=0.9 467 M2=0.4 468 M3=0.2 469 IF(KPRINT.GE.3)WRITE(LUN,*) 470 CALL XERCLR 471 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 472 IF(NUMXER(NERR).NE.IER)IPASS5=0 473C --- RC6J: L1MIN GREATER THAN L1MAX (IER=5) 474C (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) 475C --- RC6J: DIMENSION OF SIXCOF TOO SMALL (IER=6) 476 L2=50.0 477 L3=25.0 478 M1=15.0 479 M2=30.0 480 M3=40.0 481 IF(KPRINT.GE.3)WRITE(LUN,*) 482 CALL XERCLR 483 CALL RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) 484 IF(NUMXER(NERR).NE.IER)IPASS5=0 485 IF(IPASS5.EQ.0)THEN 486 IF(KPRINT.GE.1)THEN 487 WRITE(LUN,*)' ***** ***** TEST 5 FAILED ***** *****' 488 WRITE(LUN,*) 489 ENDIF 490 ELSE 491 IF(KPRINT.GE.2)THEN 492 WRITE(LUN,*)' ***** ***** TEST 5 PASSED ***** *****' 493 WRITE(LUN,*) 494 ENDIF 495 ENDIF 496C 497C --- END OF TESTS 498 IF((IPASS1.EQ.0).OR.(IPASS2.EQ.0).OR.(IPASS3.EQ.0).OR. 499 + (IPASS4.EQ.0).OR.(IPASS5.EQ.0))THEN 500 IPASS=0 501 IF(KPRINT.GE.1)WRITE(LUN,1500) 502 ELSE 503 IPASS=1 504 IF(KPRINT.GE.2)WRITE(LUN,1600) 505 ENDIF 506 1500 FORMAT(' ***** QC36J FAILED SOME TESTS *****') 507 1600 FORMAT(' ***** QC36J PASSED ALL TESTS *****') 508C 509 RETURN 510 END 511