|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 41472 (0xa200)
Types: TextFile
Names: »per1«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »per1«
c program 1 aagd
c
c aagdnjsym. a program to calculate a general recoupling
c coefficient.
c burke, p.g.
c ref. in comp. phys. commun. 1 (1970) 241 and
c in comp. phys. commun. 2 (1971) 173 and
c comp. phys. commun. 2 (1971) 181 and
c comp. phys. commun. 5 (1973) 161.
C
C
C
C DESCRIPTION OF COMMON BLOCKS
C
C C O M M O N B L O C K C O U P L E
C
C M THE TOTAL NUMBER OF ANGULAR MOMENTUM VALUES IN THE
C INITIAL AND FINAL STATES
C N THE NUMBER OF BASIC ANGULAR MOMENTUM VALUES THAT
C ARE COUPLED
C J1(I),I=1,M THE ANGULAR MOMENTUM VALUES STORED AS 2J+1
C J2(I,J),I=1,(N-1),J=1,3 THE POSITION IN THE J1 ARRAY OF THE
C INITIAL STATE TRIADS
C J3(I,J),I=1,(N-1),J=1,3 THE POSITION IN THE J1 ARRAY OF THE
C FINAL STATE TRIADS
C
C
C
C C O M M O N B L O C K D E B U G
C
C IBUG1 NOT USED
C IBUG2 NOT USED
C IBUG3 DEBUG PRINTS IN NJSYM AND GENSUM IF IBUG3 EQUALS 1
C IBUG4 NOT USED
C IBUG5 NOT USED
C IBUG6 NOT USED
C
C
C
C C O M M O N B L O C K D E P T H S
C
C J40J0,J=1,M THE LEVEL OF J IN THE J2 COUPLING TREE EVALUATED
C BY SUBROUTINE GENJ45
C J50J0,J=1,M THE LEVEL OF J IN THE J3 COUPLING TREE EVALUATED
C BY SUBROUTINE GENJ45
C
C
C C O M M O N B L O C K D I M E N
C
C KFL1 A TEST TO DETERMINE WHETHER DIMENSION TESTS SET
C KFL2 TEST ON DIMENSIONS OF J2 AND J3 ARRAYS
C KFL3 TEST ON DIMENSION OF KW ARRAY
C KFL4 TEST ON DIMENSIONS OF J1,K6 AND K8 ARRAYS
C KFL5 TEST ON DIMENSIONS OF K7 ARRAY
C KFL6 TEST ON DIMENSIONS OF JSUM1,JSUM2 ETC ARRAYS USED
C IN GENSUM
C
C
C C O M M O N B L O C K I N F O R M
C
C IREAD INPUT CHANNEL NUMBER
C IWRITE OUTPUT CHANNEL NUMBER
C
C
C
C C O M M O N B L O C K W C O M I 9
C
C I3 CONTAINS THE COLUMN OF THE J2 ARRAY WHICH CONTAINS
C THE FIRST ELEMENT TO BE BROUGHT INTO THE SAME
C TRIAD BY RECOUPLING. INPUT TO SUBROUTINE GENI9
C I4 CONTAINS THE COLUMN OF THE J2 ARRAY WHICH CONTAINS
C THE SECOND ELEMENT TO BE BROUGHT INTO THE SAME
C TRIAD BY RECOUPLING. INPUT TO SUBROUTINE GENI9
C I5 CONTAINS THE ROW OF THE J2 ARRAY WHICH CONTAINS
C THE FIRST ELEMENT,INPUT TO SUBROUTINE GENI9
C I6 CONTAINS THE ROW OF THE J2 ARRAY WHICH CONTAINS
C THE SECOND ELEMENT,INPUT TO SUBROUTINE GENI9
C I7 CONTAINS THE LEVEL OF THE I5 TRIAD BELOW THE
C COMMON TRIAD IN COUPLING SCHEME OF J2,EVALUATED BY
C SUBROUTINE GENI9
C I8 CONTAINS THE LEVEL OF THE I6 TRIAD BELOW THE
C COMMON TRIAD IN COUPLING SCHEME OF J2,EVALUATED BY
C SUBROUTINE GENI9
C I9 CONTAINS THE NUMBER OF RECOUPLINGS PLUS TWO.
C EVALUATED BY SUBROUTINE GENI9
C I17 CONTAINS THE ROW OF THE J2 ARRAY CONTAINING THE
C HIGHEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
C I18 CONTAINS THE ROW OF THE J2 ARRAY CONTAINING THE
C LOWEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
C I19 CONTAINS THE COLUMN OF THE J2 ARRAY CONTAINING THE
C HIGHEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
C I20 CONTAINS THE COLUMN OF THE J2 ARRAY CONTAINING
C THE LOWEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
C
C
C
C
C
program TESTNJSYM
C
C READS AND WRITES RECOUPLING MATRICES J1,J2,AND J3
C CALLS NJSYM AND GENSUM AND WRITES OUT RESULT
C
DIMENSION K6(40),K7(80),K8(40),KW(6,20)
COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
common/debug/ibug1,ibug2,ibug3,ibug4,ibug5,ibug6,ibug7,ibug8,ibug9
COMMON/DEPTHS/J4(40),J5(40)
common/inform/iread,iwrite,ipunch
C
C FORMAT STATEMENTS
C
1 FORMAT(12I5)
2 FORMAT(7H RECUP=,E15.7///)
3 FORMAT(3H M=,I3,3H N=,I3//)
4 FORMAT(4H J1=,25I4)
5 FORMAT(19H J2 J3)
6 FORMAT(4X,3I4,4X,3I4)
9 FORMAT(23H1TEST OUTPUT FROM NJSYM////)
C
C SET INPUT AND OUTPUT CHANNEL NUMBERS
zone readf(200,1,stderror)
zone writef(400,1,stderror)
zone punchf(400,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call zassign(punchf,8)
call open(readf,4,'readf',0)
call open(writef,4,'writef',0)
c call open(punchf,4,'punchf',0)
C
iread=1
iwrite=2
ipunch=3
C
C SET DEBUG PRINTS ZERO
C
IBUG1 = 0
IBUG2 = 0
IBUG3 = 0
IBUG4 = 0
IBUG5 = 0
IBUG6 = 0
C
C READ AND WRITE INPUT DATA
C
WRITE(IWRITE,9)
8 READ(IREAD,1) M,N
K=N-1
READ(IREAD,1) (J1(J),J=1,M)
READ(IREAD,1) ((J2(I,J),J=1,3),I=1,K)
READ(IREAD,1) ((J3(I,J),J=1,3),I=1,K)
WRITE(IWRITE,3) M,N
WRITE(IWRITE,4) (J1(J),J=1,M)
WRITE(IWRITE,5)
DO 7 I=1,K
WRITE(IWRITE,6) (J2(I,J),J=1,3),(J3(I,J),J=1,3)
7 CONTINUE
C
C CALLS NJSYM AND GENSUM AND WRITES OUT RESULT
C
CALL NJSYM (J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
WRITE(IWRITE,2) RECUP
READ(IREAD,1) (J1(J),J=1,M)
WRITE(IWRITE,4) (J1(J),J=1,M)
CALL GENSUM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
WRITE(IWRITE,2) RECUP
GO TO 8
END
c
c----------------------------------------------------------------------
c n j s y m
c----------------------------------------------------------------------
c
SUBROUTINE NJSYM (J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
C
C GENERAL RECOUPLING PROGRAMME
C EVALUATES THE RECOUPLING COEFFICIENT RECUP BETWEEN TWO COUPLING
C SCHEMES
C
C
C J6C THE NUMBER OF ELEMENTS IN THE K6 ARRAY
C J7C THE NUMBER OF ELEMENTS IN THE K7 ARRAY
C J8C THE NUMBER OF ELEMENTS IN THE K8 ARRAY
C JWC THE NUMBER OF COLUMNS IN THE KW ARRAY
C K6(I),I=1,J6C. EACH ENTRY CORRESPONDS TO A FACTOR SQRT(2J+1) IN
C RECUP. THE VALUE OF K6 GIVES POSITION IN J1 ARRAY
C WHERE J VALUE IS FOUND
C K7(I),I=1,J7C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**J IN
C RECUP
C K8(I),I=1,J8C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**(-J) IN
C RECUP
C KW(I,J),I=1,6,J=1,JWC. EACH COLUMN CORRESPONDS TO A RACAH
C COEFFICIENT IN RECUP
C RECUP THE RESULTANT RECOUPLING COEFFICIENT EVALUATED
C AND STORED IN RECUP
C
C
C THE ARRAYS K6,K7,K8 AND KW ARE EVALUATED BY NJSYM. THE ENTRY IN
C EACH CASE CORRESPONDS TO A POSITION IN THE J1 ARRAY WHERE THE
C 2J+1 VALUE IS FOUND IF LESS THAN OR EQUAL TO M,OR TO A SUMMATION
C VARIABLE IF GREATER THAN M
C
C THE SUMMATION OVER THE VARIABLES IN K6,K7,K8 AND KW AND THE
C EVALUATION OF RECUP IS CARRIED OUT IN GENSUM
C
C GENSUM CAN BE RE-ENTERED DIRECTLY TO EVALUATE DIFFERENT
C RECOUPLING COEFFICIENTS WITH THE SAME STRUCTURE BY JUST ALTERING
C THE NUMBERS IN THE J1 ARRAY
C
DIMENSION K6(40),K7(80),K8(40),KW(6,20)
COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
common/debug/ibug1,ibug2,ibug3,ibug4,ibug5,ibug6,ibug7,ibug8,ibug9
COMMON/DEPTHS/J4(40),J5(40)
COMMON/DIMEN/KFL1,KFL2,KFL3,KFL4,KFL5,KFL6
common/inform/iread,iwrite,ipunch
COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
C
C FORMAT STATEMENTS USED IN NJSYM
C
50 FORMAT(59H RECOUPLING COEFFICIENT SET ZERO AS TRIANGLE DOES NOT MA
1TCH)
65 FORMAT(29H FAIL IN RECOUPLING PROGRAMME)
107 FORMAT(4H J1=,20I5)
108 FORMAT(23H J2 J3)
110 FORMAT(3I5,I10,2I5)
111 FORMAT(3H KW)
112 FORMAT(6I5)
113 FORMAT(4H K6=,38I3)
114 FORMAT(4H K7=,38I3)
115 FORMAT(4H K8=,38I3)
c 145 FORMAT(8H JWC = 0,8H J6C = 0,8H J7C = 0,8H J8C = 0)
204 FORMAT(23H KFL2 DIMENSION FAILURE)
207 FORMAT(23H KFL3 DIMENSION FAILURE)
208 FORMAT(23H KFL4 DIMENSION FAILURE)
209 FORMAT(23H KFL5 DIMENSION FAILURE)
221 FORMAT(17H NO KW ARRAYS SET)
226 FORMAT(17H NO K6 ARRAYS SET)
230 FORMAT(17H NO K7 ARRAYS SET)
233 FORMAT(17H NO K8 ARRAYS SET)
C
C SET DIMENSIONVARIABLES AND TEST SOME OF DIMENSIONS
C
IF(KFL1-5) 200,201,200
200 KFL1 = 5
KFL2 = 12
KFL3 = 20
KFL4 = 40
KFL5 = 80
KFL6 = 12
201 IF(KFL2-N+1) 202,203,203
202 WRITE(IWRITE,204)
CALL EXIT
203 IF(KFL4-M) 205,206,206
205 WRITE(IWRITE,208)
CALL EXIT
C
C IP IS THE NUMBER OF INEQUIVALENT TRIADS WHICH HAVE TO BE
C RECOUPLED. IT IS SET INITIALLY TO THE TOTAL NUMBER OF TRIADS AND
C THEN DECREASED IN SECTION 1 BELOW AS THE RECOUPLING PROCEEDS
C UNTIL EVENTUALLY IT REACHES ZERO
C
206 IP=N-1
C
C DEBUG PRINTS
C
IF(IBUG3-1)124,123,124
123 WRITE(IWRITE,108)
DO 125 I=1,IP
WRITE(IWRITE,110) ((J2(I,J),J=1,3),(J3(I,J),J=1,3))
125 CONTINUE
C
C SET COUNTS ZERO. MP IS COUNT ON THE J VALUES WHICH ARE SUMMED
C OVER.
C
124 J6C=0
J7C=0
J8C=0
JWC=0
MP=M
C
C
C
C
C
C S E C T I O N 1
C
C THE FOLLOWING SECTION SEARCHES THE J2 AND J3 ARRAYS TO SEE IF
C ANY TRIADS ARE EQUIVALENT. IF SO IT PUTS THEM AT END OF J2 AND J3
C ARRAYS AND SETS IP EQUAL TO THE NUMBER OF INEQUIVALENT TRIADS
C REMAINING. IF IP=0 THEN THE RECOUPING HAS BEEN COMPLETED AND EXIT
C IS MADE TO GENSUM TO CARRY OUT THE SUMMATIONS
C
117 I1=1
16 DO 1 I2=1,IP
IF(J2(I2,1)-J3(I1,1)) 2,3,2
2 IF(J2(I2,2)-J3(I1,1))1,4,1
1 CONTINUE
C
C NO EQUIVALENT TRIADS WITH THIS VALUE OF I1. INCREASE I1 AND TRY
C AGAIN
C
GO TO 5
3 IF(J2(I2,2)-J3(I1,2))5,6,5
4 IF(J2(I2,1)-J3(I1,2))5,6,5
6 IF(I2-IP)7,8,8
C
C REARRANGE SO THAT EQUIVALENT TRIADS OCCUR AT THE END OF J2 AND
C J3 ARRAYS
C
7 I3=J2(I2,1)
I4=J2(I2,2)
I5=J2(I2,3)
I6=I2+1
DO 9 I7=I6,IP
DO 10 I8=1,3
J2(I7-1,I8)=J2(I7,I8)
10 CONTINUE
9 CONTINUE
J2(IP,1)=I3
J2(IP,2)=I4
J2(IP,3)=I5
8 IF(I1-IP)11,14,14
11 I3=J3(I1,1)
I4=J3(I1,2)
I5=J3(I1,3)
I6=I1+1
DO 12 I7=I6,IP
DO 13 I8=1,3
J3(I7-1,I8)=J3(I7,I8)
13 CONTINUE
12 CONTINUE
J3(IP,1)=I3
J3(IP,2)=I4
J3(IP,3)=I5
C
C IS THE THIRD ELEMENT IN J2 SUMMED OVER. IF SO REPLACE BY THIRD
C ELEMENT IN J3 ARRAY
C
14 IF(J2(IP,3)-M)47,47,44
44 J=J3(IP,3)
JP=J2(IP,3)
J2(IP,3)=J
IF(IP-2)101,18,18
C
C NOW REPLACE ALL OTHER ELEMENTS IN J2,KW,K7,K8 AND K6 WHICH ARE
C SUMMED OVER AT THE SAME TIME BY THE SAME QUANTITY J
C
18 IQ=IP-1
DO 19 I3=1,IQ
DO 20 I4=1,3
IF(J2(I3,I4)-JP) 20,21,20
21 J2(I3,I4)=J
20 CONTINUE
19 CONTINUE
101 IF(JWC)38,38,39
39 DO 23 I=1,6
DO 22 I3=1,JWC
IF(KW(I,I3)-JP) 22,25,22
25 KW(I,I3)=J
22 CONTINUE
23 CONTINUE
38 IF(J7C)87,87,41
41 DO 34 I3=1,J7C
IF(K7(I3)-JP)34,35,34
35 K7(I3)=J
34 CONTINUE
87 IF(J8C)40,40,86
86 DO 88 I3=1,J8C
IF(K8(I3)-JP)88,89,88
89 K8(I3)=J
88 CONTINUE
40 IF(J6C)42,42,43
43 DO 36 I3=1,J6C
IF(K6(I3)-JP)36,37,36
37 K6(I3)=J
36 CONTINUE
C
C SET I1 BACK TO 1 IN ORDER TO START SEARCH FOR EQUIVALENT TRIADS
C AGAIN SINCE SOME ELEMENTS MAY HAVE BEEN ALTERED
C
42 I1=1
C
C TEST WHETHER TRIANGLE MATCHES
C
47 JJ2=J2(IP,3)
JJ3=J3(IP,3)
IF(JJ2-JJ3) 148,49,148
148 IF(J1(JJ2)-J1(JJ3)) 48,44,48
C
C RECOUPLING COEFFICIENT SET ZERO WHEN TRIAD IN INITIAL AND FINAL
C STATES DO NOT MATCH. IN THIS CASE, GENSUM IS NOT CALLED AND THE
C ARRAYS K6,K7,K8,KW ARE NOT SET UP, READY FOR FURTHER DIRECT
C ENTRIES TO GENSUM.
C
48 IF(IBUG3-1) 150,151,150
151 WRITE(IWRITE,50)
150 RECUP=0.
RETURN
C
C IF J2 ANGULAR MOMENTA ARE IN OPPOSITE ORDER TO J3 ANGULAR
C MOMENTA INTERCHANGE THEM AND STORE SIGN CHANGES IN K7 AND K8.
C CHECK DIMENSIONS
C
49 IF(J2(IP,1)-J3(IP,1))100,99,100
100 J=J2(IP,1)
J2(IP,1)=J2(IP,2)
J2(IP,2)=J
K7(J7C+1)=J2(IP,1)
K7(J7C+2)=J2(IP,2)
J7C=J7C+2
K8(J8C+1)=J2(IP,3)
J8C=J8C+1
IF(KFL5-J7C) 210,220,220
220 IF(KFL4-J8C) 212,99,99
C
C DECREASE IP AND RETURN TO LOOK FOR FURTHER EQUIVALENT TRIADS
C
99 IP=IP-1
GO TO 15
5 I1=I1+1
15 IF(I1-IP)16,16,17
C
C IF IP = 0 THIS MEANS THAT ALL TRIADS HAVE BEEN TRANSFORMED TO BE
C EQUIVALENT. NOW EXIT TO SUM OVER RACAH COEFFICIENTS
C
17 IF(IP)126,126,46
C
C
C
C
C
C S E C T I O N 2
C
C ITEST = 0 DETERMINES THE MIMIMUM RECOUPLING OF J2 ARRAY TO
C OBTAIN AN EQUIVALENT TRIAD TO ONE IN J3 ARRAY. STORE ROW OF J3
C ARRAY IN ITEST1.
C ITEST = 1 DETERMINE RECOUPLING OF J2 ARRAY TO OBTAIN AN
C EQUIVALENT TRIAD OF ITEST1 ROW OF J3 ARRAY.
C IN BOTH CASES STORE INFORMATION ON RECOUPLING
C
46 I10=9999
ITEST=0
I1=1
C
C GENJ45 DETERMINES THE LEVEL OF EACH J IN THE COUPLING TREE OF J2
C AND J3 AND STORES THE RESULT IN THE J4 AND J5 ARRAYS RESPECTIVELY
C
96 CALL GENJ45(IP)
C
C LOOK FOR J IN J2 ARRAY WHICH IS SAME AS FIRST ELEMENT IN J3 ARRAY
C
95 DO 52 I2=1,IP
IF(J2(I2,1)-J3(I1,1))53,54,53
53 IF(J2(I2,2)-J3(I1,1))52,55,52
52 CONTINUE
GO TO 51
C
C I3 AND I5 DENOTES POSITION IN J2 ARRAY OF COMMON J
C
54 I3=1
GO TO 60
55 I3=2
60 I5=I2
C
C NOW LOOK FOR J IN J2 ARRAY WHICH IS SAME AS OTHER ELEMENT IN J3
C ARRAY
C
DO 56 I2=1,IP
IF(J2(I2,1)-J3(I1,2))57,58,57
57 IF(J2(I2,2)-J3(I1,2))56,59,56
56 CONTINUE
GO TO 51
C
C I4 AND I6 DENOTES POSITION IN J2 ARRAY OF COMMON J
C
58 I4=1
GO TO 61
59 I4=2
61 I6=I2
C
C I7 AND I8 DENOTE THE POSITION IN THE J1 ARRAY OF THE TWO COMMON J
C VALUES IN J2 AND J3
C
I7=J2(I5,I3)
I8=J2(I6,I4)
C
C GENI9 DETERMINES THE NUMBER OF RECOUPLINGS OF TWO ELEMENTS OF J2
C NECESSARY TO OBTAIN IDENTICAL TRIADS IN J2 AND J3 ARRAYS. THIS
C NUMBER PLUS TWO IS STORED IN I9
C
CALL GENI9(IP)
IF(I9-I10)62,51,51
C
C A SMALLER RECOUPLING PAIR FOUND. STORE LOWEST AS J2(I13,I14) AND
C HIGHEST AS J2(I11,I12). I15 AND I16 CONTAIN LEVEL OF THESE BELOW
C COMMON TRIADS. FINALLY ITEST1 DENOTES TRIAD IN J3 FOR NEXT ENTRY
C TO SECTION 2 AND IS REQUIRED IF MORE THAN ONE RECOUPLING
C
62 I10=I9
I11 = I17
I12 = I19
I13 = I18
I14 = I20
I15=I7
I16=I8
ITEST1=I1
51 IF(ITEST) 98,97,98
C
C I1 IS ONLY INCREASED IF SEARCHING FOR SMALLEST RECOUPLING PAIR
C
97 I1=I1+1
IF(I1-IP)95,95,98
98 IF(I10-9999)63,64,64
C
C FAIL BECAUSE NO PAIR IN J2 AND J3 FOUND WHICH COULD BE RECOUPLED
C
64 WRITE(IWRITE,65)
CALL EXIT
C
C
C
C
C
C S E C T I O N 3
C
C THE PAIR OF J VALUES THAT REQUIRE THE SMALLEST NUMBER OF
C RECOUPLINGS OF J2 TO BRING INTO THE SAME ORDER AS J3 HAS NOW
C BEEN FOUND. THIS SECTION NOW CARRIES OUT ONE RECOUPLING
C
63 IF(I15-I16) 67,68,68
C
C I1 AND I2 DENOTES THE LEVEL ABOVE THE GIVEN LEVELS OF THE TRIAD
C OF ELEMENTS TO BE RECOUPLED
C
67 I1=I15-1
I2=I16-2
GO TO 69
68 I1=I16-1
I2=I15-2
69 I3 = I11
I4 = I13
I5 = I12
I6 = I14
IF(I1)70,70,71
C
C FIND FIRST ELEMENT TO BE RECOUPLED
C
71 DO 72 I=1,I1
DO 73 I7=1,IP
IF(J2(I7,1)-J2(I3,3))74,75,74
74 IF(J2(I7,2)-J2(I3,3)) 73,76,73
73 CONTINUE
75 I5=1
GO TO 77
76 I5=2
77 I3=I7
72 CONTINUE
C
C FIRST ELEMENT TO BE RECOUPLED IS J2(I3,I5)
C NOW FIND SECOND ELEMENT TO BE RECOUPLED
C
70 IF(I2)78,78,79
79 DO 80 I=1,I2
DO 81 I7=1,IP
IF(J2(I7,1)-J2(I4,3))82,83,82
82 IF(J2(I7,2)-J2(I4,3))81,84,81
81 CONTINUE
83 I6=1
GO TO 85
84 I6=2
85 I4=I7
80 CONTINUE
C
C SECOND ELEMENT TO BE RECOUPLED IS J2(I4,I6)
C
78 IF(I6-1)90,90,91
C
C INTERCHANGE ELEMENTS OF I4 ROW OF J2 IF NECESSARY AND INCLUDE
C SIGNS IN K7 AND K8 ARRAYS
C
90 K7(J7C+1)=J2(I4,1)
K7(J7C+2)=J2(I4,2)
J7C=J7C+2
K8(J8C+1)=J2(I4,3)
J8C=J8C+1
I=J2(I4,1)
J2(I4,1)=J2(I4,2)
J2(I4,2)=I
91 IF(I5-1) 92,92,93
C
C INTERCHANGE ELEMENTS OF I3 ROW OF J2 IF NECESSARY AND STORE SIGNS
C IN K7 AND K8 ARRAYS
C
92 K7(J7C+1)=J2(I3,1)
K7(J7C+2)=J2(I3,2)
J7C=J7C+2
K8(J8C+1)=J2(I3,3)
J8C=J8C+1
I=J2(I3,1)
J2(I3,1)=J2(I3,2)
J2(I3,2)=I
C
C NOW RECOUPLE THE TWO ELEMENTS OF J2 AND STORE SQUARE ROOTS IN K6
C AND RACAH COEFFICIENT IN KW ARRAYS. MP DENOTES A J WHICH WILL BE
C SUMMED OVER
C
93 K6(J6C+1)=J2(I4,3)
MP=MP+1
K6(J6C+2)=MP
J6C=J6C+2
JWC=JWC+1
KW(1,JWC)=J2(I4,1)
KW(2,JWC)=J2(I4,2)
KW(3,JWC)=J2(I3,3)
KW(4,JWC)=J2(I3,2)
KW(5,JWC)=J2(I3,1)
KW(6,JWC)=MP
J2(I3,1)=J2(I4,1)
J2(I4,1)=J2(I4,2)
J2(I4,2)=J2(I3,2)
J2(I4,3)=MP
J2(I3,2)=MP
C
C TEST DIMENSIONS AND EXIT IF FAILURE
C
IF(KFL5-J7C)210,211,211
210 WRITE(IWRITE,209)
CALL EXIT
211 IF(KFL4-J8C) 212,213,213
212 WRITE(IWRITE,208)
CALL EXIT
213 IF(KFL4-MP) 212,215,215
215 IF(KFL4-J6C) 212,217,217
217 if(kfl3-jwc) 218,219,219
218 WRITE(IWRITE,207)
CALL EXIT
219 IF(I1+I2) 117,117,94
C
C MORE THAN ONE RECOUPLING REQUIRED. RETURN TO SECTION 2 TO DECIDE
C WHICH ELEMENTS OF J2 TO RECOUPLE IN NEXT STEP. IF ALL RECOUPLINGS
C OF A PARTICULAR PAIR HAVE BEEN CARRIED OUT THEN IDENTICAL PAIRS
C ARE NOW PRESENT IN J2 AND J3 ARRAYS. RETURN TO SECTION 1 TO SEE
C IF ANY MORE RECOUPLING REQUIRED
C
94 ITEST=1
I1=ITEST1
I10=9999
GO TO 96
C
C DEBUG PRINTS
C
126 IF(IBUG3-1) 105,104,105
104 WRITE(IWRITE,107) (J1(I),I=1,M)
WRITE(IWRITE,111)
IF(JWC) 127,127,128
128 DO 116 J=1,JWC
WRITE(IWRITE,112) (KW(I,J),I=1,6)
116 CONTINUE
GO TO 224
127 WRITE(IWRITE,221)
224 IF(J6C) 222,222,223
223 WRITE(IWRITE,113) (K6(J),J=1,J6C)
GO TO 225
222 WRITE(IWRITE,226)
225 IF(J7C) 227,227,228
228 WRITE(IWRITE,114) (K7(J),J=1,J7C)
GO TO 229
227 WRITE(IWRITE,230)
229 IF(J8C) 231,231,232
232 WRITE(IWRITE,115) (K8(J),J=1,J8C)
GO TO 105
231 WRITE(IWRITE,233)
C
C CARRY OUT SUMMATIONS
C
105 CALL GENSUM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
RETURN
END
c
c---------------------------------------------------------------------
c g e n j 4 5
c---------------------------------------------------------------------
c
SUBROUTINE GENJ45(IP)
C
C FIND THE LEVEL OF EACH J IN THE COUPLING TREES OF J2 AND J3 AND
C STORE IN THE J4 AND J5 ARRAYS RESPECTIVELY. IF AN ELEMENT OF J1
C DOES NOT OCCUR IN J2 THE J4 ENTRY IS -1 AND IF AN ELEMENT DOES
C NOT OCCUR IN J3 THE J5 ENTRY IS -1
C
COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
COMMON/DEPTHS/J4(40),J5(40)
C
C
C
DO 1 I=1,M
DO 2 I2=1,IP
C
C STORE LEVEL OF EACH J IN J2 ARRAY IN J4
C
IF (J2(I2,1)-I) 3,4,3
3 IF (J2(I2,2)-I) 2,4,2
2 CONTINUE
DO 17 I2 = 1,IP
IF (J2(I2,3)-I) 17,18,17
17 CONTINUE
J4(I) = -1
GO TO 5
18 J4(I) = 0
GO TO 5
4 I3 = 1
9 DO 6 I4 = 1,IP
IF (J2(I4,1)-J2(I2,3)) 7,8,7
7 IF (J2(I4,2)-J2(I2,3)) 6,8,6
6 CONTINUE
J4(I) = I3
GO TO 5
8 I3 = I3+1
I2 = I4
GO TO 9
C
C STORE LEVEL OF EACH J IN J3 ARRAY IN J5
C
5 DO 10 I2 = 1,IP
IF (J3(I2,1)-I) 11,12,11
11 IF (J3(I2,2)-I) 10,12,10
10 CONTINUE
DO 19 I2 = 1,IP
IF (J3(I2,3)-I) 19,20,19
19 CONTINUE
J5(I) = -1
GO TO 1
20 J5(I) = 0
GO TO 1
12 I3 = 1
16 DO 13 I4 = 1,IP
IF (J3(I4,1)-J3(I2,3)) 14,15,14
14 IF (J3(I4,2)-J3(I2,3)) 13,15,13
13 CONTINUE
J5(I) = I3
GO TO 1
15 I3 = I3+1
I2 = I4
GO TO 16
1 CONTINUE
RETURN
END
c
c-------------------------------------------------------------------------
c g e n i 9
c--------------------------------------------------------------------------
c
SUBROUTINE GENI9(IP)
C
C DETERMINES THE NUMBER OF RECOUPLING NECESSARY TO BRING J2(I5,I3)
C AND J2(I6,I4) INTO THE SAME TRIAD. THIS WILL GIVE A TRIAD
C IDENTICAL WITH ONE IN J3. ON EXIT I9 CONTAINS THE NUMBER OF
C RECOUPLINGS PLUS TWO,I7 CONTAINS THE LEVEL OF THE I5 TRIAD BELOW
C THE COMMON TRIAD AND I8 CONTAINS THE LEVEL OF THE I6 TRIAD BELOW
C THE COMMON TRIADS
C SEE DESCRIPTION OF COMMON BLOCK WCOMI9 FOR FURTHER DETAILS
C
COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
COMMON/DEPTHS/J4(40),J5(40)
COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
C
C
C
I1 = J4(I7)
I2 = J4(I8)
C
C DETERMINES WHICH J OF J2(I5,I3) AND J2(I6,I4) LIES LOWEST, STORE
C LOWEST AS J2(I18,I20) AND HIGHEST AS J2(I17,I19)
C
IF (I1-I2) 1,1,3
1 I17 = I5
I18 = I6
I19 = I3
I20 = I4
I3 = I2-I1
I7 = 0
I8 = I3
I4 = I1
IF (I3) 8,8,2
C
C I6 DENOTES THE LOWEST TRIAD,SCAN TRIADS TO FIND NEW TRIAD I6 AT
C SAME LEVEL AS I5
C
2 DO 4 I = 1,I3
DO 5 J = 1,IP
IF (J2(J,1)-J2(I6,3)) 7,6,7
7 IF (J2(J,2)-J2(I6,3)) 5,6,5
5 CONTINUE
J=IP
6 I6 = J
4 CONTINUE
GO TO 8
3 I17 = I6
I18 = I5
I19 = I4
I20 = I3
I3 = I1-I2
I7 = I3
I8 = 0
C
C I5 DENOTES THE LOWEST TRIADS. SCAN TRIADS TO FIND NEW TRIAD I6 AT
C SAME LEVEL I5
C
DO 9 I = 1,I3
DO 12 J = 1,IP
IF (J2(J,1)-J2(I5,3)) 10,11,10
10 IF (J2(J,2)-J2(I5,3)) 12,11,12
12 CONTINUE
J=IP
11 I5 = J
9 CONTINUE
I4 = I2
C
C I5 AND I6 NOW DENOTES TRIADS AT SAME LEVEL. I4 CONTAINS THE
C COMMON LEVEL
C
8 DO 13 I = 1,I4
I1 = I
IF (I5-I6) 14,21,14
C
C I5 AND I6 DENOTE DIFFERENT TRIADS SCAN TO FIND TRIADS AT NEXT
C LEVEL WHICH REPLACE I5 AND I6
C
14 DO 15 J = 1,IP
IF (J2(J,1)-J2(I5,3)) 16,17,16
16 IF (J2(J,2)-J2(I5,3)) 15,17,15
15 CONTINUE
J=IP
17 I5 = J
DO 18 J = 1,IP
IF (J2(J,1)-J2(I6,3)) 19,20,19
19 IF (J2(J,2)-J2(I6,3)) 18,20,18
18 CONTINUE
J=IP
20 I6 = J
13 CONTINUE
C
C I5 AND I6 NOW BOTH DENOTE THE COMMON TRIAD
C
21 I9 = I3+2*I1
I8 = I8+I1
I7 = I7+I1
RETURN
END
c
c-------------------------------------------------------------------------
c g e n s u m
c-------------------------------------------------------------------------
c
SUBROUTINE GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,RECUP)
C
C CARRIES OUT THE SUMMATION OVER COEFFICIENTS DEFINED BY THE ARRAYS
C J6,J7,J8 AND JW TO GIVE RECUP
C THE ENTRY IS EITHER MADE FROM NJSYM OR DIRECTLY ASSUMING THAT THE
C ARRAYS J6,J7,J8 AND JW HAVE ALREADY BEEN DETERMINED BY A PREVIOUS
C ENTRY TO NJSYM AND THAT THE SUMMATION IS REQUIRED FOR ANOTHER SET
C OF J VALUES DEFINED BY THE ARRAY J1
C THE DEFINITION OF THE ARGUMENT LIST IS GIVEN AT BEGINNING OF
C NJSYM
C
DIMENSION ist(6),JWORD(6,20),J6P(40),J7P(80),J8P(40),JSUM1(12),
1JSUM2(12),JSUM4(12,20),JSUM5(12,20),JSUM3(12),JSUM6(12)
2,JSUM7(12),JSUM8(12),JSUM(2,20),JWTEST(20),WSTOR(20),IPAIR(2,2)
DIMENSION J6(40),J7(80),J8(40),JW(6,20)
COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,ibug7,ibug8,ibug9
COMMON/DIMEN/KFL1,KFL2,KFL3,KFL4,KFL5,KFL6
common/inform/iread,iwrite,ipunch
C
C FORMAT STATEMENTS USED IN GENSUM
C
35 FORMAT (21H FAIL IN GENSUM AT 35)
36 FORMAT (21H FAIL IN GENSUM AT 36)
42 FORMAT (21H FAIL IN GENSUM AT 42)
63 FORMAT (21H FAIL IN GENSUM AT 63)
169 FORMAT(22H 169... RECUP =,F12.8,7H STOR =,F12.8,8H STOR1 =,
1F12.8)
170 FORMAT(18H 170... ist ,6i4)
190 FORMAT(8H WSTOR =,10F10.6)
308 FORMAT(23H KFL6 DIMENSION FAILURE)
311 FORMAT(22H FAIL IN GENSUM AT 310)
C
C
C
C
C
C S E C T I O N 1
C
C EVALUATES ALL TERMS IN J6,J7,J8 AND JW WHICH DO NOT INVOLVE A
C SUMMATION AND FORM MODIFIED ARRAYS J6P,J7P,J8P AND JWORD WHICH DO
C THE RESULT OF THE EVALUATION IS STORED IN RECUP AND AISTOR
C
RECUP = 1.0
MAXJWE=M
JWRD = 0
IF(JWC)302,302,185
C
C MULTIPLY RECUP BY ALL RACAH COEFFICIENTS WHICH DO NOT INVOLVE A
C SUMMATION
C
185 DO 1 I=1,JWC
DO 2 J=1,6
IF(JW(J,I)-M) 2,2,3
2 CONTINUE
DO 4 J=1,6
I1=JW(J,I)
ist(j)=j1(i1)-1
4 CONTINUE
call dracah(ist(1),ist(2),ist(3),ist(4),ist(5),ist(6),x1)
RECUP = RECUP*X1
GO TO 1
C
C JWRD IS THE NUMBER OF RACAH COEFFICIENTS WHICH INVOLVE A
C SUMMATION
C JWORD(I,J),I=1,6,J=1,JWRD CONTAINS THE NUMBER WHICH GIVE THE
C LOCATION OF THE J VALUES FOR THE RACAH COEFFICIENTS EITHER IN THE
C J1 LIST OR IN THE JSUM1 LIST
C
3 JWRD = JWRD+1
DO 5 J=1,6
JWORD(J,JWRD)=JW(J,I)
C
C MAXJWE CONTAINS THE MAXIMUM J IN THE LIST OF VARIABLES TO BE
C SUMMED OVER
C
IF(MAXJWE-JW(J,I)) 215,5,5
215 MAXJWE=JW(J,I)
5 CONTINUE
1 CONTINUE
302 J6CP=0
IF(J6C)300,300,301
C
C J6P(I),I=1,J6CP CONTAINS ALL J6 WHICH INVOLVE A SUMMATION
C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT
C
301 DO 6 I=1,J6C
IF(J6(I)-M) 7,7,21
7 I1=J6(I)
RECUP = RECUP*SQRT(FLOAT(J1(I1)))
GO TO 6
21 J6CP = J6CP+1
J6P(J6CP)=J6(I)
6 CONTINUE
300 iastor=0
J7CP = 0
IF(J7C) 303,303,304
C
C J7P(I),I=1,J7CP CONTAINS ALL J7 WHICH INVOLVE A SUMMATION.
C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT
C
304 DO 8 I=1,J7C
IF(J7(I)-M) 9,9,22
9 I1=J7(I)
iastor=iastor+j1(i1)-1
GO TO 8
22 J7CP = J7CP+1
J7P(J7CP)=J7(I)
8 CONTINUE
303 J8CP=0
IF(J8C) 305,305,306
C
C J8CP(I),I=1,J8CP CONTAINS ALL J8 WHICH INVOLVE A SUMMATION
C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT
C
306 DO 10 I=1,J8C
IF(J8(I)-M) 11,11,23
11 I1=J8(I)
iastor=iastor-j1(i1)+1
GO TO 10
23 J8CP=J8CP+1
J8P(J8CP)=J8(I)
10 CONTINUE
C
C NO RACAH COEFFICIENTS REMAINING AND THUS NO SUMMATIONS TO BE
C CARRIED OUT IF JWRD=0. JUMP TO END TO INCLUDE (-1) FACTORS IN
C RECUP AND THEN EXIT
C
305 IF(JWRD) 12,12,13
C
C
C
C
C
C S E C T I O N 2
C
C SEARCH THROUGH THE JWORD LIST TO FIND ALL THE SUMMATION VARIABLES
C NSUM IS THE NUMBER OF SUMMATION VARIABLES
C JSUM1(I),I=1,NSUM CONTAINS A LIST OF ALL SUMMATION VARIABLES IN
C THE SAME NOTATION AS IN JW LIST
C
13 NSUM=0
MAXSUM=MAXJWE-M
DO 24 I=1,MAXSUM
JSUM6(I)=0
JSUM7(I)=0
24 CONTINUE
C
C FIND SUMMATION VARIABLES
C
DO 14 I=1,JWRD
DO 15 J=1,6
IF(JWORD(J,I)-M) 15,15,16
16 NSUM=NSUM+1
IF(NSUM-1) 17,17,18
C
C HAS THE SUMMATION VARIABLE OCCURED BEFORE. IF NOT INCLUDE IN
C JSUM1 LIST
C
18 NSUM1 = NSUM-1
DO 19 I1=1,NSUM1
IF(JWORD(J,I)-JSUM1(I1)) 19,20,19
19 CONTINUE
17 JSUM1(NSUM)=JWORD(J,I)
I1=NSUM
GO TO 25
20 NSUM =NSUM1
C
C JSUM6(I),I=1,NSUM IS THE NUMBER OF TIMES EACH SUMMATION VARIABLE
C OCCURS IN JWORD
C
25 JSUM6(I1)=JSUM6(I1)+1
I2=JSUM6(I1)
C
C JSUM4(I,J),JSUM5(I,J),I=1,NSUM,J=1,JSUM6(I) IS THE POSITION IN
C THE JWORD LIST WHERE THE JSUM1 ELEMENT OCCURS
C
JSUM4(I1,I2)=J
JSUM5(I1,I2)=I
C
C (JWORD-M) GIVES LOCATION IN JSUM1 LIST IF A SUMMATION VARIABLE
C
JWORD(J,I)=M+I1
15 CONTINUE
14 CONTINUE
IF(KFL6-NSUM) 312,307,307
312 WRITE(IWRITE,308)
CALL EXIT
307 IF(J6CP) 26,26,27
C
C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J6P. SET J6P
C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE
C
27 DO 28 I=1,J6CP
DO 29 J=1,NSUM
IF(J6P(I)-JSUM1(J)) 29,30,29
29 CONTINUE
WRITE(IWRITE,35)
CALL EXIT
30 J6P(I)=J
28 CONTINUE
26 IF(J7CP) 130,130,31
C
C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J7P, SET J7P
C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE
C
31 DO 32 I=1,J7CP
DO 33 J=1,NSUM
IF(J7P(I)-JSUM1(J)) 33,34,33
33 CONTINUE
WRITE(IWRITE,36)
CALL EXIT
34 J7P(I)=J
32 CONTINUE
130 IF(J8CP) 37,37,38
C
C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J8P. SET J8P
C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE
C
38 DO 39 I=1,J8CP
DO 40 J=1,NSUM
IF(J8P(I)-JSUM1(J)) 40,41,40
40 CONTINUE
WRITE(IWRITE,42)
CALL EXIT
41 J8P(I)=J
39 CONTINUE
C
C
C
C
C
C S E C T I O N 3
C
C ORDERS THE SUMMATION VARIABLES SO THAT THE RANGE OF EACH
C SUMMATION HAS BEEN PREVIOUSLY DEFINED
C
37 NCT =0
NCT1 = 0
64 DO 43 I=1,JWRD
DO 44 J=1,6
I1=JWORD(J,I)-M
IF(I1) 44,44,45
C
C JSUM7(I),I=1,NSUM IS THE ORDER OF THE SUMMATIONS OVER THE J
C VARIABLES. INITIALLY THIS ARRAY IS ZERO
C
45 IF(JSUM7(I1)) 46,46,44
46 GO TO (47,48,49,50,51,52),J
C
C THE ROWS OF THE IPAIR ARRAYS GIVE LIMITS OF SUMMATION IMPOSED
C BY THE TRIANGULAR CONDITION
C
47 IPAIR(1,1) = JWORD(2,I)
IPAIR(1,2) = JWORD(5,I)
IPAIR(2,1) = JWORD(3,I)
IPAIR(2,2) = JWORD(6,I)
GO TO 53
48 IPAIR(1,1) = JWORD(1,I)
IPAIR(1,2) = JWORD(5,I)
IPAIR(2,1) = JWORD(4,I)
IPAIR(2,2) = JWORD(6,I)
GO TO 53
49 IPAIR(1,1) = JWORD(1,I)
IPAIR(1,2) = JWORD(6,I)
IPAIR(2,1) = JWORD(4,I)
IPAIR(2,2) = JWORD(5,I)
GO TO 53
50 IPAIR(1,1) = JWORD(2,I)
IPAIR(1,2) = JWORD(6,I)
IPAIR(2,1) = JWORD(3,I)
IPAIR(2,2) = JWORD(5,I)
GO TO 53
51 IPAIR(1,1)= JWORD(1,I)
IPAIR(1,2) = JWORD(2,I)
IPAIR(2,1) = JWORD(3,I)
IPAIR(2,2) = JWORD(4,I)
GO TO 53
52 IPAIR(1,1) = JWORD(1,I)
IPAIR(1,2) = JWORD(3,I)
IPAIR(2,1) = JWORD(2,I)
IPAIR(2,2) = JWORD(4,I)
C
C TEST WHETHER RANGE OF SUMMATION HAS BEEN DEFINED. WE CHOOSE THE
C FIRST PAIR OF J VALUES THAT DEFINE THE RANGE AND STORE IN JSUM
C
53 DO 54 I2=1,2
DO 55 I3=1,2
IF(IPAIR(I2,I3)-M) 55,55,56
56 I4 = IPAIR(I2,I3)-M
C
C JSUM7 GREATER THAN ZERO MEANS THAT LIMIT IS DEFINED PREVIOUSLY
C
IF(JSUM7(I4)) 54,54,55
55 CONTINUE
GO TO 57
54 CONTINUE
GO TO 44
C
C NCT IS COUNT ON ORDER OF SUMMATION
C
57 NCT = NCT+1
JSUM7(I1)=NCT
C
C JSUM(I,J),I=1,2,J=1,NSUM CONTAINS THE POSITION OF THE J VALUES
C THAT DEFINE THE RANGE OF EACH VARIABLE. THE FIRST ROW CORRESPONDS
C TO THE FIRST J AND THE SECOND ROW TO THE SECOND J DEFINING RANGE.
C IF VALUE IN RANGE 1 TO M THEN CORRESPONDS TO AN ELEMENT IN J1.
C IF VALUE GREATER THAN M THEN CORRESPONDS TO A SUMMATION VARIABLE
C IN JSUM1 LIST. NOTE THAT JSUM DOES NOT NECESSARILY CONTAIN THE
C MOST RESTRICTIVE RANGES SINCE ONLY ONE OF TWO POSSIBLE PAIRS FROM
C THE RACAH COEFFICIENT IS TAKEN
C
DO 58 I3=1,2
JSUM(I3,I1)=IPAIR(I2,I3)
58 CONTINUE
44 CONTINUE
43 CONTINUE
C
C CHECK WHETHER THE RANGE OF ALL SUMMATIONS SET. FAIL IF NOT
C POSSIBLE TO SET ALL RANGES
C
IF(NCT-NSUM) 59,60,60
59 IF(NCT-NCT1) 61,61,62
61 WRITE(IWRITE,63)
CALL EXIT
62 NCT1=NCT
GO TO 64
C
C JSUM8(I),I=1,NSUM IS THE POSITION IN THE JSUM7 LIST WHERE THE ITH
C SUMMATION IS FOUND
C
60 DO 65 J=1,NSUM
DO 66 I1=1,NSUM
IF(JSUM7(I1)-J) 66,67,66
66 CONTINUE
I1=NSUM
67 JSUM8(J)=I1
65 CONTINUE
C
C
C
C
C
C S E C T I O N 4
C
C CARRY OUT THE SUMMATIONS.
C I6 DENOTES THE FIRST J THAT REQUIRES TO BE SET TO THE LOWEST
C VALUE IN THE RANGE
C I7 = 0 THE FIRST TIME THE JS ARE SET BUT BUT IS SET EQUAL TO 1
C ON SUBSEQUENT TIMES
C
I6=1
I7=0
100 IF(I6-NSUM) 105,105,104
C
C JSUM2(I),I=1,NSUM CONTAINS CURRENT VALUE OF (2J+1) IN THE SAME
C ORDER AS JSUM1 LIST. SET JSUM2 EQUAL TO LOWEST VALUE IN EACH
C RANGE
C
105 DO 68 J=I6,NSUM
I1=JSUM8(J)
IF(JSUM(1,I1)-M) 69,69,70
C
C FIRST J DEFINING RANGE FIXED
C
69 I2=JSUM(1,I1)
I3=J1(I2)
GO TO 71
C
C FIRST J DEFINING RANGE VARIABLE
C
70 I2=JSUM(1,I1)-M
I3=JSUM2(I2)
71 IF(JSUM(2,I1)-M) 72,72,73
C
C SECOND J DEFINING RANGE FIXED
C
72 I2=JSUM(2,I1)
I4=J1(I2)
GO TO 74
C
C SECOND J DEFINING RANGE VARIABLE
C
73 I2=JSUM(2,I1)-M
I4=JSUM2(I2)
C
C SET LOWER LIMIT OF RANGE IN JSUM2
C
74 JSUM2(I1)=IABS(I3-I4)+1
68 CONTINUE
C
C JSUM3(I),I=1,NSUM IS 1 IF J HAS ALTERED FROM ITS PREVIOUS VALUE
C AND IS 0 IF IT IS STILL THE SAME
C
DO 77 I=I6,NSUM
JSUM3(I)=1
77 CONTINUE
IF(I7) 103,103,104
103 I7=1
C
C JWTEST(I),I=1,JWRD IS 1 IF REQUIRED TO EVALUATE RACAH COEFFICIENT
C AND IS 0 IF VALUE THE SAME AS BEFORE.JWTEST IS SET ZERO THE FIRST
C TIME THROUGH AND LATER SET 1 IF NECESSARY
C
DO 78 I=1,JWRD
JWTEST(I)=0
78 CONTINUE
C
C STOR1 WILL CONTAIN THE PRODUCT OF RACAH COEFFICIENTS TIMES
C (2J+1) FACTORS
C STOR WILL CONTAIN SUMS OF THE STOR1
C
STOR1=1.
STOR=0.
C
C CHECK THE TRIANGULAR RELATION FOR ALL J VALUES IN JWORD LIST. IF
C A SUMMATION VARIABLE THEN VALUE TAKEN FROM JSUM2 LIST
C
104 DO 79 J=1,JWRD
DO 80 I=1,6
IF(JWORD(I,J)-M) 81,81,82
81 I1=JWORD(I,J)
ist(i)=j1(i1)-1
GO TO 80
82 I1=JWORD(I,J)-M
ist(i)=jsum2(i1)-1
80 CONTINUE
IF(IST(1)+IST(2)-IST(5)) 83,84,84
84 IF(IABS(IST(1)-IST(2))-IST(5)) 85,85,83
85 IF(IST(3)+IST(4)-IST(5)) 83,86,86
86 IF(IABS(IST(3)-IST(4))-IST(5)) 87,87,83
87 IF(IST(1)+IST(3)-IST(6)) 83,88,88
90 IF(IABS(IST(2)-IST(4))-IST(6)) 79,79,83
89 IF(IST(2)+IST(4)-IST(6)) 83,90,90
88 IF(IABS(IST(1)-IST(3))-IST(6))89,89,83
79 CONTINUE
GO TO 91
C
C FAIL ONE OF THE TRIANGULAR RELATIONS. INCREASE THE J VALUES
C
83 I2=NSUM
203 I1 = JSUM8(I2)
C
C INCREASE A SUMMATION J VALUE WHICH IS IN JSUM2 AND SET JSUM3 TO
C SHOW VALUE CHANGED
C
JSUM2(I1)=JSUM2(I1)+2
JSUM3(I1)=1
C
C NOW STORE J VALUE DEFINING RANGE OF THIS J IN I3 AND I4.
C
IF(JSUM(1,I1)-M) 92,92,93
92 I20 = JSUM(1,I1)
I3 = J1(I20)
GO TO 94
93 I20 = JSUM(1,I1)-M
I3 = JSUM2(I20)
94 IF(JSUM(2,I1)-M)95,95,96
95 I20 = JSUM(2,I1)
I4 = J1(I20)
GO TO 97
96 I20 = JSUM(2,I1)-M
I4 = JSUM2(I20)
97 I5=I3+I4-1
c 98 I6=I2+1
C
C NOW TEST J VALUES AGAINST MAXIMUM IN RANGE. IF SATISFIED RETURN
C TO SET REMAINING J VALUES WHICH DEPEND ON THIS J TO THEIR
C LOWEST VALUES. IF NOT RETURN TO INCREASE PRECEDING J VALUE
C
IF(JSUM2(I1)-I5) 100,100,101
101 I2=I2-1
IF(I2) 102,102,203
C
C NO MORE J VALUES TO SUM OVER. THE SUMMATION IS THEREFORE COMPLETE
C MULTIPLY BY COMMON FACTOR AND EXIT
C
102 RECUP=RECUP*STOR
IF(IBUG3-1) 131,230,131
230 WRITE(IWRITE,169) RECUP,STOR,STOR1
131 RETURN
C
C SEE TRIANGULAR RELATIONS ARE SATISFIED. NOW PROCEED TO EVALUATE
C RACAH COEFFICIENTS
C FIRST DETERMINE WHICH RACAH COEFFICIENTS NEED RE-EVALUATING AND
C SET JWTEST APPROPRIATELY
C
91 DO 106 J=1,NSUM
IF(JSUM3(J)) 106,106,107
107 I2=JSUM6(J)
DO 108 I1=1,I2
I3=JSUM5(J,I1)
JWTEST(I3)=1
108 CONTINUE
106 CONTINUE
C
C NOW EVALUATE ALL JWRD RACAH COEFFICIENTS WHICH HAVE NOT ALREADY
C BEEN EVALUATED
C
DO 109 I=1,JWRD
IF(JWTEST(I)) 109,109,110
110 DO 111 I1=1,6
IF(JWORD(I1,I)-M) 112,112,113
112 I2=JWORD(I1,I)
ist(i1)=j1(i2)-1
GO TO 111
113 I2=JWORD(I1,I)-M
ist(i1)=jsum2(i2)-1
111 CONTINUE
IF(IBUG3-1) 132,133,132
133 WRITE(IWRITE,170) (ist(J),J=1,6)
132 call dracah(ist(1),ist(2),ist(3),ist(4),ist(5),ist(6),x1)
WSTOR(I)=X1
109 CONTINUE
C
C WSTOR(I),I=1,JWRD CONTAINS THE EVALUATED RACAH COEFFICIENTS
C
IF(IBUG3-1) 134,135,134
135 WRITE(IWRITE,190) (WSTOR(J),J=1,JWRD)
C
C SET JSUM3 AND JWTEST TO ZERO TO INDICATE THAT RACAH COEFFICIENTS
C NEED NOT BE EVALUATED UNLESS J VALUE CHANGES
C
134 DO 114 J=1,NSUM
JSUM3(J)=0
114 CONTINUE
DO 115 J=1,JWRD
JWTEST(J)=0
115 CONTINUE
C
C FORM PRODUCT OF RACAH COEFFICIENTS,(2J+1) FACTORS AND (-1)
C FACTORS IN STOR1
C
DO 116 I=1,JWRD
STOR1 = STOR1*WSTOR(I)
116 CONTINUE
C
C iasTOR CONTAINS THE POWER OF (-1) WHICH IS COMMON TO ALL TERMS
C
ix2=iastor
IF(J6CP) 117,117,118
118 DO 119 I=1,J6CP
I1=J6P(I)
STOR1 = STOR1*SQRT(FLOAT(JSUM2(I1)))
119 CONTINUE
117 IF(J7CP) 120,120,121
121 DO 122 I=1,J7CP
I1=J7P(I)
ix2=ix2+jsum2(i1)-1
122 CONTINUE
120 IF(J8CP) 123,123,124
124 DO 125 I=1,J8CP
I1=J8P(I)
ix2=ix2-jsum2(i2)+1
125 CONTINUE
123 i1=ix2/2
C
C ADD TERM INTO STOR AND RESET STOR1 TO 1 READY FOR NEXT TERM
C
if(mod(ix2,2) .eq. 1) stor1=-stor1
STOR = STOR + STOR1
STOR1=1.
GO TO 83
C
C NO SUMMATIONS. CHECK THAT THERE ARE NO INCONSISTENCIES. THEN
C MULTIPLY BY (-1) FACTOR AND EXIT
C
12 IF(J6CP+J7CP+J8CP) 309,309,310
310 WRITE(IWRITE,311)
CALL EXIT
309 i1 = iastor/2
if(mod(ix2,2) .eq. 1) recup=-recop
c 186 RETURN
END
c
c------------------------------------------------------------------------
c d r a c a h
c------------------------------------------------------------------------
c
SUBROUTINE DRACAH (J1,J2,L2,L1,J3,L3,D6J)
C THIS SUBROUTINE WAS ORIGINALLY WRITTEN BY G.BESSIS TO COMPUTE
C 6-J SYMBOLS. THIS VERSION HAS BEEN SLIGHTLY MODIFIED TO GIVE
C RACAH COEFFICENTS WITH A CALL COMPATIBLE WITH AAGD
C ARGUMENTS ARE DOUBLE THE ACTUAL QUANTUM NUMBERS
COMMON/INFORM/IREAD,IWRITE,IPUNCH
DIMENSION KC(11),NA(31),MC(23),NC(7),NB(31)
kc(1)=2
kc(2)=3
kc(3)=5
kc(4)=7
kc(5)=11
kc(6)=13
kc(7)=17
kc(8)=19
kc(9)=23
kc(10)=29
kc(11)=31
d6j=0.0
IF(IABS(L1-J2).GT.L3.OR.IABS(J2-L3).GT.L1.OR.IABS(L1-L3).GT.J2) GO
1TO 99
IF(IABS(J1-J2).GT.J3.OR.IABS(J2-J3).GT.J1.OR.IABS(J1-J3).GT.J2) GO
1TO 99
IF(IABS(L1-L2).GT.J3.OR.IABS(L2-J3).GT.L1.OR.IABS(L1-J3).GT.L2) GO
1TO 99
IF(IABS(J1-L2).GT.L3.OR.IABS(L2-L3).GT.J1.OR.IABS(J1-L3).GT.L2) GO
1TO 99
DO 5 I=1,31
5 NA(I)=0
MC(1)=J1+J2-J3
MC(2)=J1-J2+J3
MC(3)=-J1+J2+J3
MC(4)=J1+L2-L3
MC(5)=J1-L2+L3
MC(6)=-J1+L2+L3
MC(7)=L1+J2-L3
MC(8)=L1-J2+L3
MC(9)=-L1+J2+L3
MC(10)=L1+L2-J3
MC(11)=L1-L2+J3
MC(12)=-L1+L2+J3
MC(13)=J1+J2+J3+2
MC(14)=J1+L2+L3+2
MC(15)=L1+J2+L3+2
MC(16)=L1+L2+J3+2
MC(17)=J1+J2+J3
MC(18)=J1+L2+L3
MC(19)=L1+J2+L3
MC(20)=L1+L2+J3
MC(21)=J1+J2+L1+L2
MC(22)=J2+J3+L2+L3
MC(23)=J3+J1+L3+L1
DO 6 I=1,23
IF (MOD(MC(I),2).NE.0) GO TO 98
MC(I)=MC(I)/2
IF(MC(I).LT.0) GO TO 99
IF(MC(I).GT.31) GO TO 98
6 CONTINUE
DO 20 I=1,12
N=MC(I)
DO 15 J=1,N
15 NA(J)=NA(J)+1
20 CONTINUE
DO 17 I=13,16
N=MC(I)
DO 16 J=1,N
16 NA(J)=NA(J)-1
17 CONTINUE
DO 26 I=1,31
26 NB(I)=NA(I)
IZM=MIN0(MC(21),MC(22),MC(23))
IZD=MAX0(MC(17),MC(18),MC(19),MC(20))
ISIG=1
IF (MOD(IZD,2).NE.0) ISIG=-ISIG
DO 60 IZ=IZD,IZM
NC(1)=IZ-MC(17)
NC(2)=IZ-MC(18)
NC(3)=IZ-MC(19)
NC(4)=IZ-MC(20)
NC(5)=MC(21)-IZ
NC(6)=MC(22)-IZ
NC(7)=MC(23)-IZ
DO 28 I=1,31
28 NA(I)=NB(I)
N=IZ+1
DO 29 I=1,N
29 NA(I)=NA(I)+2
DO 40 I=1,7
N=NC(I)
DO 35 J=1,N
35 NA(J)=NA(J)-2
40 CONTINUE
NA(2)=NA(2)+2*NA(4)+NA(6)+3*NA(8)+NA(10)+2*NA(12)+NA(14)+4*NA(16)+
1NA(18)+2*NA(20)+NA(22)+3*NA(24)+NA(26)+2*NA(28)+NA(30)
NA(3)=NA(3)+NA(6)+2*NA(9)+NA(12)+NA(15)+2*NA(18)+NA(21)+NA(24)+3*N
1A(27)+NA(30)
NA(5)=NA(5)+NA(10)+NA(15)+NA(20)+2*NA(25)+NA(30)
NA(7)=NA(7)+NA(14)+NA(21)+NA(28)
NA(11)=NA(11)+NA(22)
NA(13)=NA(13)+NA(26)
DRA=1.
DAX=1.
DNR=1.
DO 50 K=1,11
I=KC(K)
N=NA(I)
IF(N.EQ.0) GO TO 50
IF(MOD(N,2)) 41,42,41
41 N=N-1
DRA=DRA*I
42 N=N/2
IF(N) 43,50,45
43 N=-N
DO 44 IN=1,N
44 DNR=DNR*I
GO TO 50
45 DO 46 IN=1,N
46 DAX=DAX*I
50 CONTINUE
DRA = SQRT(DRA)
D6J=D6J+(DAX*DRA*ISIG)/DNR
ISIG=-ISIG
60 CONTINUE
IF( MOD( (J1+J2+L1+L2)/2,2) .EQ. 0) GO TO 99
D6J = -D6J
GO TO 99
98 WRITE (IWRITE,101) J1,J2,L1,L2,J3,L3
101 FORMAT(44H FAILURE IN CALCULATING RACAH COEFFICIENT W(,3(I3,1H,),I
13,1H;,I3,1H,,I3,1H))
CALL EXIT
99 RETURN
END
▶EOF◀