|
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: 10752 (0x2a00)
Types: TextFile
Names: »p1list«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »p1list«
1 c program 1 aagd
2 c
3 c aagdnjsym. a program to calculate a general recoupling
4 c coefficient.
5 c burke, p.g.
6 c ref. in comp. phys. commun. 1 (1970) 241 and
7 c in comp. phys. commun. 2 (1971) 173 and
8 c comp. phys. commun. 2 (1971) 181 and
9 c comp. phys. commun. 5 (1973) 161.
10 C
11 C
12 C
13 C DESCRIPTION OF COMMON BLOCKS
14 C
15 C C O M M O N B L O C K C O U P L E
16 C
17 C M THE TOTAL NUMBER OF ANGULAR MOMENTUM VALUES IN THE
18 C INITIAL AND FINAL STATES
19 C N THE NUMBER OF BASIC ANGULAR MOMENTUM VALUES THAT
20 C ARE COUPLED
21 C J1(I),I=1,M THE ANGULAR MOMENTUM VALUES STORED AS 2J+1
22 C J2(I,J),I=1,(N-1),J=1,3 THE POSITION IN THE J1 ARRAY OF THE
23 C INITIAL STATE TRIADS
24 C J3(I,J),I=1,(N-1),J=1,3 THE POSITION IN THE J1 ARRAY OF THE
25 C FINAL STATE TRIADS
26 C
27 C
28 C
29 C C O M M O N B L O C K D E B U G
30 C
31 C IBUG1 NOT USED
32 C IBUG2 NOT USED
33 C IBUG3 DEBUG PRINTS IN NJSYM AND GENSUM IF IBUG3 EQUALS 1
34 C IBUG4 NOT USED
35 C IBUG5 NOT USED
36 C IBUG6 NOT USED
37 C
38 C
39 C
40 C C O M M O N B L O C K D E P T H S
41 C
42 C J40J0,J=1,M THE LEVEL OF J IN THE J2 COUPLING TREE EVALUATED
43 C BY SUBROUTINE GENJ45
44 C J50J0,J=1,M THE LEVEL OF J IN THE J3 COUPLING TREE EVALUATED
45 C BY SUBROUTINE GENJ45
46 C
47 C
48 C C O M M O N B L O C K D I M E N
49 C
50 C KFL1 A TEST TO DETERMINE WHETHER DIMENSION TESTS SET
51 C KFL2 TEST ON DIMENSIONS OF J2 AND J3 ARRAYS
52 C KFL3 TEST ON DIMENSION OF KW ARRAY
53 C KFL4 TEST ON DIMENSIONS OF J1,K6 AND K8 ARRAYS
54 C KFL5 TEST ON DIMENSIONS OF K7 ARRAY
55 C KFL6 TEST ON DIMENSIONS OF JSUM1,JSUM2 ETC ARRAYS USED
56 C IN GENSUM
57 C
58 C
59 C C O M M O N B L O C K I N F O R M
60 C
61 C IREAD INPUT CHANNEL NUMBER
62 C IWRITE OUTPUT CHANNEL NUMBER
63 C
64 C
65 C
66 C C O M M O N B L O C K W C O M I 9
67 C
68 C I3 CONTAINS THE COLUMN OF THE J2 ARRAY WHICH CONTAINS
69 C THE FIRST ELEMENT TO BE BROUGHT INTO THE SAME
70 C TRIAD BY RECOUPLING. INPUT TO SUBROUTINE GENI9
71 C I4 CONTAINS THE COLUMN OF THE J2 ARRAY WHICH CONTAINS
72 C THE SECOND ELEMENT TO BE BROUGHT INTO THE SAME
73 C TRIAD BY RECOUPLING. INPUT TO SUBROUTINE GENI9
74 C I5 CONTAINS THE ROW OF THE J2 ARRAY WHICH CONTAINS
75 C THE FIRST ELEMENT,INPUT TO SUBROUTINE GENI9
76 C I6 CONTAINS THE ROW OF THE J2 ARRAY WHICH CONTAINS
77 C THE SECOND ELEMENT,INPUT TO SUBROUTINE GENI9
78 C I7 CONTAINS THE LEVEL OF THE I5 TRIAD BELOW THE
79 C COMMON TRIAD IN COUPLING SCHEME OF J2,EVALUATED BY
80 C SUBROUTINE GENI9
81 C I8 CONTAINS THE LEVEL OF THE I6 TRIAD BELOW THE
82 C COMMON TRIAD IN COUPLING SCHEME OF J2,EVALUATED BY
83 C SUBROUTINE GENI9
84 C I9 CONTAINS THE NUMBER OF RECOUPLINGS PLUS TWO.
85 C EVALUATED BY SUBROUTINE GENI9
86 C I17 CONTAINS THE ROW OF THE J2 ARRAY CONTAINING THE
87 C HIGHEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
88 C I18 CONTAINS THE ROW OF THE J2 ARRAY CONTAINING THE
89 C LOWEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
90 C I19 CONTAINS THE COLUMN OF THE J2 ARRAY CONTAINING THE
91 C HIGHEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
92 C I20 CONTAINS THE COLUMN OF THE J2 ARRAY CONTAINING
93 C THE LOWEST ELEMENT,EVALUATED BY SUBROUTINE GENI9
94 C
95 C
96 C
97 C
98 C
99 program TESTNJSYM
100 C
101 C READS AND WRITES RECOUPLING MATRICES J1,J2,AND J3
102 C CALLS NJSYM AND GENSUM AND WRITES OUT RESULT
103 C
104 DIMENSION K6(40),K7(80),K8(40),KW(6,20)
105 COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
106 common/debug/ibug1,ibug2,ibug3,ibug4,ibug5,ibug6,ibug7,ibug8,ibug9
107 COMMON/DEPTHS/J4(40),J5(40)
108 common/inform/iread,iwrite,ipunch
109 C
110 C FORMAT STATEMENTS
111 C
112 1 FORMAT(12I5)
113 2 FORMAT(7H RECUP=,E15.7///)
114 3 FORMAT(3H M=,I3,3H N=,I3//)
115 4 FORMAT(4H J1=,25I4)
116 5 FORMAT(19H J2 J3)
117 6 FORMAT(4X,3I4,4X,3I4)
118 9 FORMAT(23H1TEST OUTPUT FROM NJSYM////)
119 C
120 C SET INPUT AND OUTPUT CHANNEL NUMBERS
121 zone readf(200,1,stderror)
122 zone writef(400,1,stderror)
123 zone punchf(400,1,stderror)
124 call zassign(readf,1)
125 call zassign(writef,7)
126 call zassign(punchf,8)
127 call open(readf,4,'readfile',0)
128 call open(writef,4,'writefile',0)
129 c call open(punchf,4,'punchfile',0)
130 call open(readf,4,'data1aagd',0)
131 call open(writef,4,'out1aagd',0)
132 call open(punchf,4,'punch1aagd',0)
133 C
134 iread=1
135 iwrite=2
136 ipunch=3
137 C
138 C SET DEBUG PRINTS ZERO
139 C
140 IBUG1 = 0
141 IBUG2 = 0
142 IBUG3 = 0
143 IBUG4 = 0
144 IBUG5 = 0
145 IBUG6 = 0
146 C
147 C READ AND WRITE INPUT DATA
148 C
149 WRITE(IWRITE,9)
150 8 READ(IREAD,1) M,N
151 K=N-1
152 READ(IREAD,1) (J1(J),J=1,M)
153 READ(IREAD,1) ((J2(I,J),J=1,3),I=1,K)
154 READ(IREAD,1) ((J3(I,J),J=1,3),I=1,K)
155 WRITE(IWRITE,3) M,N
156 WRITE(IWRITE,4) (J1(J),J=1,M)
157 WRITE(IWRITE,5)
158 DO 7 I=1,K
159 WRITE(IWRITE,6) (J2(I,J),J=1,3),(J3(I,J),J=1,3)
160 7 CONTINUE
161 C
162 C CALLS NJSYM AND GENSUM AND WRITES OUT RESULT
163 C
164 CALL NJSYM (J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
165 WRITE(IWRITE,2) RECUP
166 READ(IREAD,1) (J1(J),J=1,M)
167 WRITE(IWRITE,4) (J1(J),J=1,M)
168 CALL GENSUM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
169 WRITE(IWRITE,2) RECUP
170 GO TO 8
171 END
172 c
173 c----------------------------------------------------------------------
174 c n j s y m
175 c----------------------------------------------------------------------
176 c
177 SUBROUTINE NJSYM (J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP)
178 C
179 C GENERAL RECOUPLING PROGRAMME
180 C EVALUATES THE RECOUPLING COEFFICIENT RECUP BETWEEN TWO COUPLING
181 C SCHEMES
182 C
183 C
184 C J6C THE NUMBER OF ELEMENTS IN THE K6 ARRAY
185 C J7C THE NUMBER OF ELEMENTS IN THE K7 ARRAY
186 C J8C THE NUMBER OF ELEMENTS IN THE K8 ARRAY
187 C JWC THE NUMBER OF COLUMNS IN THE KW ARRAY
188 C K6(I),I=1,J6C. EACH ENTRY CORRESPONDS TO A FACTOR SQRT(2J+1) IN
189 C RECUP. THE VALUE OF K6 GIVES POSITION IN J1 ARRAY
190 C WHERE J VALUE IS FOUND
191 C K7(I),I=1,J7C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**J IN
192 C RECUP
193 C K8(I),I=1,J8C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**(-J) IN
194 C RECUP
195 C KW(I,J),I=1,6,J=1,JWC. EACH COLUMN CORRESPONDS TO A RACAH
196 C COEFFICIENT IN RECUP
197 C RECUP THE RESULTANT RECOUPLING COEFFICIENT EVALUATED
198 C AND STORED IN RECUP
199 C
200 C
201 C THE ARRAYS K6,K7,K8 AND KW ARE EVALUATED BY NJSYM. THE ENTRY IN
202 C EACH CASE CORRESPONDS TO A POSITION IN THE J1 ARRAY WHERE THE
203 C 2J+1 VALUE IS FOUND IF LESS THAN OR EQUAL TO M,OR TO A SUMMATION
204 C VARIABLE IF GREATER THAN M
205 C
206 C THE SUMMATION OVER THE VARIABLES IN K6,K7,K8 AND KW AND THE
207 C EVALUATION OF RECUP IS CARRIED OUT IN GENSUM
208 C
209 C GENSUM CAN BE RE-ENTERED DIRECTLY TO EVALUATE DIFFERENT
210 C RECOUPLING COEFFICIENTS WITH THE SAME STRUCTURE BY JUST ALTERING
211 C THE NUMBERS IN THE J1 ARRAY
212 C
213 DIMENSION K6(40),K7(80),K8(40),KW(6,20)
214 COMMON/COUPLE/M,N,J1(40),J2(12,3),J3(12,3)
215 common/debug/ibug1,ibug2,ibug3,ibug4,ibug5,ibug6,ibug7,ibug8,ibug9
216 COMMON/DEPTHS/J4(40),J5(40)
217 COMMON/DIMEN/KFL1,KFL2,KFL3,KFL4,KFL5,KFL6
218 common/inform/iread,iwrite,ipunch
219 COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
220 C
221 C FORMAT STATEMENTS USED IN NJSYM
222 C
223 50 FORMAT(59H RECOUPLING COEFFICIENT SET ZERO AS TRIANGLE DOES NOT MA
224 1TCH)
225 65 FORMAT(29H FAIL IN RECOUPLING PROGRAMME)
226 107 FORMAT(4H J1=,20I5)
227 108 FORMAT(23H J2 J3)
228 110 FORMAT(3I5,I10,2I5)
229 111 FORMAT(3H KW)
230 112 FORMAT(6I5)
231 113 FORMAT(4H K6=,38I3)
232 114 FORMAT(4H K7=,38I3)
233 115 FORMAT(4H K8=,38I3)
234 c 145 FORMAT(8H JWC = 0,8H J6C = 0,8H J7C = 0,8H J8C = 0)
235 204 FORMAT(23H KFL2 DIMENSION FAILURE)
236 207 FORMAT(23H KFL3 DIMENSION FAILURE)
237 208 FORMAT(23H KFL4 DIMENSION FAILURE)
238 209 FORMAT(23H KFL5 DIMENSION FAILURE)
239 221 FORMAT(17H NO KW ARRAYS SET)
240 226 FORMAT(17H NO K6 ARRAYS SET)
241 230 FORMAT(17H NO K7 ARRAYS SET)
242 233 FORMAT(17H NO K8 ARRAYS SET)
243 C
244 C SET DIMENSIONVARIABLES AND TEST SOME OF DIMENSIONS
245 C
246 IF(KFL1-5) 200,201,200
247 200 KFL1 = 5
248 KFL2 = 12
249 KFL3 = 20
250 KFL4 = 40
251 KFL5 = 80
252 KFL6 = 12
253 201 IF(KFL2-N+1) 202,203,203
254 202 WRITE(IWRITE,204)
255 CALL EXIT
256 203 IF(KFL4-M) 205,206,206
257 205 WRITE(IWRITE,208)
258 CALL EXIT
259 C
260 C IP IS THE NUMBER OF INEQUIVALENT TRIADS WHICH HAVE TO BE
261 C RECOUPLED. IT IS SET INITIALLY TO THE TOTAL NUMBER OF TRIADS AND
262 C THEN DECREASED IN SECTION 1 BELOW