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