|
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: 148992 (0x24600)
Types: TextFile
Names: »cpc6«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »cpc6«
c cpc6
c
c acqv weights new version. a new version af a general program
c to calculate angular momentum integrals in atomic structure.
c hibbert, a.
c ref. in comp. phys. commun. 2 (1971) 180 and
c comp. phys. commun. 6 (1973) 59 and
c comp. phys. commun. 7 (1974) 318 and
c comp. phys. commun. 8 (1974) 329
c
C
C JANUARY 1971
C
C GENERAL PROGRAM TO CALCULATE THE MATRIX ELEMENTS OF THE TWO-
C ELECTRON OPERATOR OF THE HAMILTONIAN AS A SUM OF SLATER INTEGRALS
C WRITTEN BY A. HIBBERT , DEPT. OF APPLIED MATHEMATICS AND
C THEORETICAL PHYSICS, THE QUEENS UNIVERSITY OF BELFAST.
C
C THE CODE USES THE RECOUPLING COEFFICIENT CODE OF P.G. BURKE ,
C AND THE COEFFICIENT OF FRACTIONAL PARENTAGE ROUTINES (CFPP AND
C CFPD) WRITTEN BY D.C.S. ALLISON , BOTH OF THE QUEENS UNIVERSITY
C OF BELFAST
C
C
C THREE DASHES (OR THREE EQUALS SIGNS) AT THE BEGINNING OF A COMMENT
C CARD INDICATE A NEW SECTION OF A SEGMENT
C
C
C ********** LISTING OF COMMON BLOCKS **********
C
C
C === INFORM
C IREAD - DEFINITION OF CARD INPUT CHANNEL
C IWRITE - DEFINITION OF LINE PRINTER OUTPUT CHANNEL
C IPUNCH - DEFINITION OF CARD PUNCH OUTPUT CHANNEL
C
C === DEBUG
C IBUG1 - DEFINES PRINTOUT FROM THIS PACKAGE
C = 0 - NO PRINT-OUT
C = 1 - FINAL RESULTS
C .GT. 1 - FULL RESULTS
C IBUG2 - DEFINES PRINT-OUT FROM PRNTWT
C IBUG3 - DEFINES PRINT-OUT FROM RECOUPLING COEFFICIENT PACKAGE
C ONLY PRINT-OUT WHEN =1
c ibug4 - defines printout from one-electron part cf. ibug1
c ibug5 to ibug9 are not used in this paskage
C
C === KRON
C IDEL(I,J),I,J=1,NHDEL - KRONECKER DELTA
C
C === STATES
C NCFG - NUMBER OF CONFIGURATIONS
C NOCCSH(I),I=1,NCFG - FOR EACH CONFIGURATION, THE NUMBER OF
C OCCUPIED SHELLS
C NOCORB(J,I),J=1,NOCCSH(I),I=1,NCFG - FOR EACH CONFIGURATION
C THE NUMBERS INDICATING WHICH SHELLS ARE OCCUPIED
C NELCSH(J,I),J=1,NOCCSH(I),I=1,NCFG - FOR EACH CONFIGURATION,
C THE NUMBER OF ELECTRONS IN EACH OCCUPIED SHELL
C J1QNRD(J,K,I),J=1,2*NOCCSH(I)-1,K=1,3,I=1,NCFG - ANGULAR
C MOMENTUM QUANTUM NUMBERS. K=1 IS SENIORITY, K=2 IS
C (2L+1), K=3 IS (2S+1). J=1,NOCCSH(I) IS THE SET OF
C QUANTUM NUMBERS FOR EACH SHELL. THE REMAINING
C NOCCSH(I)-1 ARE QUANTUM NUMBERS RESULTING FROM COUPLING
C OF THE SHELLS
C MAXORB - HIGHEST VALUE OF NOCORB(J,I)
C LJCOMP(I),I=1,MAXORB - L VALUES OF THE ORBITALS
C
C === TERMS
C NROWS - NUMBER OF ROWS OF TABLE OF TERMS, ACCORDING TO
C S,S**2,P,P**2,P**3,D,...D**5, ETC.
C ITAB(I),I=1,NROWS - NUMBER OF SETS OF 3 QUANTUM NUMBERS IN
C EACH ROW
C JTAB(I),I=1,NROWS - IF WE LIST ALL QUANTUM NUMBERS IN A SINGLE
C LINE, THIS MEASURES NUMBER OF QUANTUM NUMBERS OCCURRING
C BEFORE ROW I
C NTAB(J),J=1,(JTAB(I)+3*ITAB(I)) - LIST OF THE QUANTUM NUMBERS OF
C THE TERMS
C
C === FACT
C GAMMA(I),I=1,NFACT - FACTORIAL (OR GAMMA FUNCTION FOR INTEGER)
C
C === MEDEFN
C THIS LISTS THE QUANTUM NUMBERS NEEDED IN A SINGLE MATRIX
C ELEMENT (PSI/V/PSIP)
C IHSH - NUMBER OF SHELLS OCCUPIED (INCLUDING DUMMIES) IN PSI
C OR PSIP
C NJ(I),LJ(I),I=1,IHSH - N,L VALUES OF THE OCCUPIED SHELLS
C NOSH1(I),NOSH2(I),I=1,IHSH - NUMBER OF ORBITALS IN EACH SHELL,
C FOR PSI AND PSIP RESPECTIVELY
C J1QN1(J,K),J1QN2(J,K),J=1,2*IHSH-1,K=1,3 - K=1 IS SENIORITY ,
C K=2 IS 2L+1 , K=3 IS 2S+1 . THE FIRST IHSH VALUES
C OF J ARE THE QUANTUM NUMBERS OF THE SHELLS, THE
C REMAINING IHSH-1 ARE THE QUANTUM NUMBERS OBTAINED BY
C COUPLING THE SHELLS
C J1QN1 CORRESPONDS TO PSI, J1QN2 TO PSIP
C NOTICE THE DIFFERENT DEFINITION OF THIS BLOCK IN MUMDAD
C AND SETUP,
C
C === MVALUE
C M1,M2,.....M20
C M1=ISIG-IRHO, M2=ISIGP-IRHOP, M19=IRHO-IRHOP
C M20=ISIG-ISIGP . ALL THE REST OF THE M-VALUES ARE
C SIMPLY RELATED TO IHSH AND ARE AS DEFINED IN RKWTS
C
C === XATION
C KD1,KD2 - LIMITS ON K FOR DIRECT INTEGRALS
C KE1,KE2 - LIMITS ON K FOR EXCHANGE INTEGRALS
C AMULT(K),K=KD1,KD2,2 . BMULT(K),K=KE1,KE2,2 - THESE STORE THE
C MULTIPLYING FACTORS OF THE DIRECT AND EXCHANGE RK
C INTEGRALS
C MULTD,MULTE - ARE ZERO IF THERE ARE NO DIRECT/EXCHANGE INTEGRALS
C TO CALCULATE
C
C === NJLJ
C NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP
C N,L VALUES OF THE SHELLS RHO,SIG,RHOP,SIGP
C
C === INTERM
C INTERMEDIATE COUPLING QUANTUM NUMBERS
C J1BAR1(I,K),J1BAR2(I,K),J1TLD1(I,K),J1TLD2(I,K),I=1,IHSH,K=1,3
C K=1 IS SENIORITY, K=2 IS (2L+1), K=3 IS (2S+1)
C J1BAR1 AND J1BAR2 DEFINE QUANTUM NUMBERS OF SPECTATOR
C ELECTRONS IN EACH SHELLS OF PSI AND PSIP RESPECTIVELY
C J1TLD1 AND J1TLD2 ARE DEFINED ONLY IF RHO=SIG (OR
C RHOP=SIGP). THEN THESE ARE QUANTUM NUMBERS OBTAINED BY
C COUPLING ONE OF THE TWO INTERACTING ELECTRONS ONTO THE
C SPECTATOR ELECTRONS OF THE APPROPRIATE SHELLS
C NOTICE THE DIFFERENT DEFINITION IN MUMDAD AND SETUP
C
C === COUPLE
C THIS BLOCK HOLDS THE INPUT DATA FOR NJSYM
C MI - LENGTH OF J1 ARRAY
C MJ - NUMBER OF J2 OR J3 ROWS, PLUS 1
C J1(I),I=1,3*IHSH+4(7) - (2J+1) VALUES - SPIN(ANGULAR)
C J2(I),J),J3(I,J),I=1,IHSH+1(2),J=1,3 - DETERMINE COUPLING
C SCHEMES. I LIMIT IS IHSH+1 FOR SPIN, IHSH+2 FOR ANGULAR
C
C === HOLD
C STORAGE ARRAYS FOR SPIN AND ANGULAR COUPLING SCHEMES
C STORES J2 AND J3 ARRAYS ROW AFTER ROW
C J2SPIN(I),J3SPIN(I),I=1,3*(IHSH+1)
C J2ANG(I),J3ANG(I),I=1,3*(IHSH+2)
C
C === DIAGNL
C IDIAG = 0 FOR OFF-DIAGONAL MATRIX ELEMENT
C = 1 FOR DIAGONAL MATRIX ELEMENT
C
C === ENAV
C OUTPUT OF INFORMATION FROM INTERACTION ENERGY ROUTINE
C NINTS - NUMBER OF FK OR GK INTEGRALS OTHER THAN F0
C KVALUE(I),I=1,NINTS - THE K-VALUES OF THOSE INTEGRALS
C COEFCT(I),I=1,NINTS - THE COEFFICIENTS MULTIPLYING THOSE INTEGRALS
C
C === REMOVE
C ICHOP(I),I=1,IHSH -
C = 1 IF ALL INTERACTIONS INVOLVING SHELL I MAY BE
C TREATED PURELY BY AVERAGE ENERGY
C = 0 OTHERWISE
C
C === STORE
C USED AS A STORAGE AREA WHEN MEDEFN IS MODIFIED
C
C
C
C ********** END OF LIST OF COMMON BLOCKS **********
C
C
C
C
program wreigt
long IAJCMP
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 j1qnrd(9,3,30),maxorb,njcomp(21),ljcomp(21),iajcmp(21)
COMMON/KRON/IDEL(10,10)
common/diagnl/idiag,ja,jb
common/comchf/locate(21)
common/punch1/yl(100),nl,jl1(100),jl2(100)
common/inf1/writef
common/inf2/punchf
C
1 FORMAT(4I5)
11 FORMAT(//,50H IN THIS CALCULATION, THE NUMBER OF STATES CONSIDE,
16hRED IS,I3,1H,,5X,31HTHE NUMBER OF FACTORIALS SET IS,I3/
239h AND THE SIZE OF THE KRONECKER DELTA IS,I3,14H. IPUNCH =,I3//)
12 FORMAT(10X,29H DEBUG IN TWO-ELECTRON PART =,I2/10X,30H DEBUG IN RE
1COUPLING PACKAGE =,I2/10X,29H DEBUG IN ONE-ELECTRON PART =,I2)
13 FORMAT(95H1PACKAGE - WEIGHTS - CALCULATION OF MATRIX ELEMENTS OF T
1HE TWO-ELECTRON PART OF THE HAMILTONIAN/31X,29H AS A SUM OF SLATER
2 INTEGRALS/25X,41H PLUS THE CORRESPONDING ONE-ELECTRON PART//////)
41 FORMAT(/40X,22H ---------------------/40X,22H ONE-ELECTRON INTEGRA
1L/40X,22H ---------------------)
42 FORMAT(/40X,22H ---------------------/40X,22H TWO-ELECTRON INTEGRA
1L/40X,22H ---------------------)
43 format(//,1x,' ipunch skal vaere enten 8 eller 0 ')
C
C
C --- THIS PROGRAMME CONSIDERS EITHER SUPERPOSITION OF CONFIGURATIONS OR
C MULTI-CONFIGURATIONAL HARTREE-FOCK WAVE FUNCTIONS. USING THE
C RESULT THAT THE TWO-ELECTRON HAMILTONIAN MATRIX ELEMENT
C (PSI/V/PSIP) CAN BE WRITTEN AS A SUM OF SLATER INTEGRALS, THE
C PRESENT CODE - WEIGHTS - CALCULATES THE COEFFICIENTS OF THESE
C INTEGRALS. PSI AND PSIP ARE ALLOWED TO RUN OVER NCFG CONFIGURATNS
C
C
C
C --- SET INPUT AND OUTPUT CHANNELS
C
zone readf(128,1,stderror)
zone writef(128,1,stderror)
zone punchf(128,1,stderror)
c
iread=1
call zassign(readf,iread)
call open(readf,4,'inf',0)
c
iwrite=7
call zassign(writef,iwrite)
call open(writef,4,'outf',0)
c
ipunch=8
call zassign(punchf,ipunch)
call open(punchf,4,'pchf',0)
c
WRITE(IWRITE,13)
c
c call bldata
c
call bldata
C
C --- PRINT-OUT OF TERMS FORMED FROM CONFIGURATIONS L**Q
C
CALL TMSOUT
C
C NSTATE IS THE NUMBER OF STATES (NOT CONFIGURATIONS) UNDER
C CONSIDERATION
C NFACT DEFINES THE NUMBER OF FACTORIALS CALCULATED
C NHDEL DEFINES THE DIMENSION OF THE KRONECKER DELTA
C IPUNCH IS ZERO IF THE WEIGHTS OF THE SLATER INTEGRALS ARE NOT TO
C BE PUNCHED ON CARDS. IF SUCH PUNCHING IS REQUIRED, IPUNCH IS
C TO BE GIVEN THE VALUE OF THE CARD PUNCH CHANNEL NUMBER
C ONLY PRINT-OUT OF COEFFICIENTS IN THE FOLLOWING CASES -
C IBUG1 = 1 - ONLY FINAL RESULTS FROM WEIGHTS
C IBUG1 .GE. 2 - FULL PRINT-OUT FROM WEIGHTS
C IBUG3 = 1 - FULL PRINT-OUT FROM RECOUPLING COEFFICIENT PACKAGE
c ibug4 similar to ibug1, except for one-electron part.
C IBUG5 TO IBUG9 ARE NOT USED IN THIS PACKAGE
C
READ(IREAD,1) NSTATE,NFACT,NHDEL,IPUNCH
WRITE(IWRITE,11) NSTATE,NFACT,NHDEL,IPUNCH
c
if (ipunch.eq.8.or.ipunch.eq.0) goto 112
write(6,43)
write(7,43)
goto 9
112 continue
c
READ(IREAD,1) IBUG1,IBUG3,ibug4
WRITE(IWRITE,12) IBUG1,IBUG3,ibug4
IBUG5=0
IBUG6=0
do 111 i=1,10
locate(i)=0
111 continue
nl=0
C
C --- SET FACTORIALS
C
CALL SHRIEK(NFACT)
C
C --- SET KRONECKER DELTA
C
DO 2 I=1,NHDEL
DO 3 J=1,I
IF(I-J) 4,5,4
5 IDEL(I,I)=1
GO TO 3
4 IDEL(I,J)=0
IDEL(J,I)=0
3 CONTINUE
2 CONTINUE
C
C --- READ IN (AND PRINT OUT) CONFIGURATIONS
C
10 CALL CFGIN
CALL CFGOUT
call cfgtst
C
C --- CONSIDER (PSI/V/PSIP) AS PSI AND PSIP RUN OVER ALL CONFIGURATIONS
C
DO 6 JA=1,NCFG
DO 7 JB=1,JA
IF(JA.EQ.JB) GO TO 20
IDIAG=0
GO TO 21
20 IDIAG=1
21 CONTINUE
C
C --- SET UP DEFINING QUANTUM NUMBERS FOR EACH MATRIX ELEMENT
C
CALL SETUP(JA,JB)
IF(IBUG1-1) 14,15,15
15 CALL VIJOUT(JA,JB)
C
C --- TEST ON POSSIBLE RECOUPLING ORTHOGONALITY
C
14 CALL ORTHOG(LET)
IF(LET.EQ.0) GO TO 7
IF(IBUG4.EQ.2) WRITE(IWRITE,41)
IF(IDIAG.EQ.0) GO TO 32
IF(IBUG4.NE.0) CALL DH0
GO TO 35
32 CALL H0WTS(ISIG,ISIGP,Y,ICAL)
C
C ICAL=0 UNLESS Y HAS BEEN CALCULATED
C
CALL ODH0(ISIG,ISIGP,Y,ICAL)
35 IF(IBUG1.EQ.2) WRITE(IWRITE,42)
C
C --- IF NO SUCH ORTHOGONALITY IS EXHIBITED, CALCULATE WEIGHTS OF SLATER
C INTEGRALS
C
CALL CHOP
CALL RKWTS
7 CONTINUE
6 CONTINUE
C
C --- ARE THERE ANY MORE STATES TO CONSIDER
C
NSTATE=NSTATE-1
IF(NSTATE) 9,9,10
9 call exit
END
c
c----------------------------------------------------------------------------
c e x i t
c----------------------------------------------------------------------------
c
subroutine exit
common/inf1/writef
common/inf2/punchf
zone writef(128,1,stderror)
zone punchf(128,1,stderror)
4 format(/,3a1)
eof=25.shift.16+25.shift.8+25
write(writef,4) eof,eof,eof
write(punchf,4) eof,eof,eof
call close(writef,.true.)
call close(punchf,.true.)
stop
return
end
c
c---------------------------------------------------------------------------
c t m s o u t
c---------------------------------------------------------------------------
c
SUBROUTINE TMSOUT
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/TERMS/NROWS,ITAB(12),JTAB(12),NTAB(171)
C
C --- PRINT-OUT OF TABLE OF TERMS, SET IN BLOCK DATA
C
1 FORMAT(40X,24H TABLE OF POSSIBLE TERMS//)
2 FORMAT(I3,91H ROWS OF THIS TABLE (NTAB) ARE DEFINED. THE LENGTHS
1 (ITAB) OF THE ROWS ARE, RESPECTIVELY,/30X,12I5)
3 FORMAT(/74H LIST OF NTAB. EACH TRIAD OF NUMBERS CORRESPONDS TO (S
1ENIORITY,2L+1,2S+1)/)
4 FORMAT(5H ROW ,I2,2H ,,8(I8,2I3)/I17,2I3,7(I8,2I3))
WRITE(IWRITE,1)
WRITE(IWRITE,2) NROWS,(ITAB(I),I=1,NROWS)
WRITE(IWRITE,3)
DO 5 I=1,NROWS
JI=JTAB(I)
JJ=3*ITAB(I)
WRITE(IWRITE,4) I,(NTAB(JI+J),J=1,JJ)
5 CONTINUE
RETURN
END
c
c-----------------------------------------------------------------------
c s h r i e k
c-----------------------------------------------------------------------
c
SUBROUTINE SHRIEK(NFACT)
C
C === EVALUATES FACTORIALS
C
COMMON/FACT/ GAMMA(20)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
GAMMA(1)=one
DO 1 I=2,NFACT
II=I-1
GAMMA(I)=II*GAMMA(II)
1 CONTINUE
RETURN
C
C GAMMA(I+1)=FACTORIAL I
C
END
c
c---------------------------------------------------------------------
c c f g i n
c---------------------------------------------------------------------
c
SUBROUTINE CFGIN
long IAJCMP
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 j1qnrd(9,3,30),maxorb,njcomp(21),ljcomp(21),iajcmp(21)
C
C --- QUANTUM NUMBERS DEFINING THE CONFIGURATIONS ARE READ IN
C
1 FORMAT(12I5)
5 format(24a3)
MAXORB=0
READ(IREAD,1) NCFG
READ(IREAD,1)(NOCCSH(I),I=1,NCFG)
DO 2 I=1,NCFG
N=NOCCSH(I)
READ(IREAD,1) (NOCORB(J,I) ,J=1,N)
READ(IREAD,1) (NELCSH(J,I) ,J=1,N)
IF(MAXORB-NOCORB(N,I)) 3,4,4
3 MAXORB=NOCORB(N,I)
4 M=2*N-1
READ(IREAD,1) ((J1QNRD(J,K,I),K=1,3),J=1,M)
2 CONTINUE
READ(IREAD,1) (NJCOMP(I),LJCOMP(I),I=1,MAXORB)
read(iread,5) (iajcmp(i),i=1,maxorb)
RETURN
END
c
c---------------------------------------------------------------------
c c f g o u t
c---------------------------------------------------------------------
c
SUBROUTINE CFGOUT
long IAJCMP
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 J1QNRD(9,3,30),MAXORB,NJCOMP(21),LJCOMP(21),IAJCMP(21)
C
C --- PRINT-OUT OF CONFIGURATIONS, BEING DATA READ IN CFGIN
C
1 FORMAT(27H1NUMBER OF CONFIGURATIONS =,I3/)
2 FORMAT(50H NUMBER OF OCCUPIED SHELLS IN THESE CONFIGURATIONS/30I3)
4 FORMAT(/,14H CONFIGURATION,I3,/,6X,21HOCCUPIED ORBITALS ARE,32X,10I3)
5 FORMAT(5X,16H COUPLING SCHEME)
6 FORMAT(5X,3I3,6(I10,2I3))
7 FORMAT(22X,6(I10,2I3))
8 FORMAT(/10H THERE ARE,I3,30H ORBITALS WHOSE N,L VALUES ARE/2I3,10(
1I8,I3))
9 FORMAT(5X,49H NUMBER OF ORBITALS IN RESPECTIVE OCCUPIED SHELLS,5X,
110I3)
WRITE(IWRITE,1) NCFG
WRITE(IWRITE,2) (NOCCSH(I),I=1,NCFG)
DO 3 I=1,NCFG
N=NOCCSH(I)
WRITE(IWRITE,4) I,(NOCORB(J,I),J=1,N)
M=2*N-1
WRITE(IWRITE,9) (NELCSH(J,I),J=1,N)
N1=N+1
WRITE(IWRITE,5)
WRITE(IWRITE,6) ((J1QNRD(J,K,I),K=1,3),J=1,N)
WRITE(IWRITE,7) ((J1QNRD(J,K,I),K=1,3),J=N1,M)
3 CONTINUE
WRITE(IWRITE,8) MAXORB,(NJCOMP(I),LJCOMP(I),I=1,MAXORB)
RETURN
END
c
c---------------------------------------------------------------------
c s e t u p
c---------------------------------------------------------------------
c
SUBROUTINE SETUP(JA,JB)
long IAJCMP
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 j1qnrd(9,3,30),maxorb,njcomp(21),ljcomp(21),iajcmp(21)
common/medefn/ihsh,nj(10),lj(10),nosh(10,2),j1qn(19,3,2),ijful(10)
C
C NOTICE THE DIFFERENT NAMES IN THE COMMON BLOCK MEDEFN - WE
C STORE NOSH1(I=1,10) AS NOSH((I=1,10),1) AND NOSH2(I=1,10) AS
C NOSH((I=1,10),2) AND USE THE FACT THAT NOSH1 AND NOSH2 WILL THEN
C BE EQUIVALENT TO THE SINGLE 2-DIMENSIONAL ARRAY NOSH. SIMILARLY
C FOR J1QN
C
C === GENERATES THE ARRAYS NJ,LJ - DEFINING THE QUANTUM NUMBERS OF THE
C SHELLS, NOSH - DEFINING THE OCCUPATION OF THE SHELLS, J1QN -
C DEFINING THE COUPLING OF THE SHELLS, FOR EACH OF THE TWO
C CONFIGURATIONS CONSIDERED. ONLY THOSE SHELLS OCCURRING IN AT
C LEAST ONE CONFIGURATION ARE INCLUDED.
C AT LEAST TWO SHELLS MUST BE CONSIDERED OCCUPIED.
C THUS (1S)**2 HELIUM MUST BE TREATED AS ,E.G., (1S)**2(2S)**0
C THE SIZE OF THE ARRAYS HERE CALCULATED IS ARRANGED TO BE NO
C GREATER THAN IS NECESSARY TO INCLUDE ALL ORBITALS WHICH ARE
C DEEMED TO BE OCCUPIED IN EITHER OR BOTH OF THE CONFIGURATIONS
C JA,JB
C
C --- INITIALIZE BASIC QUANTITIES - (I1+1) RUNS OVER 1,MAXORB, IHSH IS
C THE CURRENT VALUE OF THE HIGHEST OCCUPIED SHELL YET CONSIDERED,
C WHILE I2HSH=2*IHSH-1
C
I1=0
IHSH=0
I2HSH=-1
IA=NOCCSH(JA)
IB=NOCCSH(JB)
C
C --- TEST ON WHETHER LIMIT OF I1 HAS BEEN REACHED
C
1 IF(I1-MAXORB) 101,100,100
C
C --- INCREASE BASIC QUANTITIES
C
101 I1=I1+1
I3=IHSH+1
I5=I2HSH+I3
C
C --- IS THE SHELL I1 OCCUPIED IN JA
C
DO 2 J=1,IA
IF(I1-NOCORB(J,JA)) 2,3,2
2 CONTINUE
NA=1
GO TO 4
3 NA=2
J1=J
C
C --- IS THE SHELL I1 OCCUPIED IN JB
C
4 DO 5 J=1,IB
IF(I1-NOCORB(J,JB)) 5,6,5
5 CONTINUE
NB=1
GO TO 7
6 NB=2
J2=J
C
C IF THE SHELL I1 IS NOT OCCUPIED IN EITHER JA OR JB, IGNORE THE
C SHELL, DO NOT INCREASE IHSH, AND CONSIDER NEXT SHELL BY INCREASING
C I1
C
7 IF(NA-1) 8,8,9
8 IF(NB-1) 1,1,9
C
C --- IF THE SHELL I1 IS OCCUPIED IN EITHER JA OR JB -
C (1) IF IHSH.GT.1, THEN ALREADY AT LEAST TWO SHELLS AND THE
C RESULTING COUPLINGS HAVE BEEN STORED. WE MUST THUS MAKE ROOM FOR
C THE QUANTUM NUMBERS OF THIS NEW SHELL BETWEEN THE QUANTUM NUMBERS
C OF THE PREVIOUS SHELLS AND THE QUANTUM NUMBERS OF THE INTERMEDIATE
C COUPLINGS OF THE CONFIGURATIONS. THUS THE LATTER SET ARE =MOVED
C ALONG= TO MAKE ROOM FOR THE NEW SHELL
C (2) IF IHSH.LE.1, THERE ARE NO INTERMEDIATE COUPLING QUANTUM
C NUMBERS, AND SO THERE IS NOTHING TO MOVE
C
9 IF(IHSH-1) 11,11,10
10 DO 12 I=1,2
DO 13 J=I3,I2HSH
I4=I5-J
DO 14 K=1,3
J1QN(I4+1,K,I)=J1QN(I4,K,I)
14 CONTINUE
13 CONTINUE
12 CONTINUE
11 IHSH=I3
I2HSH=I2HSH+2
NC=NA
I=1
IC=J1
JC=JA
C
C --- FIRST CONSIDER THE L.H.S. (I=1) OF THE MATRIX ELEMENT. NC=1 MEANS
C UNOCCUPIED, REPRESENTED BY A DUMMY SINGLET S SHELL, AND THE
C ADDITIONAL SET OF COUPLING QUANTUM NUMBERS WILL BE THE SAME AS THE
C LAST SET OF COUPLING QUANTUM NUMBERS ALREADY OBTAINED.
C NC=2 MEANS OCCUPIED. THEN ALL THE NEW QUANTUM NUMBERS (BOTH FOR
C THE SHELL AND FOR THE COUPLING OF THIS SHELL TO THE RESULTANT OF
C THE PREVIOUS ONES) ARE DEFINED IN THE CORRESPONDING J1QNRD ARRAY.
C NOSH - THE NUMBER OF ELECTRONS IN THIS SHELL, IS DEFINED BY THE
C APPROPRIATE ENTRY IN NELCSH . THE R.H.S. IS THEN CONSIDERED
C SIMILARLY (I=2)
C
25 GO TO (15,16),NC
15 NOSH(IHSH,I)=0
J1QN(IHSH,1,I)=0
J1QN(IHSH,2,I)=1
J1QN(IHSH,3,I)=1
IF(IHSH-2) 22,18,19
18 J1QN(3,1,I)=0
J1QN(3,2,I)=J1QN(1,2,I)
J1QN(3,3,I)=J1QN(1,3,I)
GO TO 22
19 DO 27 K=1,3
J1QN(I2HSH,K,I)=J1QN(I2HSH-1,K,I)
27 CONTINUE
GO TO 22
16 NOSH(IHSH,I)=NELCSH(IC,JC)
DO 20 K=1,3
J1QN(IHSH,K,I)=J1QNRD(IC,K,JC)
C
C IS THIS THE FIRST OCCUPIED SHELL OF EITHER CONFIGURATION. IF SO,
C THEN THERE ARE NO INTERMEDIATE COUPLINGS TO CONSIDER AT THIS STAGE
C
IF(IHSH-1) 20,20,21
C
C IS THIS THE FIRST OCCUPIED SHELL OF THIS CONFIGURATION, THOUGH NOT
C THE FIRST OF THE OTHER CONFIGURATION. IF SO, THE INTERMEDIATE
C COUPLING FORMED HAS THE SAME L,S VALUES AS THIS OCCUPIED SHELL,
C SINCE WE COUPLE THE SHELL TO A DUMMY SINGLET S.
C
21 IF(IC-1) 26,26,29
26 I2=1
IF(K-1) 28,17,28
C
C SENIORITY SET (ARBITRARILY) ZERO FOR INTERMEDIATE COUPLING
C
17 J1QN(I2HSH,1,I)=0
GO TO 20
29 I2=NOCCSH(JC)+IC-1
28 J1QN(I2HSH,K,I)=J1QNRD(I2,K,JC)
20 CONTINUE
22 IF(I-2) 23,24,24
23 NC=NB
I=2
IC=J2
JC=JB
GO TO 25
C
C --- SET THE NJ AND LJ VALUES OF THE OCCUPIED SHELLS
C
24 NJ(IHSH)=NJCOMP(I1)
LJ(IHSH)=LJCOMP(I1)
ijful(ihsh)=i1
C
C --- RETURN TO 1 TO SEE IF MAXORB HAS BEEN REACHED
C
GO TO 1
100 RETURN
END
c
c--------------------------------------------------------------------
c v i j o u t
c--------------------------------------------------------------------
c
SUBROUTINE VIJOUT(JA,JB)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
C
C THIS SUBROUTINE IS ENTERED ONLY IF IBUG1 IS GREATER THAN ZERO
C
C --- PRINT OUT OF QUANTUM NUMBERS AND COUPLING SCHEMES FOR EACH
C MATRIX ELEMENT AS DEFINED BY SETUP
C
5 FORMAT(//48H L.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY)
6 FORMAT(//48H R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY)
7 FORMAT(9H1(CONFIG ,I2,10H/V/CONFIG ,I2,1H))
8 FORMAT(/7H NJ,LJ ,10(I6,I3))
9 FORMAT(/6H NOSH ,10I4)
10 FORMAT(6H J1QN ,10(I5,2I3))
I2HSH=2*IHSH-1
WRITE(IWRITE,7) JA,JB
WRITE(IWRITE,8) (NJ(I),LJ(I),I=1,IHSH)
IF(IBUG1-1) 1,1,2
2 WRITE(IWRITE,5)
WRITE(IWRITE,9) (NOSH1(J),J=1,IHSH)
WRITE(IWRITE,10) ((J1QN1(J,K),K=1,3),J=1,I2HSH)
WRITE(IWRITE,6)
WRITE(IWRITE,9) (NOSH2(J),J=1,IHSH)
WRITE(IWRITE,10) ((J1QN2(J,K),K=1,3),J=1,I2HSH)
1 RETURN
END
c
c----------------------------------------------------------------------
c o r t h o g
c----------------------------------------------------------------------
c
SUBROUTINE ORTHOG(LET)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
C
C THIS SUBROUTINE CHECKS FOR POSSIBLE ORTHOGONALITY DUE TO
C COUPLING DIFFERENCES OR UNEVEN PARITY
C
101 FORMAT(37H DIFFERING RESULTANT ANGULAR MOMENTUM)
102 FORMAT(52H ORTHOGONALITY IN COUPLING SCHEMES OF CONFIGURATIONS)
103 FORMAT(59H THE TWO CONFIGURATIONS HAVE DIFFERING NUMBERS OF ELECTR
1ONS)
104 FORMAT(51H THE TWO CONFIGURATIONS HAVE DIFFERING TOTAL PARITY)
C
C --- DO PSI AND PSIP CONTAIN THE SAME NUMBERS OF ELECTRONS
C DO PSI AND PSIP HAVE THE SAME TOTAL PARITY
C
N5=0
N6=0
N7=0
DO 20 I=1,IHSH
L1=LJ(I)
L2=NOSH1(I)
L3=NOSH2(I)
N5=N5+L2
N6=N6+L3
N7=N7+L1*(L2-L3)
20 CONTINUE
C
C CHECK ON NUMBER OF ELECTRONS
C
IF (N5-N6) 21,22,21
21 IF(IBUG1-1) 11,28,28
28 WRITE(IWRITE,103)
GO TO 11
C
C CHECK ON PARITY
C
22 IF(N7-N7/2*2) 23,24,23
23 IF(IBUG1-1) 11,25,25
25 WRITE(IWRITE,104)
GO TO 11
24 N1=2*IHSH-1
N2=IHSH+1
N3=IHSH-1
N4=IHSH-2
C
C --- IS THE FINAL STATE THE SAME FOR PSI AND PSIP
C
DO 1 K=2,3
IF(J1QN1(N1,K)-J1QN2(N1,K))2,1,2
1 CONTINUE
GO TO 3
2 IF(IBUG1-1) 11,26,26
26 WRITE(IWRITE,101)
C
C --- THE TWO CONFIGURATIONS WILL HAVE ZERO HAMILTONIAN MATRIX ELEMENT
C
11 LET=0
RETURN
C
C --- COUPLING ORTHOGONALITY TEST FOR FIRST TWO SHELLS
C
3 write(iwrite,102)
C
C --- NO OBVIOUS ANGULAR MOMENTUM ORTHOGONALITY
C
LET=1
RETURN
END
c
c---------------------------------------------------------------------
c r k w t s
c---------------------------------------------------------------------
c
SUBROUTINE RKWTS
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
COMMON/REMOVE/ICHOP(10)
C
C THE MATRIX ELEMENT OF THE TWO-ELECTRON POTENTIAL BETWEEN TWO
C STATES (LABELLED 1 AND 2) MAY BE EXPRESSED AS A SUM OF WEIGHTED
C RK (SLATER) INTEGRALS. THIS SUBROUTINE, TOGETHER WITH THOSE
C CALLED BY IT, DETERMINES THESE WEIGHTS, WHICH ARISE FROM AN
C INTEGRATION OVER THE ANGULAR AND SPIN CO-ORDINATES
C FOR DETAILS, SEE U. FANO, PHYS. REV.,140,A67,(1965)
C
C THE =INTERACTING= SHELLS ARE DESIGNATED IRHO,ISIG,IRHOP,ISIGP.
C THE FIRST TWO REFER TO THE L.H.S. OF (PSI/V/PSIP) , WHILE
C THE SECOND TWO REFER TO THE R.H.S. FOR DIAGONAL AND CERTAIN OFF-
C DIAGONAL MATRIX ELEMENTS, THESE MAY NOT BE UNIQUE, AND EACH
C POSSIBILITY MUST BE CONSIDERED IN TURN
C THE CONDITION =IRHO .LE. ISIG , IRHOP .LE. ISIGP= IS TO BE
C SATISFIED
C
61 FORMAT(//10X,7H IRHO =,I3,4X,7H ISIG =,I3,4X,8H IRHOP =,I3,3X,8H I
1SIGP =,I3)
C
C === DETERMINE THE INTERACTING SHELLS AS FAR AS POSSIBLE BY
C CONSIDERING THE DIFFERENCES BETWEEN PSI AND PSIP
C
IBUG2=2
IX=0
IRHO=0
ISIG=0
IRHOP=0
ISIGP=0
DO 4 J=1,IHSH
N=NOSH1(J)-NOSH2(J)
IF(IABS(N)-2) 5,5,1
5 IF(N) 7,4,6
6 IF(N-1) 4,8,9
C
C --- TO SATISFY =IRHO.LE.ISIG= IRHO IS SET FIRST, ETC.
C
8 IF(IRHO) 10,10,11
10 IRHO = J
GO TO 12
11 ISIG=J
12 IX =IX+1
GO TO 4
9 IRHO=J
IX=IX+2
GO TO 4
7 IF(N+1) 13,14,4
14 IF(IRHOP) 15,15,16
15 IRHOP = J
GO TO 17
16 ISIGP=J
17 IX=IX+1
GO TO 4
13 IRHOP=J
IX=IX+2
4 CONTINUE
C
C IX MEASURES THE TOTAL NUMBER OF ELECTRONS IN EITHER CONFIGURATION
C WHICH DO NOT OCCUR IN THE OTHER. THEN IF IX IS GREATER THAN 4,
C ORTHOGONALITY OF THE ORBITALS PREVENTS A NON-ZERO MATRIX ELEMENT.
C IF IX IS LESS THAN 4, THEN WE DIVIDE IX BY 2 AND NOW IX MEASURES
C THE NUMBER OF ELECTRONS WHICH HAVE BEEN CHANGED IN GOING FROM PSI
C TO PSIP. IF NOW IX=0, WE HAVE A DIAGONAL MATRIX ELEMENT. RHO AND
C SIG MAY TAKE ON ANY VALUES LESS THAN IHSH. IF IX=1, ONE INTER-
C ACTING SHELL ON EACH SIDE IS FIXED, WHILE THE OTHER MAY VARY. IF
C IX=2, ALL INTERACTING SHELLS ARE DETERMINED
C
IF(IX-4) 18,18,1
18 IX=IX/2
IF(IX-1) 19,20,21
C
C === UNIQUE SPECIFICATION OF INTERACTING SHELLS
C
21 IF(ISIG) 22,23,22
23 ISIG=IRHO
22 IF(ISIGP) 24,25,24
25 ISIGP = IRHOP
24 IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP
C
C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS
C
CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
CALL FANO(IRHO,ISIG,IRHOP,ISIGP)
IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP)
CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP)
RETURN
C
C === ONE INTERACTING SHELL SPECIFIED ON EACH SIDE. SUMMATION OVER OTHER
C
20 IRSTO=IRHO
IRPSTO=IRHOP
DO 125 K1=1,IHSH
IF(NOSH1(K1)) 26,125,26
26 ISIG=K1
IF(NOSH2(K1)) 29,125,29
29 ISIGP = K1
IRHO=IRSTO
IRHOP=IRPSTO
C
C ORTHOGONALITY OF THE ORBITALS REQUIRES THAT THE VARYING INTER-
C ACTING SHELL BE THE SAME ON BOTH SIDES OF THE MATRIX ELEMENT
C
C --- IRHO.LE.ISIG, IRHOP.LE.ISIGP
C
IF(IRHO-ISIG) 27,127,227
227 ISTO=IRHO
IRHO=ISIG
ISIG = ISTO
GO TO 27
127 IF(NOSH1(ISIG)-1) 125,125,27
27 IF(IRHOP-ISIGP) 30,130,31
31 ISTO=IRHOP
IRHOP = ISIGP
ISIGP = ISTO
GO TO 30
130 IF(NOSH2(ISIGP)-1) 125,125,30
30 IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP
C
C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS
C
CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
CALL FANO(IRHO,ISIG,IRHOP,ISIGP)
IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP)
CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP)
125 CONTINUE
RETURN
C
C === NO INTERACTING SHELLS SPECIFIED
C SUMMATION OVER ALL POSSIBLE COMBINATIONS
C IN THIS CASE, ORTHOGONALITY OF ORBITALS PRECLUDES ALL CASES
C EXCEPT IRHO=IRHOP AND ISIG=ISIGP
C
19 DO 32 K1=1,IHSH
IF(NOSH1(K1)) 36,32,36
36 ISIG=K1
DO 33 K2=1,K1
IF(NOSH1(K2)) 37,33,37
37 IRHO=K2
IF(IRHO-ISIG) 50,51,50
51 IF(NOSH1(ISIG)-1) 33,33,50
50 IRHOP=IRHO
ISIGP=ISIG
IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP
C
C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS
C
IF(ICHOP(K1).EQ.1.OR.ICHOP(K2).EQ.1) GO TO 34
CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
CALL FANO(IRHO,ISIG,IRHOP,ISIGP)
IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP)
CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP)
GO TO 33
34 CALL USEEAV(IRHO,ISIG)
33 CONTINUE
32 CONTINUE
1 RETURN
C
C --- SET CONSTANTS USEFUL IN INNER SUBROUTINES
C
END
c
c-----------------------------------------------------------------------
c f a n o
c-----------------------------------------------------------------------
c
SUBROUTINE FANO(IRHO,ISIG,IRHOP,ISIGP)
DIMENSION RMEDIR(9),RMEEX(9),NBAR(10)
DIMENSION K6(40),K7(80),K8(40),KW(6,20)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/KRON/IDEL(10,10)
COMMON/TERMS/NROWS,ITAB(12),JTAB(12),NTAB(171)
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
common/xation/amult(9),bmult(9),kd1,kd2,ke1,ke2,multd,multe
COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP
COMMON/INTERM/J1BAR1(10,3),J1BAR2(10,3),J1TLD1(3),J1TLD2(3)
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
C
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C === DETERMINES POTENTIAL MATRIX ELEMENT FOR GIVEN RHO,SIG,RHOP,SIGP
C
C
301 FORMAT(21H NO POSSIBLE K-VALUES)
302 FORMAT(66H SPECTATOR QUANTUM NUMBERS NOT DIAGONAL FOR NON-INTERACT
1ING SHELLS)
305 FORMAT(23H DIRECT SPIN INTEGRAL =,F10.6)
306 FORMAT(25H EXCHANGE SPIN INTEGRAL =,F10.6)
307 FORMAT(6H NJ,LJ,4(I8,I4))
308 FORMAT(6H KD1 =,I4,6H KD2 =,I4,6H KE1 =,I4,6H KE2 =,I4)
309 FORMAT(56H ROWS OF TERM TABLE CONTAINING PARENTS ARE, RESPECTIVELY
1,2(I6,I3))
310 FORMAT(26H DIRECT ANGULAR INTEGRAL =,F10.6)
c 311 FORMAT(3H J1,I6,36I3)
312 FORMAT(28H EXCHANGE ANGULAR INTEGRAL =,F10.6)
C
C --- SET USEFUL CONSTANTS
C
M1=ISIG-IRHO
M2=ISIGP-IRHOP
M19=IRHO-IRHOP
M20=ISIG-ISIGP
MULTD=0
MULTE=0
C
C JSNDIR,JANGDI=0 IMPLIES APPROPRIATE J2,J3 ARRAYS FOR CALL OF
C NJSYM HAVE NOT BEEN SET
C
JSNDIR=0
JANGDI=0
C
C --- SET N,L VALUES OF INTERACTING SHELLS
C
NRHO=NJ(IRHO)
LRHO=LJ(IRHO)
NSIG=NJ(ISIG)
LSIG=LJ(ISIG)
NRHOP=NJ(IRHOP)
LRHOP=LJ(IRHOP)
NSIGP=NJ(ISIGP)
LSIGP=LJ(ISIGP)
IF(IBUG1-1) 160,160,161
161 WRITE(IWRITE,307) NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP
C
C --- EVALUATE MULTIPLICATIVE FACTORS
C
160 IL=IDEL(IRHO,ISIG)
IR=IDEL(IRHOP,ISIGP)
q=nosh1(irho)*(nosh1(isig)-il)*nosh2(irhop)*(nosh2(isigp)-ir)
xmult=sqrt(q)*half
adirct=(1+(1-il)*(1-ir))/sqrt((lsig+lsig+one)*(lrhop+lrhop+one))
IEXCHG=2-IL-IR
aexchg=iexchg/sqrt((lsig+lsig+one)*(lsig+lsig+one))
DO 13 J=1,IHSH
NBAR(J)=NOSH1(J)-IDEL(J,IRHO)-IDEL(J,ISIG)
13 CONTINUE
IDELP=0
IF(M1) 14,15,14
14 K1=IRHO+1
DO 16 J=K1,ISIG
IDELP=IDELP+NBAR(J)
16 CONTINUE
15 IF(M2) 17,18,17
17 K1=IRHOP+1
DO 19 J=K1,ISIGP
IDELP=IDELP+NBAR(J)
19 CONTINUE
18 xmult=xmult*(-one)**idelp
C
C --- DETERMINES RANGES OF K FOR DIRECT AND EXCHANGE INTEGRALS
C TRIANGULAR RELATIONS LIMIT (K+1) VALUES TO LIE BETWEEN KD1 AND KD2
C FOR =DIRECT= INTEGRALS, KE1 AND KE2 FOR =EXCHANGE= INTEGRALS
C
K1=IABS(LSIG-LSIGP)
K2=LSIG+LSIGP
K3=IABS(LRHO-LRHOP)
K4=LRHO+LRHOP
KD1=MAX0(K1,K3)+1
KD2=MIN0(K2,K4)+1
K1=IABS(LRHOP-LSIG)
K2=LRHOP+LSIG
K3=IABS(LRHO-LSIGP)
K4=LRHO+LSIGP
KE1=MAX0(K1,K3)+1
KE2=MIN0(K2,K4)+1
IF(IBUG1-1) 612,612,613
613 WRITE(IWRITE,308) KD1,KD2,KE1,KE2
612 IF(KD1-KD2) 213,213,211
211 IF(KE1-KE2) 213,213,212
212 IF(IBUG1-1) 400,400,401
401 WRITE(IWRITE,301)
400 RETURN
C
C --- ZEROIZE MULTIPLYING FACTORS FOR ALLOWED K-VALUES. THE LOWEST
C VALUES KD1 AND KD2 ARE ALWAYS ALLOWED (UNLESS THEY ARE
C GREATER THAN KD2 AND KE2 RESPECTIVELY). ALLOWED K-VALUES THEN
C STEP BY 2 TO SATISFY THE EVEN CONDITION OF THE REDUCED MATRIX
C ELEMENTS, WHICH ARE THEN CALCULATED AND STORED
C
213 IF(KD1-KD2) 231,231,232
231 DO 230 JK1=KD1,KD2,2
K=JK1-1
AMULT(JK1)=one
RMEDIR(JK1)=RME(LRHO,LRHOP,K)*RME(LSIG,LSIGP,K)
230 CONTINUE
232 IF(KE1-KE2) 233,233,241
233 DO 234 JK1=KE1,KE2,2
K=JK1-1
BMULT(JK1)=one
RMEEX(JK1)=RME(LRHO,LSIGP,K)*RME(LSIG,LRHOP,K)
234 CONTINUE
C
C --- SET SENIORITY, S AND L VALUES OF SPECTATOR SHELLS
C
241 DO 26 J=1,IHSH
IF(IRHO-J) 27,29,27
27 IF(ISIG-J) 28,29,28
28 DO 128 K=1,3
J1BAR1(J,K)=J1QN1(J,K)
128 CONTINUE
29 IF(IRHOP-J) 30,26,30
30 IF(ISIGP-J) 31,26,31
31 DO 181 K=1,3
J1BAR2(J,K)=J1QN2(J,K)
181 CONTINUE
IF(IRHO-J) 32,26,32
32 IF(ISIG-J) 33,26,33
C
C CHECK THAT SPECTATOR SHELLS HAVE SAME RESPECTIVE QUANTUM NUMBERS
C
33 DO 183 K=1,3
IF(J1BAR1(J,K)-J1BAR2(J,K)) 402,183,402
183 CONTINUE
26 CONTINUE
GO TO 405
402 IF(IBUG1-1) 404,404,403
403 WRITE(IWRITE,302)
404 RETURN
C
C --- FROM WHICH ROWS OF NTAB DO WE FIND THE QUANTUM NUMBERS WITH BARS
C OR TILDES
C
405 NELCTS=NOSH1(ISIG)
K2=NTAB1(NELCTS,LSIG+1)
IF(M1) 20,21,20
21 NELCTS=NOSH1(ISIG)-1
GO TO 22
20 NELCTS=NOSH1(IRHO)
22 K1=NTAB1(NELCTS,LRHO+1)
NELCTS=NOSH2(ISIGP)
K4=NTAB1(NELCTS,LSIGP+1)
IF(M2) 23,24,23
24 NELCTS=NOSH2(ISIGP)-1
GO TO 25
23 NELCTS=NOSH2(IRHOP)
25 K3=NTAB1(NELCTS,LRHOP+1)
IF(IBUG1-1) 59,59,49
49 WRITE(IWRITE,309) K1,K2,K3,K4
59 KK1=ITAB(K1)
KK2=ITAB(K2)
KK3=ITAB(K3)
KK4=ITAB(K4)
C
C === SUM OVER QUANTUM NUMBERS WITH BARS OR TILDES
C
DO 151 JJ2=1,KK2
C
C --- TEST TO SEE WHICH PARENT TERMS ARE ALLOWABLE. ONLY TEST THIS ON
C L AND S VALUES AT THIS STAGE, BY MEANS OF TRIANGULAR CONDITIONS
C FOR TWICE THE QUANTUM NUMBERS, IN ORDER TO USE ONLY INTEGER
C QUANTITIES
C
IN3=2*LSIG
IJK2=3*(JJ2-1)+JTAB(K2)
DO 131 K=2,3
IN1=NTAB(IJK2+K)-1
IN2=J1QN1(ISIG,K)-1
IF(IN1-IN2-IN3) 130,130,151
130 IF(IN1-IABS(IN2-IN3)) 151,140,140
140 IN3=1
131 CONTINUE
DO 152 JJ1=1,KK1
IN3=2*LRHO
IJK1=3*(JJ1-1)+JTAB(K1)
DO 132 K=2,3
IN1=NTAB(IJK1+K)-1
IF(M1) 141,142,141
141 IN2=J1QN1(IRHO,K)-1
GO TO 143
142 IN2=NTAB(IJK2+K)-1
143 IF(IN1-IN2-IN3) 144,144,152
144 IF(IN1-IABS(IN2-IN3)) 152,145,145
145 IN3=1
132 CONTINUE
DO 153 JJ4=1,KK4
IN3=2*LSIGP
IJK4=3*(JJ4-1)+JTAB(K4)
DO 133 K=2,3
IN1=NTAB(IJK4+K)-1
IN2=J1QN2(ISIGP,K)-1
IF(IN1-IN2-IN3) 146,146,153
146 IF(IN1-IABS(IN2-IN3)) 153,147,147
147 IN3=1
133 CONTINUE
DO 154 JJ3=1,KK3
IN3=2*LRHOP
IJK3=3*(JJ3-1)+JTAB(K3)
DO 134 K=2,3
IN1=NTAB(IJK3+K)-1
IF(M2) 138,139,138
138 IN2=J1QN2(IRHOP,K)-1
GO TO 148
139 IN2=NTAB(IJK4+K)-1
148 IF(IN1-IN2-IN3) 149,149,154
149 IF(IN1-IABS(IN2-IN3)) 154,150,150
150 IN3=1
134 CONTINUE
C
C SUMMATIONS NOW PERFORMED OVER ALLOWED QUANTUM NUMBERS
C THE TILDES CORRESPOND TO IRHO=ISIG AND/OR IRHOP=ISIGP
C
C --- SET THE REMAINING QUANTUM NUMBERS WITH BARS OR TILDES
C
DO 35 K=1,3
J1BAR1(IRHO,K)=NTAB(IJK1+K)
J1BAR2(IRHOP,K)=NTAB(IJK3+K)
IF(M1) 36,37,36
36 J1BAR1(ISIG,K)=NTAB(IJK2+K)
GO TO 38
37 J1TLD1(K)=NTAB(IJK2+K)
38 IF( M2) 39,40,39
39 J1BAR2(ISIGP,K)=NTAB(IJK4+K)
GO TO 35
40 J1TLD2(K)=NTAB(IJK4+K)
35 CONTINUE
C
C --- IS POTENTIAL DIAG. IN BARRED QU. NOS. FOR INTERACTING SHELLS
C
I5=0
I=ISIG
GO TO 50
42 I=IRHO
IF( M1) 43,44,43
43 GO TO 50
44 I5=I5+1
45 I=ISIGP
GO TO 50
46 I=IRHOP
IF(M2) 47,48,47
47 GO TO 50
50 I5=I5+1
DO 51 K=1,3
IF(J1BAR1(I,K)-J1BAR2(I,K)) 154,51,154
51 CONTINUE
GO TO (42,45,46,48),I5
48 PICFP=one
C
C --- EVALUATE FRACTIONAL PARENTAGE COEFFICIENTS
C
I=1
CALL MUMDAD (I,ISIG,IRHO,M1,CFPLHS)
PICFP=PICFP*CFPLHS
if(abs(picfp).lt.eps) go to 154
I=2
CALL MUMDAD(I,ISIGP,IRHOP,M2,CFPRHS)
PICFP=PICFP*CFPRHS
IF(ABS(PICFP).LT.eps) GO TO 154
C
C === SET UP J1,J2,J3 AND EVALUATE RECOUPLING COEFFICIENTS
C
C --- FIRST OF ALL, THE SPIN COEFFICIENTS
C
I=3
CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP)
CALL J23SPN(IRHO,ISIG,IRHOP,ISIGP,JSNDIR)
C
C --- DIRECT SPIN INTEGRAL
C
IF(KD1-KD2) 89,89,90
90 SPINDT=zero
GO TO 78
89 CALL NJSYM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,SPINDT)
78 IF(IBUG1-1) 91,91,170
170 WRITE(IWRITE,305) SPINDT
C
C IEXCHG IS ZERO WHENEVER M1=0=M2 , IN WHICH CASE THE EXCHANGE
C INTEGRAL HAS ZERO COEFFICIENT. THERE IS THEN NO POINT IN
C CALCULATING THIS INTEGRAL, AND SPINEX IS SET ZERO (AT STATEMENT
C 93) AS A MARKER OF THIS SITUATION
C
91 IF(IEXCHG.EQ.0) GO TO 93
C
C --- MODIFY J2 AND J3 TO CALCULATE THE EXCHANGE SPIN INTEGRAL
C
I=1
CALL MODJ23(I)
C
C --- EXCHANGE SPIN INTEGRAL
C
IF(KE1-KE2) 92,92,93
93 SPINEX=zero
GO TO 94
92 CALL NJSYM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,SPINEX)
94 IF(IBUG1-1) 171,171,172
172 WRITE(IWRITE,306) SPINEX
C
C --- MULTIPLY SPIN INTEGRALS BY PRODUCT OF FRACTIONAL PARENTAGE COEFFS
C
171 BDIRCT=SPINDT*PICFP
BEXCHG=SPINEX*PICFP
C
C --- THE ANGULAR RECOUPLING COEFFICIENTS
C SET J1,J2,J3 (COMPARE SPIN INTEGRALS)
C
C IF BOTH SPIN INTEGRALS ARE ZERO, THERE IS NO PURPOSE IN
C CALCULATING THE ANGULAR INTEGRALS
C
if(abs(spindt).lt.eps.and.abs(spinex).lt.eps) go to 154
C
I=2
CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP)
CALL J23ANG(IRHO,ISIG,IRHOP,ISIGP,JANGDI)
C
C IF THE DIRECT SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT
C CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT
C
if(abs(spindt).lt.eps) go to 121
c
C --- DIRECT ANGULAR INTEGRAL
C
C CONSIDER ALL ALLOWED K-VALUES
C
DO 114 JK1=KD1,KD2,2
CALL J23ANG(IRHO,ISIG,IRHOP,ISIGP,JANGDI)
J1(NJ1S)=2*JK1-1
CALL NJSYM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,ANGDIR)
C
C ADD INTO THE COEFFICIENT OF THE SLATER INTEGRAL
C
AMULT(JK1)=AMULT(JK1)+ANGDIR*BDIRCT
C
C MULTD=1 WHEN A DIRECT INTEGRAL COEFFICIENT HAS BEEN CALCULATED -
C FOR USE, SEE PRNTWT
C
MULTD=1
IF(IBUG1-1) 114,114,123
123 WRITE(IWRITE,310) ANGDIR
114 CONTINUE
C
C IF THE EXCHANGE SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT
C CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT
C
121 if(abs(spinex).lt.eps) go to 154
C
C --- EXCHANGE ANGULAR INTEGRAL
C
C CONSIDER ALL ALLOWED K-VALUES
C
DO 115 JK1=KE1,KE2,2
C
C --- MODIFY J2 AND J3 ARRAYS TO CALCULATE EXCHANGE TERMS
C
I=2
CALL MODJ23(I)
J1(NJ1S) = 2*JK1-1
I=4
CALL NJSYM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,ANGEX)
BMULT(JK1)=BMULT(JK1)-ANGEX*BEXCHG
C
C MULTE=1 WHEN AN EXCHANGE INTEGRAL COEFFICIENT HAS BEEN CALCULATED
C
MULTE=1
IF(IBUG1-1) 115,115,117
117 WRITE(IWRITE,312) ANGEX
115 CONTINUE
154 CONTINUE
153 CONTINUE
152 CONTINUE
151 CONTINUE
C
C === INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THIS
C FOUR-FOLD SUMMATION
C
IF(MULTD) 524,525,524
524 DO 518 JK1=KD1,KD2,2
AMULT(JK1)=AMULT(JK1)*XMULT*RMEDIR(JK1)*ADIRCT
518 CONTINUE
525 IF(MULTE) 526,527,526
526 DO 519 JK1=KE1,KE2,2
BMULT(JK1)=BMULT(JK1)*XMULT*RMEEX(JK1)*AEXCHG
519 CONTINUE
C
C --- PRINT OUT THE VALUES OF THE COEFFICIENTS OF THE SLATER INTEGRALS
C
C THE SUBROUTINE PRNTWT IS CALLED FROM RKWTS
C
527 RETURN
C
C *** DEFINITION OF DIMENSION LIST
C
C RMEDIR(K),K=KD1,KD2,2 - DIRECT REDUCED MATRIX ELEMENT PRODUCT
C RMEEX(K),K=KE1,KE2,2 - EXCHANGE REDUCED MATRIX ELEMENT PRODUCT
C KD1,KE1 ARE ALWAYS .GE. 1
C KD2,KE2 ARE .LE. 1+2*MAX(L-VALUE)
C NBAR(I), I=1,IHSH - NUMBER OF SPECTATOR ELECTRONS IN EACH SHELL
C THE K6,K7,K8,KW ARRAYS ARE DEFINED IN NJSYM
C
C
END
c
c-----------------------------------------------------------------------
c r m e
c-----------------------------------------------------------------------
c
FUNCTION RME(L,LP,K)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/FACT/ GAMMA(20)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C --- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP) - SEE FANO
C AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81
C
200 format(//4h L =,i3,5h LP =,i3,4h K =,i3,
143h RME SET ZERO SINCE TRIANGEL DOES NOT MATCH)
if (k.gt.(l+lp).or.k.lt.iabs(l-lp)) goto 100
I2G=L+LP+K
IG=I2G/2
IF(I2G-2*IG) 1,2,1
1 RME=zero
RETURN
100 IF(IBUG1-1) 1,1,3
3 WRITE(IWRITE,200) L,LP,K
GO TO 1
2 IF(IG) 100,13,12
13 RME=one
RETURN
12 I1=IG-L
I2=IG-LP
I3=IG-K
AL1=GAMMA(I1+1)
AL2=GAMMA(2*I1+1)
ALP1=GAMMA(I2+1)
ALP2=GAMMA(2*I2+1)
AK1=GAMMA(I3+1)
AK2=GAMMA(2*I3+1)
QUSQRT=(2*L+1)*(2*LP+1)*AL2*ALP2*AK2/GAMMA(I2G+2)
RME=SQRT(QUSQRT)*GAMMA(IG+1)/(AL1*ALP1*AK1)
RETURN
END
c
c----------------------------------------------------------------------
c n t a b 1
c----------------------------------------------------------------------
c
FUNCTION NTAB1(NELCTS,K)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
C
C THIS SUBROUTINE CALCULATES THE ROW OF NTAB CORRESPONDING TO THE
C PARENTS WHICH MAY GIVE RISE TO THE TERM ASSOCIATED WITH SHELL
C LAMBDA . E.G. IF WE SEEK THE ROW OF NTAB CONTAINING THE PARENTS
C OF ONE OF THE P**3 TERMS, THE ROW = VALUE OF NTAB1 IS THAT
C CONTAINING THE P**2 TERMS
C
C USE IS MADE OF THE FACT THAT THE LIST OF POSSIBLE PARENTS (SEE
C WHITE - ATOMIC SPECTRA - APPENDIX) IS SYMMETRICAL ABOUT THE
C CONFIGURATION L**(2L+1)
C
C
C --- FOR ONE ELECTRON IN A TERM, THE PARENT IS ALWAYS A SINGLET S TERM
C
IF(NELCTS-1) 1,2,1
2 NTAB1=2
RETURN
C
C OTHERWISE THE VALUE OF NTAB1 DEPENDS ON THE L VALUE OF THE
C ELECTRONS
C
1 GO TO (3,4,5,6,14),K
C
C --- FOR S ELECTRONS, THE ONLY OTHER POSSIBILITY IS THAT NELCTS=2
C
3 NTAB1=1
RETURN
C
C --- P ELECTRONS - ARE WE BEYOND P**4
C
4 IF(NELCTS-4) 7,7,8
8 NELCTS=8-NELCTS
7 NTAB1=1+NELCTS
RETURN
C
C --- D ELECTRONS - ARE WE BEYOND D**6
C
5 IF(NELCTS-6) 9,9,10
10 NELCTS=12-NELCTS
9 NTAB1=4+NELCTS
RETURN
C
C --- F ELECTRONS - ARE THERE MORE THAN TWO. IF SO, THE PROGRAMME NEEDS
C AN F-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINE, AND THE
C ARRAYS IN /TERMS/ NEED EXTENDING
C
6 IF(NELCTS-2) 2,11,12
11 NTAB1 = 11
RETURN
C
C --- G ELECTRONS - ARE THERE MORE THAN TWO. IF SO, THE PROGRAMME
C NEEDS A G-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINE, AND
C THE ARRAYS IN /TERMS/ NEED EXTENDING
C
14 IF(NELCTS-2) 2,15,16
15 NTAB1=12
RETURN
12 WRITE(IWRITE,13)
13 FORMAT(////67H STOP AND EXTEND THE NTAB AND ITAB ARRAYS TO ALLOW M
1ORE F-ELECTRONS/78H YOU WILL ALSO REQUIRE A COMPLETE FRACTIONAL PA
2RENTAGE ROUTINE FOR F-ELECTRONS//)
GO TO 17
16 WRITE(IWRITE,18)
18 FORMAT(////67H STOP AND EXTEND THE NTAB AND ITAB ARRAYS TO ALLOW M
1ORE G-ELECTRONS/78H YOU WILL ALSO REQUIRE A COMPLETE FRACTIONAL PA
2RENTAGE ROUTINE FOR G-ELECTRONS//)
17 CALL EXIT
END
c
c------------------------------------------------------------------------
c m u m d a d
c------------------------------------------------------------------------
c
SUBROUTINE MUMDAD(II,IJ,IK,M,X)
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH(10,2),J1QN(19,3,2),IJFUL(10)
COMMON/INTERM/J1B(10,3,2),J1T(3,2)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C NOTICE THE NAMES IN THE COMMON BLOCKS. SEE SETUP FOR DESCRIPTION
C
C --- CALLS AND EVALUATES FRACTIONAL PARENTAGE COEFFICIENTS
C
X=one
LIJ=LJ(IJ)
IF(LIJ) 12,12,11
12 IF(M)4,5,4
11 N=NOSH(IJ,II)
IVI=J1QN(IJ,1,II)
ILI=(J1QN(IJ,2,II)-1)/2
ISI=J1QN(IJ,3,II)
C
C IF M=0 THERE ARE QUANTUM NUMBERS WITH TILDES TO CONSIDER
C
IF(M) 1,2,1
1 IVJ=J1B(IJ,1,II)
ILJ=(J1B(IJ,2,II)-1)/2
ISJ= J1B(IJ,3,II)
GO TO 3
2 IVJ=J1T(1,II)
ILJ=(J1T(2,II)-1)/2
ISJ=J1T(3,II)
3 CALL CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
X=X*COEFP
IF(ABS(X).LT.eps) GO TO 5
4 LIJ=LJ(IK)
IF(LIJ) 5,5,14
14 IF(M) 6,7,6
6 N=NOSH(IK,II)
IVI=J1QN(IK,1,II)
ILI=(J1QN(IK,2,II)-1)/2
ISI=J1QN(IK,3,II)
IVJ = J1B(IK,1,II)
ILJ =(J1B(IK,2,II)-1)/2
ISJ = J1B(IK,3,II)
GO TO 8
7 N=NOSH(IJ,II)-1
IVI=IVJ
ILI=ILJ
ISI=ISJ
IVJ=J1B(IJ,1,II)
ILJ=(J1B(IJ,2,II)-1)/2
ISJ = J1B(IJ,3,II)
8 CALL CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
X=X*COEFP
5 CONTINUE
RETURN
END
c
c----------------------------------------------------------------------
c c f p
c----------------------------------------------------------------------
c
SUBROUTINE CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
C
C === CHOOSES APPROPRIATE FRACTIONAL PARENTAGE SUBROUTINE
C
9 FORMAT(' UNNECESSARY ATTEMT TO FORM CFP OF AN S-ELEKTRON - THERE'
1 ,' IS AN ERROR')
10 FORMAT(8H COEFP =,F15.9)
K=LIJ+1
C
C IF F-SHELL OR G-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINES
C ARE INCLUDED, THIS COMPUTED GO TO NEEDS MODIFYING TO ACCOUNT FOR
C THIS
C
GO TO (1,2,3,4,4),K
C
C --- FALSE CALL FOR S-SHELLS
C
1 WRITE(IWRITE,9)
CALL EXIT
C
C --- P-SHELLS
C
2 CALL CFPP(N,ILI,ISI,ILJ,ISJ,COEFP)
GO TO 5
C
C --- D-SHELLS
C
3 CALL CFPD(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
GO TO 5
C
C --- F-SHELLS, G-SHELLS ETC. WITH UP TO TWO ELECTRONS
C
4 CALL CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
5 IF(IBUG1-1) 6,6,7
7 WRITE(IWRITE,10) COEFP
6 RETURN
END
c
c------------------------------------------------------------------------
c c f p f
c------------------------------------------------------------------------
c
SUBROUTINE CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
C
C THIS IS A DUMMY SUBROUTINE TO CALCULATE CFP OF F-ELECTRONS. IT IS
C VALID ONLY FOR ONE OR TWO ELECTRONS IN THE F-SHELL UNDER
C CONSIDERATION.
C
COEFP=one
RETURN
END
c
c-------------------------------------------------------------------------
c s e t j 1
c-------------------------------------------------------------------------
c
SUBROUTINE SETJ1(K,IRHO,ISIG,IRHOP,ISIGP)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP
COMMON/INTERM/J1BAR1(10,3),J1BAR2(10,3),J1TLD1(3),J1TLD2(3)
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C === SETS J1 ARRAYS FOR DIRECT INTEGRAL CALLS OF NJSYM
C
15 FORMAT(3H J1,I6,36I3)
DO 1 J=1,IHSH
J1(J)=J1BAR1(J,K)
1 CONTINUE
DO 2 J=M4,M6
J1(J)=J1QN1(J,K)
2 CONTINUE
DO 3 J=M7,M8
J1(J)=J1QN2(J-M3,K)
3 CONTINUE
J1(M10)=J1QN1(ISIG,K)
J1(M12)=J1QN2(ISIGP,K)
IF(M1) 4,5,4
4 J1(M9)=J1QN1(IRHO,K)
GO TO 6
5 J1(M9)=J1TLD1(K)
6 IF(M2) 7,8,7
7 J1(M11)=J1QN2(IRHOP,K)
GO TO 9
8 J1(M11)=J1TLD2(K)
C
C K=2 IMPLIES ANGULAR TERMS , K=3 IMPLIES SPIN TERMS
C
9 IF(K-2) 11,11,10
10 J1(M13)=2
J1(M14)=2
MLIMIT=M14
NJ1S=M14
NJ23S=M5
GO TO 12
11 J1(M13)=2*LRHO+1
J1(M14)=2*LSIG+1
J1(M15)=2*LRHOP+1
J1(M16)=2*LSIGP+1
MLIMIT=M16
NJ1S=M17
NJ23S=M18
12 IF(IBUG1-1) 13,13,16
C
C PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1
C
16 IF(IBUG3.NE.1) WRITE(IWRITE,15)(J1(J),J=1,MLIMIT)
13 RETURN
END
c
c-----------------------------------------------------------------------
c j 2 3 s p n
c-----------------------------------------------------------------------
c
SUBROUTINE J23SPN(IRHO,ISIG,IRHOP,ISIGP,JSNDIR)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36)
C
C === SET UP THE J2 AND J3 ARRAYS FOR THE DIRECT SPIN INTEGRAL CALL
C OF NJSYM
C
303 FORMAT(3H J2,18X,2HJ3)
304 FORMAT(3I5,I10,2I5)
C
C HAVE THE J2 AND J3 ARRAYS ALREADY BEEN SET. IF NOT, THEN GO TO 2
C
IF(JSNDIR) 2,2,1
C
C --- SET THIRD ROW OF J2 AND J3
C
2 IF(IRHO-1) 271,272,271
271 J2(3,1)=1
GO TO 273
272 IF(M1) 274,275,274
275 J2(3,1)=M10
GO TO 276
274 J2(3,1)=M9
GO TO 276
273 IF(IRHO-2) 277,278,277
277 J2(3,2)=2
GO TO 284
278 IF(M1) 280,281,280
280 J2(3,2)=M9
GO TO 284
281 J2(3,2)=M10
GO TO 284
276 IF(ISIG-2) 277,281,277
284 J2(3,3)=M4
IF(IRHOP-1) 285,286,285
285 J3(3,1)=1
GO TO 287
286 IF(M2) 288,289,288
288 J3(3,1)=M11
GO TO 290
289 J3(3,1)=M12
GO TO 290
287 IF(IRHOP-2) 291,292,291
291 J3(3,2)=2
GO TO 293
292 IF(M2) 294,295,294
295 J3(3,2)=M12
GO TO 293
294 J3(3,2)=M11
GO TO 293
290 IF(ISIGP-2) 291,295,291
293 J3(3,3)=M7
C
C --- SET ROWS 4,5,.. ETC.
C
IF(M4-4) 203,202,202
202 DO 470 J=4,M4
J2(J,1)=M4 +J-4
J2(J,3)=M4+J-3
IF(ISIG+1-J) 471,472,471
471 IF(M1) 473,474,473
473 IF(IRHO+1-J) 474,475,474
474 J2(J,2)=J-1
GO TO 476
472 J2(J,2)=M10
GO TO 476
475 J2(J,2)=M9
476 J3(J,1)=M7+J-4
IF(J-M4 ) 482,483,482
483 J3(J,3)=J2(J,3)
GO TO 484
482 J3(J,3)=M7+J-3
484 IF(ISIGP+1-J) 477,478,477
477 IF(M2) 479,480,479
479 IF(IRHOP+1-J) 480,481,480
480 J3(J,2)=J-1
GO TO 470
478 J3(J,2)=M12
GO TO 470
481 J3(J,2)=M11
470 CONTINUE
C
C --- SET FIRST TWO ROWS, CORRESPONDING TO COUPLING OF INTERACTING
C ELECTRONS WITHIN THEIR SHELLS
C
203 J2(2,3)=M10
J2(1,2) = M13
J2(2,2) = M14
J2(1,3) = M9
IF(M1) 82,83,82
82 J2(1,1) = IRHO
J2(2,1) = ISIG
GO TO 84
83 J2(1,1) = ISIG
J2(2,1) = M9
84 J3(2,3) = M12
J3(1,2) = M13
J3(2,2) = M14
J3(1,3) = M11
IF(M2) 85,86,85
85 J3(1,1) = IRHOP
J3(2,1) = ISIGP
GO TO 187
86 J3(1,1) = ISIGP
J3(2,1) = M11
C
C --- STORE J2,J3 ARRAYS FOR USE IN CALCULATING EXCHANGE INTEGRAL
C
187 I1=0
DO 451 J=1,M4
DO 452 K=1,3
I1=I1+1
J2SPIN(I1)=J2(J,K)
J3SPIN(I1)=J3(J,K)
452 CONTINUE
451 CONTINUE
JSNDIR=1
3 IF(IBUG1-1) 570,570,6
C
C PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1
C
6 IF(IBUG3-1) 200,570,200
200 WRITE(IWRITE,303)
DO 201 J=1,M4
WRITE(IWRITE,304) (J2(J,K),K=1,3),(J3(J,K),K=1,3)
201 CONTINUE
570 RETURN
C
C --- SET J2 AND J3 ARRAYS FROM STORE OF PREVIOUS CALCULATIONS
C
1 I1=0
DO 4 J=1,M4
DO 5 K=1,3
I1=I1+1
J2(J,K)=J2SPIN(I1)
J3(J,K)=J3SPIN(I1)
5 CONTINUE
4 CONTINUE
GO TO 3
END
c
c------------------------------------------------------------------
c m o d j 2 3
c------------------------------------------------------------------
c
SUBROUTINE MODJ23(K)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36)
C
C === MODIFIES THE DIRECT J2 AND J3 ARRAYS FOR EXCHANGE CALL OF NJSYM
C
7 FORMAT(3H J2,18X,2HJ3)
8 FORMAT(3I5,I10,2I5)
GO TO (1,2),K
C
C --- K=1 - SPIN INTEGRALS
C
1 MK=M4
I1=0
DO 11 J=1,MK
DO 12 K=1,3
I1=I1+1
J2(J,K)=J2SPIN(I1)
J3(J,K)=J3SPIN(I1)
12 CONTINUE
11 CONTINUE
J3(1,2)=M14
J3(2,2)=M13
GO TO 3
C
C --- K=2 - ANGULAR INTEGRALS
C
2 MK=M5
I1=0
DO 21 J=1,MK
DO 22 K=1,3
I1=I1+1
J2(J,K)=J2ANG(I1)
J3(J,K)=J3ANG(I1)
22 CONTINUE
21 CONTINUE
J2(1,1)=M15
J3(1,3)=M16
3 IF(IBUG1-1) 4,4,9
C
C PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1
C
9 IF(IBUG3-1 ) 5,4,5
5 WRITE(IWRITE,7)
DO 6 J=1,MK
WRITE(IWRITE,8) (J2(J,K),K=1,3),(J3(J,K),K=1,3)
6 CONTINUE
4 RETURN
END
c
c-------------------------------------------------------------------
c j 2 3 a n g
c-------------------------------------------------------------------
c
SUBROUTINE J23ANG(IRHO,ISIG,IRHOP,ISIGP,JANGDI)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36)
C
C === SETS UP J2 AND J3 ARRAYS FOR DIRECT ANGULAR INTEGRAL CALL OF NJSYM
C
303 FORMAT(3H J2,18X,2HJ3)
304 FORMAT(3I5,I10,2I5)
C
C HAVE THE J2 AND J3 ARRAYS ALREADY BEEN SET. IF NOT, THEN GO TO 2
C
IF(JANGDI) 2,2,1
C
C --- ROWS 3 TO M4 OF SPIN J2 AND J3 ARE SAME AS ROWS 4 TO (M4+1) OF
C ANGULAR J2 AND J3
C
2 I1=6
DO 103 J=3,M4
JP1=J+1
DO 104 K=1,3
I1=I1+1
J2(JP1,K)=J2SPIN(I1)
J3(JP1,K)=J3SPIN(I1)
104 CONTINUE
103 CONTINUE
C
C --- SET ROWS 1, 2 AND 3
C
IF(M1) 105,106,105
105 J2(3,1)=ISIG
GO TO 107
106 J2(3,1)=M9
107 IF(M2) 109,110,109
109 J3(3,1)=ISIGP
GO TO 111
110 J3(3,1)=M11
111 J2(2,3)=M9
J2(2,1)=IRHO
J2(2,2)=M13
J2(1,3)=M14
J2(3,2)=M14
J2(3,3)=M10
J2(1,1)=M16
J2(1,2)=M17
J3(3,2)=M16
J3(3,3)=M12
J3(1,2)=M13
J3(1,1)=M17
J3(1,3)=M15
J3(2,3)= M11
J3(2,1)=IRHOP
J3(2,2)=M15
C
C --- STORE J2 AND J3 FOR USE IN CALCULATING THE EXCHANGE TERM
C
I1=0
DO 535 J=1,M5
DO 536 K=1,3
I1=I1+1
J2ANG(I1)=J2(J,K)
J3ANG(I1)=J3(J,K)
536 CONTINUE
535 CONTINUE
JANGDI=1
3 IF(IBUG1-1) 209,209,206
C
C PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1
C
206 IF(IBUG3-1) 207,209,207
207 WRITE(IWRITE,303)
DO 208 J=1,M5
WRITE(IWRITE,304) (J2(J,K),K=1,3),(J3(J,K),K=1,3)
208 CONTINUE
209 RETURN
C
C --- SET J2 AND J3 ARRAYS FROM STORE OF PREVIOUS CALCULATIONS
C
1 I1=0
DO 4 J=1,M5
DO 5 K=1,3
I1=I1+1
J2(J,K)=J2ANG(I1)
J3(J,K)=J3ANG(I1)
5 CONTINUE
4 CONTINUE
GO TO 3
END
c
c---------------------------------------------------------------------
c b l d a t a
c---------------------------------------------------------------------
c
subroutine bldata
COMMON/TERMS/NROWS,I(12),J(12),N(171)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C --- READS IN QUANTUM NUMBERS OF TERMS WHICH CAN BE FORMED FROM
C CONFIGURATIONS L**Q . ONLY THE FIRST HALF OF THAT PART OF THE
C TABLE, CORRESPONDING TO A GIVEN L, IS INCLUDED, BECAUSE OF THE
C SYMMETRY OF THE TABLE. E.G. D**7 FORMS THE SAME TERMS AS D**3
C
C THE ARRAYS I,J,N CORRESPOND TO THE ARRAYS ITAB,JTAB,NTAB
C
DATA NROWS/12/
DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6)/ 1, 1, 1, 3, 3, 1/
DATA I( 7),I( 8),I( 9),I(10),I(11),I(12)/ 5, 8,16,16, 1, 1/
DATA J( 1),J( 2),J( 3),J( 4),J( 5),J( 6)/ 0, 3, 6, 9, 18, 27/
DATA J( 7),J( 8),J( 9),J(10),J(11),J(12)/ 30, 45, 69,117,165,168/
DATA N( 1),N( 2),N( 3),N( 4),N( 5),N( 6)/ 1, 1, 2, 0, 1, 1/
DATA N( 7),N( 8),N( 9),N( 10),N( 11),N( 12)/ 1, 3, 2, 0, 1, 1/
DATA N( 13),N( 14),N( 15),N( 16),N( 17),N( 18)/ 2, 5, 1, 2, 3, 3/
DATA N( 19),N( 20),N( 21),N( 22),N( 23),N( 24)/ 1, 3, 2, 3, 5, 2/
DATA N( 25),N( 26),N( 27),N( 28),N( 29),N( 30)/ 3, 1, 4, 1, 5, 2/
DATA N( 31),N( 32),N( 33),N( 34),N( 35),N( 36)/ 0, 1, 1, 2, 5, 1/
DATA N( 37),N( 38),N( 39),N( 40),N( 41),N( 42)/ 2, 9, 1, 2, 3, 3/
DATA N( 43),N( 44),N( 45),N( 46),N( 47),N( 48)/ 2, 7, 3, 1, 5, 2/
DATA N( 49),N( 50),N( 51),N( 52),N( 53),N( 54)/ 3, 3, 2, 3, 5, 2/
DATA N( 55),N( 56),N( 57),N( 58),N( 59),N( 60)/ 3, 7, 2, 3, 9, 2/
DATA N( 61),N( 62),N( 63),N( 64),N( 65),N( 66)/ 3,11, 2, 3, 3, 4/
DATA N( 67),N( 68),N( 69),N( 70),N( 71),N( 72)/ 3, 7, 4, 0, 1, 1/
DATA N( 73),N( 74),N( 75),N( 76),N( 77),N( 78)/ 2, 5, 1, 2, 9, 1/
DATA N( 79),N( 80),N( 81),N( 82),N( 83),N( 84)/ 2, 3, 3, 2, 7, 3/
DATA N( 85),N( 86),N( 87),N( 88),N( 89),N( 90)/ 4, 1, 1, 4, 5, 1/
DATA N( 91),N( 92),N( 93),N( 94),N( 95),N( 96)/ 4, 7, 1, 4, 9, 1/
DATA N( 97),N( 98),N( 99),N(100),N(101),N(102)/ 4,13, 1, 4, 3, 3/
DATA N(103),N(104),N(105),N(106),N(107),N(108)/ 4, 5, 3, 4, 7, 3/
DATA N(109),N(110),N(111),N(112),N(113),N(114)/ 4, 9, 3, 4,11, 3/
DATA N(115),N(116),N(117),N(118),N(119),N(120)/ 4, 5, 5, 1, 5, 2/
DATA N(121),N(122),N(123),N(124),N(125),N(126)/ 3, 3, 2, 3, 5, 2/
DATA N(127),N(128),N(129),N(130),N(131),N(132)/ 3, 7, 2, 3, 9, 2/
DATA N(133),N(134),N(135),N(136),N(137),N(138)/ 3,11, 2, 3, 3, 4/
DATA N(139),N(140),N(141),N(142),N(143),N(144)/ 3, 7, 4, 5, 1, 2/
DATA N(145),N(146),N(147),N(148),N(149),N(150)/ 5, 5, 2, 5, 7, 2/
DATA N(151),N(152),N(153),N(154),N(155),N(156)/ 5, 9, 2, 5,13, 2/
DATA N(157),N(158),N(159),N(160),N(161),N(162)/ 5, 5, 4, 5, 9, 4/
DATA N(163),N(164),N(165),N(166),N(167),N(168)/ 5, 1, 6, 1, 7, 2/
DATA N(169),N(170),N(171) / 1, 9, 2/
c
c set global real constants
c
data zero,tenth,half,one,two,three,four,seven,eleven,eps/
1 0.0e 00,0.1e 00,0.5e 00,1.0e 00,2.0e 00,3.0e 00,4.0e 00,
2 7.0e 00,1.1e 01,1.0e-08/
c
c
c set constants to be used in cfpd
c
call cfpddata
return
end
c
c----------------------------------------------------------------------
c p r n t w t
c----------------------------------------------------------------------
c
SUBROUTINE PRNTWT(IRHO,ISIG,IRHOP,ISIGP)
C
long IAJCMP
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
common/enav/coefct(5),nints,kvalue(5)
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN(19,3,2),
1ijful(10)
common/diagnl/idiag,ja,jb
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
common/states/ncfg,noccsh(30),nocorb(5,30),nelcsh(5,30),
1 j1qnrd(9,3,30),maxorb,njcomp(21),ljcomp(21),iajcmp(21)
common/xation/amult(9),bmult(9),kd1,kd2,ke1,ke2,multd,multe
COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP
C
C --- PRINTS OUT THE COEFFICIENTS OF SLATER INTEGRALS
C
1 FORMAT(//23H INTERACTING SHELLS ARE,6X,6H RHO =,a3,6X,6H SIG =,a3,
16X,7H RHOP =,a3,6X,7H SIGP =,a3//)
2 format(12x,f18.8,2f21.8,11x,1hF,i1,1h(,a3,1h,,a3,1h))
3 format(12x,f18.8,2f21.8,11x,1hG,i1,1h(,a3,1h,,a3,1h))
4 format(12x,f18.8,2f21.8,8x,1hR,i1,1h(,a3,1h,,a3,1h/,a3,1h,,a3,1h))
5 format(//30x,33h COEFFICIENTS OF SLATER INTEGRALS//16x,17h TOTAL E
1NERGY(ET),4x,19hAVERAGE ENERGY(EAV),6x,10h(ET - EAV),9x,16hTYPE OF
2 INTEGRAL/)
31 FORMAT(I5,F16.8,8I5)
32 FORMAT(6I5)
jrho=ijful(irho)
jsig=ijful(isig)
jrhop=ijful(irhop)
jsigp=ijful(isigp)
C
C --- DETERMINE THE AVERAGE ENERGY CONTRIBUTIONS IF IDIAG IS NON-ZERO
C
if((kd1.gt.kd2).and.(ke1.gt.ke2)) go to 41
IF(IDIAG.EQ.0) GO TO 50
LA=LJ(IRHO)
LB=LJ(ISIG)
IF(M1.EQ.0) GO TO 51
IEQUIV=2
NMULT=NOSH1(IRHO)*NOSH1(ISIG)
GO TO 52
51 IEQUIV=1
NA=NOSH1(IRHO)
NMULT=NA*(NA-1)/2
C
C CALCULATE THE INTERACTION ENERGY
C
52 CALL INTACT(LA,LB,IEQUIV)
INTS=1
50 IF(IBUG1-1) 41,6,7
7 write(iwrite,1) iajcmp(jrho),iajcmp(jsig),iajcmp(jrhop),
1 iajcmp(jsigp)
C
C DEFINITION OF IBUG2 - INITIALLY, IBUG2 IS SET EQUAL TO 2 IN RKWTS.
C THE FIRST TIME THE PRESENT SUBROUTINE IS ENTERED FOR EACH MATRIX
C ELEMENT, IBUG2 HAS THIS VALUE. ONCE FORMAT 5 HAS BEEN WRITTEN,
C IBUG2 ASSUMES THE VALUE OF IBUG1. IF IBUG1=0, THERE WILL BE NO
C PRINT-OUT AT ALL. IF IBUG1=1, FORMAT5 IS OUTPUT ONLY FOR THE
C FIRST ENTRY OF PRNTWT, AND THUS THE ONLY PRINT-OUT FOR THE MATRIX
C ELEMENT AFTER THE FIRST FORMAT 5 IS A LIST OF COEFFICIENTS, AND
C THE APPROPRIATE SLATER INTEGRALS - FK,GK,RK. IF IBUG1.GT.1,
C FORMAT 5 IS OUTPUT FOR EACH SET OF IRHO,ISIG,IRHOP,ISIGP
C
6 IF(IBUG2-1) 8,8,9
9 if(ibug.eq.2.or.(ibug1.eq.1.and.ibug4.eq.0)) write(iwrite,5)
IBUG2=IBUG1
C
C --- DIRECT INTEGRALS
C
8 if(kd1.gt.kd2) go to 20
do 11 jk1=kd1,kd2,2
K=JK1-1
A=AMULT(JK1)
C
C --- DIVIDE THE WEIGHTS INTO AVERAGE ENERGY AND NON-AVERAGE ENERGY
C PARTS
C
IF(IDIAG.NE.0) GO TO 53
C
C NON-DIAGONAL MATRIX ELEMENT
C
X=zero
Y=A
IF(M19.EQ.0.AND.M20.EQ.0) GO TO 15
IF((M1+M2).EQ.0) GO TO 16
GO TO 13
C
C DIAGONAL MATRIX ELEMENT. F0 TERM IS THE ONLY ONE WITH K=0
C
53 IF(K.NE.0) GO TO 57
X=FLOAT(NMULT)
Y=A-X
GO TO 15
C
C OTHER FK INTEGRALS, ONLY OCCUR IF RHO=SIG
C
57 IF(IEQUIV.EQ.1.AND.INTS.LE.NINTS) GO TO 58
59 X=zero
Y=A
GO TO 15
58 IF(K.NE.KVALUE(INTS)) GO TO 59
X=NMULT*COEFCT(INTS)
Y=A-X
INTS=INTS+1
15 if(abs(a).ge.eps.or.abs(x).ge.eps) write(iwrite,2) a,x,y,k,
1 iajcmp(jrho),iajcmp(jsig)
go to 11
16 if(abs(a).ge.eps) write(iwrite,3) a,x,y,k,iajcmp(jrho),
1 iajcmp(jrhop)
go to 11
13 if(abs(a).ge.eps) write(iwrite,4) a,x,y,k,iajcmp(jrho),
1 iajcmp(jsig),iajcmp(jrhop),iajcmp(jsigp)
11 continue
C
C --- EXCHANGE INTEGRALS
C
20 if(ke1.gt.ke2) go to 41
DO 21 JK1=KE1,KE2,2
K=JK1-1
B=BMULT(JK1)
C
C --- DIVIDE THE WEIGHTS INTO AVERAGE ENERGY AND NON-AVERAGE ENERGY
C PARTS
C
IF(IDIAG.NE.0) GO TO 60
C
C NON-DIAGONAL MATRIX ELEMENT
C
X=zero
Y=B
IF(M19.EQ.0.AND.M20.EQ.0) GO TO 25
GO TO 23
C
C DIAGONAL MATRIX ELEMENT
C
60 IF(INTS.LE.NINTS) GO TO 61
62 X=zero
Y=B
GO TO 25
61 IF(K.NE.KVALUE(INTS)) GO TO 62
X=NMULT*COEFCT(INTS)
Y=B-X
INTS=INTS+1
25 if(abs(b).ge.eps.or.abs(x).ge.eps) write(iwrite,3) b,x,y,k,
1 iajcmp(jrho),iajcmp(jsig)
go to 21
23 if(abs(b).ge.eps) write(iwrite,4) b,x,y,k,iajcmp(jrho),
1 iajcmp(jsig),iajcmp(jsigp),iajcmp(jrhop)
21 continue
41 IF(IPUNCH) 40,40,42
C
C --- PUNCH-OUT OF INFORMATION FROM PRNTWT
C
42 WRITE(IPUNCH,32) MULTD,MULTE,KD1,KD2,KE1,KE2
IF(MULTD) 44,43,44
44 DO 45 JK1=KD1,KD2,2
K=JK1-1
WRITE(IPUNCH,31) K,AMULT(JK1),NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,
1 NSIGP,LSIGP
45 CONTINUE
43 IF(MULTE) 46,40,46
46 DO 47 JK1=KE1,KE2,2
K=JK1-1
WRITE(IPUNCH,31) K,BMULT(JK1),NRHO,LRHO,NSIG,LSIG,NSIGP,LSIGP,
1 NRHOP,LRHOP
47 CONTINUE
40 RETURN
END
c
c-------------------------------------------------------------------
c i n t a c t
c-------------------------------------------------------------------
c
c
c **************************************************************
c * *
c * this subroutine contains real constants in the text *
c * *
c **************************************************************
c
c
c
SUBROUTINE INTACT(L,LP,IEQUIV)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
common/enav/coefct(5),nints,kvalue(5)
C
C THIS SUBROUTINE GIVES THE INTERACTION ENERGY BETWEEN TWO SHELLS,
C ONE WITH ORBITAL ANGULAR MOMENTUM L , THE OTHER WITH ORBITAL
C ANGULAR MOMENTUM LP . NOTICE THAT THE FIRST TERM OF THIS
C INTERACTION ENERGY IS ALWAYS F0(L,LP) AND THIS IS NOT GIVEN
C IN THIS SUBROUTINE. THUS ONLY THE EXTRA TERMS ARE HERE PRODUCED.
C FOR EQUIVALENT ELECTRONS (IEQUIV = 1) , THERE WILL BE FK
C INTEGRALS ONLY. FOR NON-EQUIVALENT ELECTRONS (IEQUIV = 2) ,
C THERE WILL BE GK INTEGRALS ONLY.
C
C THE EXPRESSIONS FOR THE INTERACTION ENERGIES INVOLVING SHELLS WITH
C L.LE.3 ARE GIVEN BY J.C. SLATER , QUANTUM THEORY OF ATOMIC
C STRUCTURE, VOL. I, EQUATIONS (14.20) AND (14.22). IN THE LAST
C OF HIS EQUATIONS (14.22) , A TERM -1/14 G0(F,FP) IS OMITTED.
C THIS IS INCLUDED BELOW. THE INTERACTION ENERGIES FOR G-ELECTRON
C SHELLS MAY BE EVALUATED USING HIS EQUATIONS (13.12), (13.17),
C (14.19), AND (14,21)
C
IF(L.GT.4.OR.LP.GT.4) GO TO 3
GO TO (1,2),IEQUIV
C
C === EQUIVALENT ELECTRONS
C
1 IF(L.NE.LP) GO TO 4
GO TO 5
4 WRITE(IWRITE,11)
11 FORMAT(85H ERROR IN INTACT - EQUIVALENT ELECTRONS CALLED FOR DIFFE
1RING ORBITAL ANGULAR MOMENTUM)
CALL EXIT
5 IF(L.GT.0) GO TO 12
C
C S ELECTRONS
C
NINTS=0
RETURN
12 GO TO (13,14,15,16),L
C
C P ELECTRONS
C
13 NINTS=1
KVALUE(1)=2
COEFCT(1)=-0.08
RETURN
C
C D ELECTRONS
C
14 NINTS=2
KVALUE(1)=2
KVALUE(2)=4
COEFCT(1)=-0.031746032
COEFCT(2)=-0.031746032
RETURN
C
C F ELECTRONS
C
15 NINTS=3
KVALUE(1)=2
KVALUE(2)=4
KVALUE(3)=6
COEFCT(1)=-0.020512821
COEFCT(2)=-0.013986014
COEFCT(3)=-0.017930787
RETURN
C
C G ELECTRONS
C
16 NINTS=4
KVALUE(1)=2
KVALUE(2)=4
KVALUE(3)=6
KVALUE(4)=8
COEFCT(1)=-0.015278839
COEFCT(2)=-0.009519892
COEFCT(3)=-0.008227067
COEFCT(4)=-0.011856655
RETURN
C
C --- NON-EQUIVALENT ELECTRONS
C
2 IF(L.GT.LP) GO TO 21
L1=L
L2=LP
GO TO 22
21 L1=LP
L2=L
22 L1D=L1+1
L2D=L2+1
GO TO (30,40,50,60,70),L1D
30 NINTS=1
KVALUE(1)=L2
GO TO (31,32,33,34,35),L2D
C
C S - S INTERACTION
C
31 COEFCT(1)=-0.5
RETURN
C
C S - P INTERACTION
C
32 COEFCT(1)=-0.166666667
RETURN
C
C S - D INTERACTION
C
33 COEFCT(1)=-0.1
RETURN
C
C S - F INTERACTION
C
34 COEFCT(1)=-0.071428571
RETURN
C
C S - G INTERACTION
C
35 COEFCT(1)=-0.055555556
RETURN
40 NINTS=2
KVALUE(1)=L2-1
KVALUE(2)=L2D
GO TO (41,42,43,44),L2
C
C P - P INTERACTION
C
41 COEFCT(1)=-0.166666667
COEFCT(2)=-0.066666667
RETURN
C
C P - D INTERACTION
C
42 COEFCT(1)=-0.066666667
COEFCT(2)=-0.042857143
RETURN
C
C P - F INTERACTION
C
43 COEFCT(1)=-0.042857143
COEFCT(2)=-0.031746032
RETURN
C
C P - G INTERACTION
C
44 COEFCT(1)=-0.031746032
COEFCT(2)=-0.025252525
RETURN
50 NINTS=3
KVALUE(1)=L2-2
KVALUE(2)=L2
KVALUE(3)=L2+2
L3=L2-1
GO TO (51,52,53),L3
C
C D - D INTERACTION
C
51 COEFCT(1)=-0.1
COEFCT(2)=-0.028571429
COEFCT(3)=-0.028571429
RETURN
C
C D - F INTERACTION
C
52 COEFCT(1)=-0.042857143
COEFCT(2)=-0.019047619
COEFCT(3)=-0.021645022
RETURN
C
C D - G INTERACTION
C
53 COEFCT(1)=-0.028571429
COEFCT(2)=-0.014430014
COEFCT(3)=-0.017482517
RETURN
60 NINTS=4
KVALUE(1)=L2-3
KVALUE(2)=L2-1
KVALUE(3)=L2+1
KVALUE(4)=L2+3
L3=L2-2
GO TO (61,62),L3
C
C F - F INTERACTION
C
61 COEFCT(1)=-0.071428571
COEFCT(2)=-0.019047619
COEFCT(3)=-0.012987013
COEFCT(4)=-0.016650017
RETURN
C
C F - G INTERACTION
C
62 COEFCT(1)=-0.031746032
COEFCT(2)=-0.012987013
COEFCT(3)=-0.009990010
COEFCT(4)=-0.013597514
RETURN
C
C G - G INTERACTION
C
70 NINTS=5
KVALUE(1)=0
KVALUE(2)=2
KVALUE(3)=4
KVALUE(4)=6
KVALUE(5)=8
COEFCT(1)=-0.055555556
COEFCT(2)=-0.014430014
COEFCT(3)=-0.008991009
COEFCT(4)=-0.007770008
COEFCT(5)=-0.011197952
RETURN
C
C --- IF ANGULAR MOMENTUM VALUES ARE TOO LARGE -----
C
3 WRITE(IWRITE,6) L,LP
6 FORMAT(//47H THE ORBITAL ANGULAR MOMENTUM VALUES, WHICH ARE,2I5,5X
1,39H ARE TOO LARGE FOR THE CODING OF INTACT//)
CALL EXIT
END
c
c-------------------------------------------------------------------
c u s e e a v
c-------------------------------------------------------------------
c
SUBROUTINE USEEAV(IRHO,ISIG)
long IAJCMP
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
common/enav/coefct(5),nints,kvalue(5)
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
common/states/ncfg,noccsh(30),nocorb(5,30),nelcsh(5,30),
1 j1qnrd(9,3,30),maxorb,njcomp(21),ljcomp(21),iajcmp(21)
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
C
C DETERMINE THE INTERACTION ENERGY
C
N1=NOSH1(IRHO)
N2=NOSH2(ISIG)
jrho=ijful(irho)
jsig=ijful(isig)
M1=ISIG-IRHO
IZERO=0
ZERO=0.0
IF(M1.EQ.0) GO TO 1
IEQUIV=2
AC2=FLOAT(N1*N2)
GO TO 2
1 IEQUIV=1
AC2=FLOAT(N1*(N1-1)/2)
2 LA=LJ(IRHO)
LB=LJ(ISIG)
CALL INTACT(LA,LB,IEQUIV)
IF(IBUG1-1) 3,4,7
3 RETURN
C
C PRINT OUT RESULTS AS IN SUBROUTINE PRNTWT
C
7 write(iwrite,10) iajcmp(jrho),iajcmp(jsig),iajcmp(jrho),
1 iajcmp(jsig)
4 if(ibug2.gt.1.and.ibug4.eq.0) write(iwrite,5)
IBUG2=IBUG1
write(iwrite,6) ac2,ac2,zero,izero,iajcmp(jrho),iajcmp(jsig)
WRITE(IWRITE,6) IZERO,AC2,AC2,ZERO,IRHO,ISIG
IF(NINTS.EQ.0) RETURN
DO 8 N=1,NINTS
ZA=AC2*COEFCT(N)
K=KVALUE(N)
IF(IEQUIV.EQ.1) GO TO 9
write(iwrite,11) za,za,zero,k,iajcmp(jrho),iajcmp(jsig)
GO TO 8
9 write(iwrite,6) za,za,zero,k,iajcmp(jrho),iajcmp(jsig)
8 CONTINUE
5 format(//30x,33h COEFFICIENTS OF SLATER INTEGRALS//16x,17h TOTAL E
1NERGY(ET),4x,19hAVERAGE ENERGY(EAV),6x,10h(ET - EAV),9x,16hTYPE OF
2 INTEGRAL/)
6 format(12x,f18.8,2f21.8,11x,1hF,i1,1h(,a3,1h,,a3,1h))
10 format(//23h INTERACTING SHELLS ARE,6x,6h RHO =,a3,6x,6h SIG =,a3,
1 6x,7h RHOP =,a3,6x,7h SIGP =,a3//)
11 format(12x,f18.8,2f21.8,11x,1hG,i1,1h(,a3,1h,,a3,1h))
RETURN
END
c
c-----------------------------------------------------------------------
c c h o p
c-----------------------------------------------------------------------
c
SUBROUTINE CHOP
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
COMMON/REMOVE/ICHOP(10)
common/diagnl/idiag,ja,jb
C
C --- ZEROIZE THE OUTPUT ARRAY
C
DO 1 I=1,IHSH
ICHOP(I)=0
1 CONTINUE
C
C NO AVERAGE ENERGY TERMS FOR OFF-DIAGONAL MATRIX ELEMENTS
C
IF(IDIAG.EQ.0) RETURN
JSTO=0
ICOUNT=0
DO 3 J=1,IHSH
NFULL=4*LJ(J)+2
I2=NOSH1(J)
C
C IS THE SHELL FULL OR EMPTY
C
IF(I2.EQ.NFULL.OR.I2.EQ.0) GO TO 4
C
C IF NOT, DOES IT CONTAIN ONLY ONE ELECTRON, OR ONLY ONE =HOLE=
C
IF(I2.EQ.1.OR.I2.EQ.(NFULL-1)) JSTO=J
GO TO 3
4 ICOUNT=ICOUNT+1
C
C ICHOP SET UNITY FOR CLOSED SHELLS
C
ICHOP(J)=1
3 CONTINUE
C
C IF ALL BUT ONE SHELL IS CLOSED, AND THIS CONTAINS ONE ELECTRON OR
C =HOLE= , THEN IT CAN BE TREATED PURELY BY AVERAGE ENERGY
C
IF(ICOUNT.NE.(IHSH-1).OR.JSTO.EQ.0) RETURN
ICHOP(JSTO)=1
RETURN
END
c
c----------------------------------------------------------------------
c r e d u c e
c----------------------------------------------------------------------
c
SUBROUTINE REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
DIMENSION LEAVE(10)
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 j1qn2(19,3),ijful(10)
C
C THIS SUBROUTINE REMOVES SPECTATOR SINGLET S SHELLS WHICH HAVE
C NO EFFECT IN ANGULAR OR SPIN INTEGRALS
C
C LMIN INITIALLY SET LARGE
C
LMIN=99
ICOUNT=0
DO 1 I=1,IHSH
C
C NO INTERACTING SHELL MAY BE REMOVED
C
IF(I.EQ.IRHO.OR.I.EQ.ISIG.OR.I.EQ.IRHOP.OR.I.EQ.ISIGP) GO TO 2
C
C IF A SPECTATOR SHELL HAS SINGLET S COUPLING ON BOTH SIDES OF
C THE MATRIX ELEMENT, IT MAY, IN GENERAL, BE REMOVED, AS IT HAS NO
C EFFECT IN FANO
C
IF(J1QN1(I,1).EQ.0.AND.J1QN2(I,1).EQ.0) GO TO 7
2 ICOUNT=ICOUNT+1
LEAVE(ICOUNT)=I
GO TO 1
7 IF(LJ(I).GE.LMIN) GO TO 1
LMIN=LJ(I)
ILMIN=I
1 CONTINUE
IF(ICOUNT.EQ.IHSH) GO TO 8
C
C IF A CHANGE IN THE COMMON BLOCK MEDEFN IS TO BE MADE,
C ITS PRESENT SITUATION MUST BE PRESERVED BY A CALL OF MEKEEP
C
CALL MEKEEP(IRHO,ISIG,IRHOP,ISIGP)
C
C IF ONLY ONE SHELL WOULD BE LEFT IN THIS WAY, THE ONE, DESTINED
C FOR REMOVAL, WITH THE LOWEST L-VALUE MUST BE RETAINED TO DEFINE A
C COUPLING
C
IF(ICOUNT.EQ.1) GO TO 10
C
C --- MODIFY THE COMMON BLOCK MEDEFN
C
continue
DO 3 I=1,ICOUNT
J=LEAVE(I)
IF(J.EQ.IRHO) IRHO=I
IF(J.EQ.ISIG) ISIG=I
IF(J.EQ.IRHOP) IRHOP=I
IF(J.EQ.ISIGP) ISIGP=I
NJ(I)=NJ(J)
LJ(I)=LJ(J)
NOSH1(I)=NOSH1(J)
NOSH2(I)=NOSH2(J)
DO 4 K=1,3
J1QN1(I,K)=J1QN1(J,K)
J1QN2(I,K)=J1QN2(J,K)
4 CONTINUE
3 CONTINUE
ISUBH=IHSH-1
DO 5 I=2,ICOUNT
J=LEAVE(I)
II=ICOUNT+I-1
IJ=ISUBH+J
DO 6 K=1,3
J1QN1(II,K)=J1QN1(IJ,K)
J1QN2(II,K)=J1QN2(IJ,K)
6 CONTINUE
5 CONTINUE
IHSH=ICOUNT
GO TO 9
C
C THIS SITUATION ONLY OCCURS IF IRHO=ISIG=IRHOP=ISIGP
C
10 J=LEAVE(1)
IRHO = 2
ISIG = 2
IRHOP = 2
ISIGP = 2
WRITE(IWRITE,35)
WRITE(IWRITE,40) ((J1QN1(J,K),K=1,3),J=1,I2HSH)
WRITE(IWRITE,36)
WRITE(IWRITE,40) ((J1QN2(J,K),K=1,3),J=1,I2HSH)
35 FORMAT(/35H NEW DEFINITION OF COUPLING SCHEMES/38H FOR THIS SET OF
1 RHO, SIG, RHOP, SIGP//10X,48H L.H.S. OF HAMILTONIAN MATRIX ELEME
2NT DEFINED BY)
36 FORMAT(10X,48H R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY)
40 FORMAT(10X,6H J1QN ,9(I5,2I3))
C
C LESSEN = 0 IF NO CHANGE IN MEDEFN
C = 1 OTHERWISE
C
9 LESSEN=1
RETURN
8 LESSEN=0
RETURN
END
c
c------------------------------------------------------------------------
c m e k e e p
c------------------------------------------------------------------------
c
SUBROUTINE MEKEEP(IRHO,ISIG,IRHOP,ISIGP)
COMMON/MEDEFN/J(165)
COMMON/STORE/I(165),I1,I2,I3,I4
C
C STORES THE COMMON BLOCK MEDEFN , AND IRHO,ISIG,IRHOP,ISIGP
C
DO 1 K=1,155
I(K)=J(K)
1 CONTINUE
I1=IRHO
I2=ISIG
I3=IRHOP
I4=ISIGP
RETURN
END
c
c-------------------------------------------------------------------
c m e r e s t
c-------------------------------------------------------------------
c
SUBROUTINE MEREST(IRHO,ISIG,IRHOP,ISIGP)
COMMON/MEDEFN/J(165)
COMMON/STORE/I(165),I1,I2,I3,I4
C
C RESTORES THE COMMON BLOCK MEDEFN, AND IRHO,ISIG,IRHOP,ISIGP
C
DO 1 K=1,155
J(K)=I(K)
1 CONTINUE
IRHO=I1
ISIG=I2
IRHOP=I3
ISIGP=I4
RETURN
END
c
c----------------------------------------------------------------------
c h o w t s
c----------------------------------------------------------------------
c
SUBROUTINE H0WTS(ISIG,ISIGP,TIMES,ICAL)
C
DIMENSION L6(40),L7(80),L8(40),LW(6,20)
COMMON/CONST/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
COMMON/COUPLE/NJ1S,NJ23S,J1(40),J2(12,3),J3(12,3)
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/HOLD/J2STO(33),J3STO(33),J2ANG(36),J3ANG(36)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 J1QN2(19,3),IJFUL(10)
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
303 FORMAT(7H ISIG =,I3,8H ISIGP =,I3)
306 FORMAT(5H J1 =,I8,36I3)
307 FORMAT(3H J2,18X,2HJ3)
308 FORMAT(3I5,I10,2I5)
309 FORMAT(8H TIMES =,F10.6,8H RECUP =,F10.6)
310 FORMAT(8H TIMES =,F10.6,8H IDELP =,I3)
C
C --- OFF-DIAGONAL ONE-ELECTRON HAMILTONIAN MATRIX ELEMENT
C
ICAL=0
CALL SETM
ICOUNT=0
C
C TEST THAT FINAL ANGULAR MOMENTA ARE EQUAL
C
DO 8 K=2,3
IF(J1QN1(M6,K).NE.J1QN2(M6,K)) GO TO 7
8 CONTINUE
C
C --- DETERMINE INTERACTING SHELLS, ISIG ON L.H.S., ISIGP ON R.H.S.,
C FOR NON-ZERO ONE-ELECTRON MATRIX ELEMENT, N-1 ELECTRONS MUST BE
C COMMON TO BOTH SIDES. THUS THE SUM OF N(I) = NOSH1(I)-NOSH2(I),
C I=1,IHSH MUST BE EQUAL TO 0 OR 2 . THUS AT NO STAGE CAN
C N(I) BE GREATER THAN 1 . IF THIS SUM IS ZERO, THE TWO
C CONFIGURATIONS ARE MADE UP FROM THE SAME ELECTRONS, WITH TWO
C DIFFERENT COUPLING SCHEMES. SINCE THE SPHERICAL HARMONICS ARE
C EIGENFUNCTIONS OF DEL**2 , THE ORTHOGONALITY OF THE TWO COUPLING
C SCHEMES WILL BE MAINTAINED AND ORTHOGONALITY GIVES A ZERO RESULT.
C
DO 9 I=1,IHSH
N=NOSH1(I)-NOSH2(I)
IF(IABS(N).GT.1) GO TO 7
IF(N) 11,9,12
11 ISIGP=I
GO TO 13
12 ISIG=I
13 ICOUNT=ICOUNT+1
9 CONTINUE
IF(ICOUNT.NE.2) GO TO 7
IF(IBUG4.LT.2) GO TO 92
WRITE(IWRITE,303) ISIG,ISIGP
92 LSIG=LJ(ISIG)
LSIGP=LJ(ISIGP)
C
C THE ANGULAR MOMENTUM OF THE INTERACTING ELECTRONS MUST BE EQUAL
C
IF(LSIG-LSIGP) 7,93,7
C
C THE SPECTATOR SHELLS MUST HAVE MATCHING QUANTUM NUMBERS
C
93 DO 16 J=1,IHSH
IF(J.EQ.ISIG.OR.J.EQ.ISIGP) GO TO 16
DO 19 K=1,3
IF(J1QN1(J,K).NE.J1QN2(J,K)) GO TO 7
19 CONTINUE
16 CONTINUE
C
C --- TEST ON TRIANGULAR CONDITIONS
C
IN3=2*LSIG
DO 20 K=2,3
IN1=J1QN1(ISIG,K)
IN2=J1QN2(ISIG,K)
IN4=J1QN1(ISIGP,K)
IN5=J1QN2(ISIGP,K)
IF(IN1.GT.(IN2+IN3).OR.IN1.LT.IABS(IN2-IN3)) GO TO 7
IF(IN4.GT.(IN5+IN3).OR.IN4.LT.IABS(IN5-IN3)) GO TO 7
IN3=1
20 CONTINUE
C
C --- CALCULATE FRACTIONAL PARENTAGE COEFFICIENTS
C
TIMES=ONE
IF(LSIG.EQ.0) GO TO 26
N=NOSH1(ISIG)
IVI=J1QN1(ISIG,1)
ILI=(J1QN1(ISIG,2)-1)/2
ISI=J1QN1(ISIG,3)
IVJ=J1QN2(ISIG,1)
ILJ=(J1QN2(ISIG,2)-1)/2
ISJ=J1QN2(ISIG,3)
CALL CFP(LSIG,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
TIMES=TIMES*COEFP
IF(ABS(TIMES).LT.EPS) GO TO 7
N=NOSH2(ISIGP)
IVI=J1QN2(ISIGP,1)
ILI=(J1QN2(ISIGP,2)-1)/2
ISI=J1QN2(ISIGP,3)
IVJ=J1QN1(ISIGP,1)
ILJ=(J1QN1(ISIGP,2)-1)/2
ISJ=J1QN1(ISIGP,3)
CALL CFP(LSIG,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
TIMES=TIMES*COEFP
IF(ABS(TIMES).LT.EPS) GO TO 7
C
C --- SET UP J2 AND J3 ARRAYS
C
26 M1=IHSH-2
M2=M6-2
J2(1,1)=ISIG
J2(1,2)=M11
J2(1,3)=M9
J3(1,1)=ISIGP
J3(1,2)=M11
J3(1,3)=M10
IF(ISIG.EQ.1) GO TO 29
J2(2,1)=1
GO TO 30
29 J2(2,1)=M9
30 IF(ISIG.EQ.2) GO TO 32
J2(2,2)=2
GO TO 33
32 J2(2,2)=M9
33 J2(2,3)=M4
IF(ISIGP.EQ.1) GO TO 35
J3(2,1)=1
GO TO 36
35 J3(2,1)=M10
36 IF(ISIGP.EQ.2) GO TO 38
J3(2,2)=2
GO TO 39
38 J3(2,2)=M10
39 J3(2,3)=M7
IF(IHSH.LT.3) GO TO 40
DO 42 J=3,IHSH
J2(J,1)=M1+J
J2(J,3)=M1+J+1
J3(J,1)=M2+J
IF(J.EQ.IHSH) GO TO 44
J3(J,3)=M2+J+1
GO TO 45
44 J3(J,3)=M1+J+1
45 IF(J.EQ.ISIG) GO TO 47
J2(J,2)=J
GO TO 48
47 J2(J,2)=M9
48 IF(J.EQ.ISIGP) GO TO 50
J3(J,2)=J
GO TO 42
50 J3(J,2)=M10
42 CONTINUE
C
C --- STORE J2 AND J3 ARRAYS FOR USE IN SPIN RECOUPLING COEFFICIENT
C
40 I1=0
DO 51 J=1,IHSH
DO 52 K=1,3
I1=I1+1
J2STO(I1)=J2(J,K)
J3STO(I1)=J3(J,K)
52 CONTINUE
51 CONTINUE
C
C --- ORBITAL RECOUPLING COEFFICIENT
C
J1(M11)=LSIG+LSIG+1
K=2
C
C --- SET J1 ARRAY
C
64 DO 53 J=1,IHSH
IF(ISIG.EQ.J) GO TO 55
J1(J)=J1QN1(J,K)
GO TO 53
55 J1(J)=J1QN2(ISIG,K)
53 CONTINUE
DO 56 J=M4,M6
J1(J)=J1QN1(J,K)
56 CONTINUE
DO 57 J=M7,M8
J1(J)=J1QN2(J-M3,K)
57 CONTINUE
J1(M9)=J1QN1(ISIG,K)
J1(M10)=J1QN2(ISIGP,K)
NJ1S=M11
NJ23S=M4
IF(IBUG4.LT.2.OR.IBUG3.EQ.1) GO TO 77
WRITE(IWRITE,306) (J1(J),J=1,M11)
WRITE(IWRITE,307)
DO 80 J=1,IHSH
WRITE(IWRITE,308) (J2(J,KL),KL=1,3),(J3(J,KL),KL=1,3)
80 CONTINUE
C
C --- CALCULATE RECOUPLING COEFFICIENT
C
77 CALL NJSYM(L6C,L7C,L8C,LWC,L6,L7,L8,LW,RECUP)
TIMES=TIMES*RECUP
IF(IBUG4.LT.2) GO TO 58
WRITE(IWRITE,309) TIMES,RECUP
58 IF(ABS(TIMES).LT.EPS) GO TO 7
C
C --- SPIN RECOUPLING COEFFICIENT
C
IF(K.EQ.3) GO TO 60
J1(M11 )=2
K=3
I1=0
DO 62 J=1,IHSH
DO 63 KK=1,3
I1=I1+1
J2(J,KK)=J2STO(I1)
J3(J,KK)=J3STO(I1)
63 CONTINUE
62 CONTINUE
GO TO 64
C
C --- INCLUDE MULTIPLICATIVE FACTORS
C
60 IDELP=0
IF(ISIG-ISIGP) 65,70,66
65 JSIG=ISIG+1
DO 67 J=JSIG,ISIGP
IDELP=IDELP+NOSH1(J)
67 CONTINUE
GO TO 70
66 JSIGP=ISIGP+1
DO 68 J=JSIGP,ISIG
IDELP=IDELP+NOSH2(J)
68 CONTINUE
70 TIMES=TIMES*(-ONE)**IDELP*SQRT(FLOAT(NOSH1(ISIG)*NOSH2(ISIGP)))
ICAL=1
IF(IBUG4.LT.2) GO TO 7
WRITE(IWRITE,310) TIMES,IDELP
7 RETURN
END
c
c----------------------------------------------------------------------
c s e t m
c----------------------------------------------------------------------
c
SUBROUTINE SETM
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 J1QN2(19,3),IJFUL(10)
COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15,
1 M16,M17,M18,M19,M20
C
C --- SET CONSTANTS USEFUL IN INNER SUBROUTINES
C
M3=IHSH-1
M4=IHSH+1
M5=IHSH+2
M6=2*IHSH-1
M7=M6+1
M8=M3+M6
M9=M8+1
M10=M8+2
M11=M8+3
M12=M8+4
M13=M8+5
M14=M8+6
M15=M8+7
M16=M8+8
M17=M8+9
M18=IHSH+3
RETURN
END
c
c-----------------------------------------------------------------------
c d h o
c-----------------------------------------------------------------------
c
SUBROUTINE DH0
long IAJCMP
COMMON/CONST/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 J1QN2(19,3),IJFUL(10)
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 J1QNRD(9,3,30),MAXORB,NJCOMP(21),LJCOMP(21),IAJCMP(21)
300 FORMAT(/35X,34H COEFFICIENTS OF VARIOUS INTEGRALS//16X,17H TOTAL E
1NERGY(ET),4X,19HAVERAGE ENERGY(EAV),6X,10H(ET - EAV),9X,16HTYPE OF
2 INTEGRAL/)
311 FORMAT(12X,F18.8,2F21.8,11X,3HI (,A3,1H,,A3,1H))
IF(IBUG4.NE.0) WRITE(IWRITE,300)
DO 302 J=1,IHSH
IF(NOSH1(J).EQ.0) GO TO 302
JSIG=IJFUL(J)
X=NOSH1(J)
WRITE(IWRITE,311) X,X,ZERO,IAJCMP(JSIG),IAJCMP(JSIG)
302 CONTINUE
RETURN
END
c
c-----------------------------------------------------------------------
c o d h o
c-----------------------------------------------------------------------
c
SUBROUTINE ODH0(ISIG,ISIGP,Y,ICAL)
long IAJCMP
COMMON/COMCHF/LOCATE(21)
COMMON/CONST/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/DIAGNL/IDIAG,JA,JB
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1 J1QN2(19,3),IJFUL(10)
COMMON/PUNCH1/YL(100),NL,JL1(100),JL2(100)
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 J1QNRD(9,3,30),MAXORB,NJCOMP(21),LJCOMP(21),IAJCMP(21)
300 FORMAT(/35X,34H COEFFICIENTS OF VARIOUS INTEGRALS//16X,17H TOTAL E
1NERGY(ET),4X,19HAVERAGE ENERGY(EAV),6X,10H(ET - EAV),9X,16HTYPE OF
2 INTEGRAL/)
311 FORMAT(12X,F18.8,2F21.8,11X,3HI (,A3,1H,,A3,1H))
IF(IBUG4.NE.0) WRITE(IWRITE,300)
IF(ICAL.EQ.0) RETURN
JSIG=IJFUL(ISIG)
JSIGP=IJFUL(ISIGP)
WRITE(IWRITE,311) Y,ZERO,Y,IAJCMP(JSIG),IAJCMP(JSIGP)
IF(IPUNCH.EQ.0) RETURN
KSIG=LOCATE(JSIG)
KSIGP=LOCATE(JSIGP)
NL=NL+1
YL(NL)=-Y
JL1(NL)=100*KSIG+JA
JL2(NL)=100*KSIGP+JB
RETURN
END
c
c---------------------------------------------------------------------
c c f g t s t
c---------------------------------------------------------------------
c
SUBROUTINE CFGTST
C
C THIS SUBROUTINE CHECKS ALL THE CONFIGURATION SET TO ENSURE THAT
C IT SATISFIES
C (1) THE SUBSHELLS ARE IN THE CORRECT ORDER
C (2) NO SUBSHELL HAS TOO MANY (.GT.2*(2*L+1)) ELECTRONS
C (3) THE ELECTRONS IN ANY ONE SUBSHELL ARE COUPLED TO FORM AN
C ALLOWED TRIAD OF QUANTUM NUMBERS
C (4) THE TRIADS COUPLE TOGETHER IN AN ALLOWED WAY
C
C IN THE EVENT OF AN ERROR, THE PROGRAM HALTS AT THE COMPLETION
C OF THE CHECKING. ANY NUMBER OF S, P, D ELECTRONS ARE ALLOWED,
C (BUT .LE.2*(2*L+1)), BUT ONLY UP TO TWO F OR G ELECTRONS.
C NO ELECTRONS FOR L.GT.4 ARE ALLOWED
C
long IAJCMP
common/dummy/itaba(2),jtaba(2),ntaba(48)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/STATES/NCFG,NOCCSH(30),NOCORB(5,30),NELCSH(5,30),
1 J1QNRD(9,3,30),MAXORB,NJCOMP(21),LJCOMP(21),IAJCMP(21)
COMMON/TERMS/NROWS,ITAB(12),JTAB(12),NTAB(171)
DATA ITABA(1),ITABA(2)/7,9/
DATA JTABA(1),JTABA(2)/0,21/
DATA NTABA(1),NTABA(2),NTABA(3),NTABA(4),NTABA(5),NTABA(6),
1 NTABA(7),NTABA(8),NTABA(9),NTABA(10),NTABA(11),NTABA(12),
2 NTABA(13),NTABA(14),NTABA(15),NTABA(16),NTABA(17),NTABA(18),
3 NTABA(19),NTABA(20),NTABA(21),NTABA(22),NTABA(23),NTABA(24),
4 NTABA(25),NTABA(26),NTABA(27),NTABA(28),NTABA(29),NTABA(30),
5 NTABA(31),NTABA(32),NTABA(33),NTABA(34),NTABA(35),NTABA(36),
6 NTABA(37),NTABA(38),NTABA(39),NTABA(40),NTABA(41),NTABA(42),
7 NTABA(43),NTABA(44),NTABA(45),NTABA(46),NTABA(47),NTABA(48)/
8 2,3,3,2,7,3,2,11,3,0,1,1,2,5,1,2,9,1,2,13,1,
9 2,3,3,2,7,3,2,11,3,2,15,3,0,1,1,2,5,1,2,9,1,2,13,1,2,17,1/
5 FORMAT(/38H THE TRIAD OF QUANTUM NUMBERS OF SHELL,I3,17H IN CONFIG
1URATION,I3,24H IS NOT A RECOGNIZED SET)
7 FORMAT(/23H THE INCLUSION OF SHELL,I3,17H IN CONFIGURATION,I3,
1 38h RESULTS IN AN ILLEGAL COUPLING SCHEME)
9 FORMAT(/28H THE SHELLS IN CONFIGURATION,I3,24H ARE INCORRECTLY ORD
1ERED)
12 FORMAT(//41H CONFIGURATION DATA WRONG, PROGRAM HALTED//)
15 FORMAT(/17H IN CONFIGURATION,I3,7H, SHELL,I3,28H CONTAINS TOO MANY
1 ELECTRONS)
17 FORMAT(/14H CONFIGURATION,I3,81H INCLUDES A SHELL OF ANGULAR MOMEN
1TUM GREATER THAN 2 WITH MORE THAN TWO ELECTRONS)
C
IALLOW=1
DO 1 I=1,NCFG
N=NOCCSH(I)
DO 2 J=1,N
NA=NOCORB(J,I)
IF(J.EQ.1) GO TO 3
C
C CHECK THE ORDERING OF THE SUBSHELLS
C
IF(NA.GT.NB) GO TO 3
WRITE(IWRITE,9) I
IALLOW=0
3 NB=NA
LQU=LJCOMP(NA)
NC=NELCSH(J,I)
C
C CHECK THAT THERE ARE NO MORE THAN TWO F OR G ELECTRONS
C
IF(LQU.GT.2.AND.NC.GT.2) GO TO 16
C
C CHECK THAT THERE ARE NOT TOO MANY ELECTRONS IN EACH SUBSHELL
C
NQUMAX=4*LQU+2
IF(NC.GT.NQUMAX) GO TO 8
C
C CHECK THAT THE ELECTRONS IN EACH SUBSHELL ARE COUPLED TO
C ALLOWED TRIADS
C
JA=J1QNRD(J,1,I)
JB=J1QNRD(J,2,I)
JC=J1QNRD(J,3,I)
NROW=NTAB2(NC,LQU+1)
IF(NROW.EQ.0) GO TO 19
I1=ITAB(NROW)
I2=JTAB(NROW)
DO 4 IA=1,I1
I3=I2+3*IA-1
IF(JB.NE.NTAB(I3)) GO TO 4
I3=I3+1
IF(JC.NE.NTAB(I3)) GO TO 4
I3=I3-2
IF(JA.EQ.NTAB(I3)) GO TO 13
4 CONTINUE
14 WRITE(IWRITE,5) J,I
IALLOW=0
GO TO 13
C
C TWO ELECTRONS IN AN F- OR G-SHELL
C
19 I4=LQU-2
I1=ITABA(I4)
I2=JTABA(I4)
DO 20 IA=1,I1
I3=I2+3*IA-1
IF(JB.NE.NTABA(I3)) GO TO 20
I3=I3+1
IF(JC.NE.NTABA(I3)) GO TO 20
I3=I3-2
IF(JA.EQ.NTABA(I3)) GO TO 13
20 CONTINUE
GO TO 14
13 IF(J.EQ.1) GO TO 2
C
C CHECK ON COUPLING ON OF THIS TRIAD
C
J2=N+J-1
IF(J.EQ.2) GO TO 10
J1=J2-1
GO TO 11
10 J1=1
11 JD=J1QNRD(J1,2,I)
JE=J1QNRD(J1,3,I)
JF=J1QNRD(J2,2,I)
JG=J1QNRD(J2,3,I)
IF(JF.GT.(JB+JD).OR.JF.LT.IABS(JB-JD)) GO TO 6
IF(JG.GT.(JC+JE).OR.JG.LT.IABS(JC-JE)) GO TO 6
GO TO 2
16 WRITE(IWRITE,17) I
IALLOW=0
GO TO 13
8 WRITE(IWRITE,15) I,J
IALLOW=0
GO TO 13
6 WRITE(IWRITE,7) J,I
IALLOW=0
2 CONTINUE
1 CONTINUE
IF(IALLOW.EQ.1) RETURN
WRITE(IWRITE,12)
CALL EXIT
END
c
c----------------------------------------------------------------------
c n t a b s 2
c----------------------------------------------------------------------
c
FUNCTION NTAB2(NELCTS,K)
C
C THIS FUNCTION GIVES THE ROW OF NTAB FOR TERMS FORMED FROM
C (K-1)**NELCTS
C IF THERE IS MORE THAN ONE ELECTRON IN AN F OR G SHELL, THE VALUE
C OF THE FUNCTION IS ZERO
C
COMMON/INFORM/IREAD,IWRITE,IPUNCH
10 FORMAT(30H THE ANGULAR MOMENTUM VALUE IS,I3,45H WHICH IS LARGER TH
1AN THIS CODE CAN DEAL WITH//24H PROGRAM HALTED IN NTAB2///)
IF(K.LE.5) GO TO 1
K1=K-1
WRITE(IWRITE,10) K1
CALL EXIT
1 IF(NELCTS.GT.0) GO TO 2
8 NTAB2=2
RETURN
2 GO TO (3,4,5,6,7),K
C
C S ELECTRONS
C
3 NTAB2=NELCTS
RETURN
C
C P ELECTRONS
C
4 IF(NELCTS.GT.3) NELCTS=6-NELCTS
IF(NELCTS.EQ.0) GO TO 8
NTAB2=NELCTS+2
RETURN
C
C D ELECTRONS
C
5 IF(NELCTS.GT.5) NELCTS=10-NELCTS
IF(NELCTS.EQ.0) GO TO 8
NTAB2=NELCTS+5
RETURN
C
C F ELECTRONS
C
6 IF(NELCTS.GT.1) GO TO 9
IF(NELCTS.EQ.0) GO TO 8
NTAB2=11
RETURN
C
C G ELECTRONS
C
7 IF(NELCTS.GT.1) GO TO 9
IF(NELCTS.EQ.0) GO TO 8
NTAB2=12
RETURN
9 NTAB2=0
return
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,KFL7
COMMON/INFORM/IREAD,IWRITE,IPUNCH
COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
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)
1208 FORMAT(23H KFL7 DIMENSION FAILURE)
C
C SET DIMENSIONVARIABLES AND TEST SOME OF DIMENSIONS
C
IF(KFL2-12) 200,201,200
200 KFL2=12
KFL3=20
KFL4=40
KFL5=80
KFL6=12
KFL7=40
C
C
201 IF(KFL2-N+1) 202,203,203
202 WRITE(IWRITE,204)
CALL EXIT
203 IF(KFL7-M)205,206,206
205 WRITE(IWRITE,1208)
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=ZERO
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(KFL7-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,KFL7
COMMON/INFORM/IREAD,IWRITE,IPUNCH
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
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=ONE
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=ONE
STOR=ZERO
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
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(I1) + 1
125 CONTINUE
123 IX2 = 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=ONE
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 IX2 = IASTOR/2
IF (MOD(IX2,2) .EQ. 1) RECUP = -RECUP
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
DIMENSION KC(11),NA(31),MC(23),NC(7),NB(31)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
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=ZERO
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=ONE
DAX=ONE
DNR=ONE
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
c
c------------------------------------------------------------------------
c c f p p
c-------------------------------------------------------------------------
c
SUBROUTINE CFPP(N,LI,ISI,LJ,ISJ,COEFP)
C
C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
C FOR EQUIVALENT P SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER
C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960)
C IN THE SUBROUTINE LIST N,THE NO. OF ELECTRONS,L THE ANGULAR
C MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM NO. OF BOTH THE STATE
C IN QUESTION AND ITS PARENT STATE ARE INPUT PARAMETERS.THE RESULT
C IS OUTPUT AS COEFP
C
integer IL(3,3),IS(3,3),ITAB1(3,1),ITAB2(3,3),NORM1(3),NORM2(3)
common/inform/iread,iwrite,ipunch
C
C
C SET UP P SHELL PARAMETERS AND TABLES
C
il(1,1)=1
il(2,1)=1
il(2,2)=2
il(2,3)=0
il(3,1)=0
il(3,2)=2
il(3,3)=1
is(1,1)=2
is(2,1)=3
is(2,2)=1
is(2,3)=1
is(3,1)=4
is(3,2)=2
is(3,3)=2
itab1(1,1)=1
itab1(2,1)=1
itab1(3,1)=1
itab2(1,1)=1
itab2(1,2)=0
itab2(1,3)=0
itab2(2,1)=1
itab2(2,2)=-1
itab2(2,3)=0
itab2(3,1)=-9
itab2(3,2)=-5
itab2(3,3)=4
norm1(1)=1
norm1(2)=1
norm1(3)=1
norm2(1)=1
norm2(2)=2
norm2(3)=18
C
C TEST IF N IS IN THE FIRST HALF OF SHELL
C
IF(N-4) 40,103,103
C
C TEST IF STATE IN QUESTION IS ALLOWED
C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1
C
40 J = 0
101 J = J+1
IF(J-4) 41,8,8
41 IF(IL(N,J)-LI) 101,42,101
42 IF(IS(N,J)-ISI) 101,43,101
43 J1 = J
C
C TEST IF PARENT STATE IS ALLOWED
C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2
C
IF(N-1) 44,70,44
70 IF(LJ) 8,71,8
71 IF(ISJ-1) 8,1,8
44 J = 0
102 J = J+1
IF(J-4) 45,8,8
45 IF(IL(N-1,J)-LJ) 102,46,102
46 IF(IS(N-1,J)-ISJ) 102,47,102
47 J2 = J
GO TO 100
C
C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
C
103 M =6-N
IF(M) 72,73,72
73 IF(LI) 8,74,8
74 IF(ISI-1) 8,75,8
72 J = 0
104 J = J+1
IF(J-4) 48,8,8
48 IF(IL(M,J)-LI) 104,49,104
49 IF(IS(M,J)-ISI) 104,50,104
50 J1 = J
75 J = 0
105 J = J+1
IF(J-4) 51,8,8
51 IF(IL(M+1,J)-LJ) 105,52,105
52 IF(IS(M+1,J)-ISJ) 105,53,105
53 J2 = J
C
C
C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
C
100 GO TO (1,2,3,4,4,1),N
1 COEFP = 1.0
GO TO 10
2 COEFP = ITAB1(J1,J2)
IF(COEFP) 54,10,31
54 COEFP = -SQRT(-COEFP/NORM1(J1))
GO TO 10
31 COEFP = SQRT(COEFP/NORM1(J1))
GO TO 10
3 COEFP = ITAB2(J1,J2)
IF(COEFP) 55,10,32
55 COEFP = -SQRT(-COEFP/NORM2(J1))
GO TO 10
32 COEFP =SQRT(COEFP/NORM2(J1))
GO TO 10
C
C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
C SHELL
C
4 ISIGN = (-1)**((ISI+ISJ-5)/2+LI+LJ)
FACTOR = ((7.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0))
IF(N-5) 56,5,8
56 COEFP = ITAB2(J2,J1)
IF(COEFP) 57,10,33
57 COEFP = -SQRT(-COEFP/NORM2(J2))
GO TO 34
33 COEFP = SQRT(COEFP/NORM2(J2))
34 COEFP = COEFP * ISIGN * SQRT(FACTOR)
IF(LJ-1) 35,10,35
35 COEFP = -COEFP
GO TO 10
5 COEFP = ITAB1(J2,J1)
IF(COEFP) 58,10,36
58 COEFP = -SQRT(-COEFP/NORM1(J2))
GO TO 37
36 COEFP = SQRT(COEFP/NORM1(J2))
37 COEFP = COEFP * ISIGN * SQRT(FACTOR)
GO TO 10
C
8 continue
c16 format(37h fail in coefp at 8 unallowed state)
c write(iwrite,16)
coefp=9.9
10 CONTINUE
RETURN
END
c
c------------------------------------------------------------------------
c c f p d d a t a
c-------------------------------------------------------------------------
c
subroutine cfpddata
C
COMMON/FRPAR2/I(719)
C
C BLOCK DATA FOR CFPD SUBROUTINE
C
DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6),I( 7),I( 8),
1 I( 9),I( 10),I( 11),I( 12),I( 13),I( 14),I( 15),I( 16),
1 I( 17),I( 18),I( 19),I( 20),I( 21),I( 22),I( 23),I( 24),
2 I( 25),I( 26),I( 27),I( 28),I( 29),I( 30),I( 31),I( 32),
3 I( 33),I( 34),I( 35),I( 36),I( 37),I( 38),I( 39),I( 40),
4 I( 41),I( 42),I( 43),I( 44),I( 45),I( 46),I( 47),I( 48),
5 I( 49),I( 50),I( 51),I( 52),I( 53),I( 54),I( 55),I( 56),
6 I( 57),I( 58),I( 59),I( 60),I( 61),I( 62),I( 63),I( 64),
7 I( 65),I( 66),I( 67),I( 68),I( 69),I( 70),I( 71),I( 72),
8 I( 73),I( 74),I( 75),I( 76),I( 77),I( 78),I( 79),I( 80)/
1 1, 5, 8, 16, 16, 1, 2, 3,
1 4, 5, 0, 2, 3, 4, 5, 0,
1 2, 3, 4, 3, 0, 2, 3, 2,
2 5, 0, 0, 3, 4, 3, 0, 0,
3 1, 4, 5, 0, 0, 3, 2, 3,
4 0, 0, 3, 4, 3, 0, 0, 0,
5 4, 5, 0, 0, 0, 2, 3, 0,
6 0, 0, 4, 5, 0, 0, 0, 4,
7 1, 0, 0, 0, 2, 3, 0, 0,
8 0, 4, 5, 0, 0, 0, 0, 3/
DATA I( 81),I( 82),I( 83),I( 84),I( 85),I( 86),I( 87),I( 88),
1 I( 89),I( 90),I( 91),I( 92),I( 93),I( 94),I( 95),I( 96),
1 I( 97),I( 98),I( 99),I(100),I(101),I(102),I(103),I(104),
2 I(105),I(106),I(107),I(108),I(109),I(110),I(111),I(112),
3 I(113),I(114),I(115),I(116),I(117),I(118),I(119),I(120),
4 I(121),I(122),I(123),I(124),I(125),I(126),I(127),I(128),
5 I(129),I(130),I(131),I(132),I(133),I(134),I(135),I(136),
6 I(137),I(138),I(139),I(140),I(141),I(142),I(143),I(144),
7 I(145)/
1 0, 0, 0, 4, 5, 2, 3, 3,
1 2, 0, 0, 1, 1, 5, 4, 0,
1 4, 5, 4, 3, 0, 2, 4, 3,
2 2, 0, 0, 3, 3, 1, 0, 0,
3 2, 2, 6, 0, 0, 2, 1, 5,
4 0, 0, 1, 1, 4, 0, 0, 0,
5 6, 4, 0, 0, 0, 4, 3, 0,
6 0, 0, 4, 3, 0, 0, 0, 3,
7 2/
DATA I(146),I(147),I(148),I(149),I(150),I(151),I(152),I(153),
1 I(154),I(155),I(156),I(157),I(158),I(159),I(160),I(161),
1 I(162),I(163),I(164),I(165),I(166),I(167),I(168),I(169),
2 I(170),I(171),I(172),I(173),I(174),I(175),I(176),I(177),
3 I(178),I(179),I(180),I(181),I(182),I(183),I(184),I(185),
4 I(186),I(187),I(188),I(189),I(190),I(191),I(192),I(193),
5 I(194),I(195),I(196),I(197),I(198),I(199),I(200),I(201),
6 I(202),I(203),I(204),I(205),I(206),I(207),I(208),I(209),
7 I(210),I(211),I(212),I(213),I(214),I(215),I(216),I(217),
8 I(218),I(219),I(220),I(221),I(222),I(223),I(224),I(225)/
1 0, 0, 0, 2, 2, 0, 0, 0,
1 2, 2, 0, 0, 0, 0, 1, 0,
1 0, 0, 0, 0, 2, 3, 4, 5,
2 6, 0, 3, 4, 3, 4, 0, 1,
3 2, 3, 4, 0, 1, 2, 3, 4,
4 0, 1, 2, 3, 4, 0, 0, 2,
5 3, 2, 0, 0, 2, 3, 2, 0,
6 0, 2, 3, 2, 0, 0, 0, 1,
7 2, 0, 0, 0, 1, 2, 0, 0,
8 0, 1, 2, 0, 0, 0, 1, 2/
DATA I(226),I(227),I(228),I(229),I(230),I(231),I(232),I(233),
1 I(234),I(235),I(236),I(237),I(238),I(239),I(240),I(241),
1 I(242),I(243),I(244),I(245),I(246),I(247),I(248),I(249),
2 I(250),I(251),I(252),I(253),I(254),I(255),I(256),I(257),
3 I(258),I(259),I(260),I(261),I(262),I(263),I(264),I(265),
4 I(266),I(267),I(268),I(269),I(270),I(271),I(272),I(273),
5 I(274),I(275),I(276),I(277),I(278),I(279),I(280),I(281),
6 I(282),I(283),I(284),I(285),I(286),I(287),I(288),I(289),
7 I(290)/
1 0, 0, 0, 1, 2, 0, 0, 0,
1 1, 2, 0, 0, 0, 1, 2, 0,
1 0, 0, 1, 2, 1, 1, 1, 1,
2 1, 4, -7, -1, 21, 7, -21, 21,
3 -8, -1, -8, 0, 0, 28, -9, -49,
4 7, 0, 0, 1, 11, -25, -9, -25,
5 0, 0, 0, 0, -10, -10, -5, 45,
6 15, 0, 0, 0, 0, 0, 16, 0,
7 0/
DATA I(291),I(292),I(293),I(294),I(295),I(296),I(297),I(298),
1 I(299),I(300),I(301),I(302),I(303),I(304),I(305),I(306),
1 I(307),I(308),I(309),I(310),I(311),I(312),I(313),I(314),
2 I(315),I(316),I(317),I(318),I(319),I(320),I(321),I(322),
3 I(323),I(324),I(325),I(326),I(327),I(328),I(329),I(330),
4 I(331),I(332),I(333),I(334),I(335),I(336),I(337),I(338),
5 I(339),I(340),I(341),I(342),I(343),I(344),I(345),I(346),
6 I(347),I(348),I(349),I(350),I(351),I(352),I(353),I(354),
7 I(355),I(356),I(357),I(358),I(359),I(360),I(361),I(362),
8 I(363),I(364),I(365),I(366),I(367),I(368),I(369),I(370)/
1 7, 20, -560, 224, -112, -21, -56, 16,
1 0, 0, 0, 0, 0, 0, 0, 0,
1 3, 0, 0, -56, -448, 49, -64, -14,
2 0, 0, 0, 0, 0, 0, 0, 0,
3 0, 26, 308, 110, 220, 0, 0, 0,
4 7, -154, -28, -132, 0, 0, 0, 0,
5 0, -9, 297, 90, -405, 45, 0, 0,
6 3, 66, -507, -3, -60, 15, 0, 0,
7 0, 5, 315, -14, -175, -21, -56, -25,
8 0, 70, 385, -105, 28, 63, 0, 0/
DATA I(371),I(372),I(373),I(374),I(375),I(376),I(377),I(378),
1 I(379),I(380),I(381),I(382),I(383),I(384),I(385),I(386),
1 I(387),I(388),I(389),I(390),I(391),I(392),I(393),I(394),
2 I(395),I(396),I(397),I(398),I(399),I(400),I(401),I(402),
3 I(403),I(404),I(405),I(406),I(407),I(408),I(409),I(410),
4 I(411),I(412),I(413),I(414),I(415),I(416),I(417),I(418),
5 I(419),I(420),I(421),I(422),I(423),I(424),I(425),I(426),
6 I(427),I(428),I(429),I(430),I(431),I(432),I(433),I(434),
7 I(435)/
1 0, 0, 0, 315, 0, 0, 135, 0,
1 0, 189, 0, 0, 105, 0, 1, 0,
1 0, 0, 200, 15, 120, 60, -35, 10,
2 0, -25, 88, 200, 45, 20, 0, 1,
3 0, 0, 0, 16, -200, -14, -14, 25,
4 0, 0, 0, 120, -42, 42, 0, 0,
5 1, -105, -175, -175, -75, 0, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 0,
7 0/
DATA I(436),I(437),I(438),I(439),I(440),I(441),I(442),I(443),
1 I(444),I(445),I(446),I(447),I(448),I(449),I(450),I(451),
1 I(452),I(453),I(454),I(455),I(456),I(457),I(458),I(459),
2 I(460),I(461),I(462),I(463),I(464),I(465),I(466),I(467),
3 I(468),I(469),I(470),I(471),I(472),I(473),I(474),I(475),
4 I(476),I(477),I(478),I(479),I(480),I(481),I(482),I(483),
5 I(484),I(485),I(486),I(487),I(488),I(489),I(490),I(491),
6 I(492),I(493),I(494),I(495),I(496),I(497),I(498),I(499),
7 I(500),I(501),I(502),I(503),I(504),I(505),I(506),I(507),
8 I(508),I(509),I(510),I(511),I(512),I(513),I(514),I(515)/
1 154, -110, 0, 0, 231, 286, 924, -308,
1 220, -396, 0, 0, 0, 0, 0, 0,
1 -66, -90, 180, 0, 99, -99, 891,-5577,
2 -405, -9, 0, 45, 45, 0, 0, 0,
3 0, 224, 0, -56, 0, -220, 1680, 0,
4 112, 0, -21, 21, 0, -16, 0, 0,
5 -70, 14, -84, 56, 0, 55, 945, 4235,
6 -175, -315, 0, -21, 189, -25, 0, 0,
7 25, -15, -135, 35, 0, 0, 600, 968,
8 120, 600, 0, 60, 60, 10, 3, 0/
DATA I(516),I(517),I(518),I(519),I(520),I(521),I(522),I(523),
1 I(524),I(525),I(526),I(527),I(528),I(529),I(530),I(531),
1 I(532),I(533),I(534),I(535),I(536),I(537),I(538),I(539),
2 I(540),I(541),I(542),I(543),I(544),I(545),I(546),I(547),
3 I(548),I(549),I(550),I(551),I(552),I(553),I(554),I(555),
4 I(556),I(557),I(558),I(559),I(560),I(561),I(562),I(563),
5 I(564),I(565),I(566),I(567),I(568),I(569),I(570),I(571),
6 I(572),I(573),I(574),I(575),I(576),I(577),I(578),I(579),
7 I(580)/
1 0, -56, 0, -64, 0, 0, 0, 0,
1 448, 0, -9, -49, 0, 14, 0, 0,
1 0, -16, 126, 14, 0, 0, 0, 0,
2 -200, 360, 0, -14, 126, 25, 0, 0,
3 0, 0, 0, 0, -175, 182, -728,-2184,
4 0, 0, 0, 0, 0, 0, 0, 0,
5 0, 0, 0, 0, 0, 220, 880, 0,
6 -400, 0, -9, -25, 0, 0, 0, 0,
7 0/
DATA I(581),I(582),I(583),I(584),I(585),I(586),I(587),I(588),
1 I(589),I(590),I(591),I(592),I(593),I(594),I(595),I(596),
1 I(597),I(598),I(599),I(600),I(601),I(602),I(603),I(604),
2 I(605),I(606),I(607),I(608),I(609),I(610),I(611),I(612),
3 I(613),I(614),I(615),I(616),I(617),I(618),I(619),I(620),
4 I(621),I(622),I(623),I(624),I(625),I(626),I(627),I(628),
5 I(629),I(630),I(631),I(632),I(633),I(634),I(635),I(636),
6 I(637),I(638),I(639),I(640),I(641),I(642),I(643),I(644),
7 I(645),I(646),I(647),I(648),I(649),I(650),I(651),I(652),
8 I(653),I(654),I(655),I(656),I(657),I(658),I(659),I(660)/
1 0, 0, 0, -45, -5, 845,-1215, 275,
1 495, 0, -11, 99, 0, 0, 0, 0,
1 0, 0, 0, 0, 33, -7,-2541, 105,
2 -525, 0, 35, 35, -15, 0, 0, 0,
3 0, 0, 0, 0, 0, -800, 0, -160,
4 0, -5, 45, 0, 30, 0, 0, 0,
5 0, 0, 0, 0, 0, -100, 1452, 180,
6 -100, 0, -10, 90, 15, -2, 0, 0,
7 0, 0, 0, 0, 0, 0, 0, 0,
8 0, 6, 0, 0, 0, 0, 0, 0/
DATA I(661),I(662),I(663),I(664),I(665),I(666),I(667),I(668),
1 I(669),I(670),I(671),I(672),I(673),I(674),I(675),I(676),
1 I(677),I(678),I(679),I(680),I(681),I(682),I(683),I(684),
2 I(685),I(686),I(687),I(688),I(689),I(690),I(691),I(692),
3 I(693),I(694),I(695),I(696),I(697),I(698),I(699),I(700),
4 I(701),I(702),I(703),I(704),I(705),I(706),I(707),I(708),
5 I(709),I(710),I(711),I(712),I(713),I(714),I(715),I(716),
6 I(717),I(718),I(719)/
1 0, 0, 0, 0, 0, 0, 0, 0,
1 0, 0, -14, -56, 0, 0, 1, 1,
1 1, 1, 1, 5, 15, 2, 42, 70,
2 60, 140, 30, 10, 60, 1680, 840, 1680,
3 210, 360, 90, 10, 504, 1008, 560, 280,
4 140, 1, 1, 1, 420, 700, 700, 300,
5 550, 1100, 8400,18480, 2800, 2800, 50, 350,
6 700, 150, 5/
C
return
END
c
c----------------------------------------------------------------------
c cfpd
c-----------------------------------------------------------------------
c
SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP)
C
C
C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
C FOR EQUIVALENT D SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER
C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960)
C IN THE SUBROUTINE LIST N,THE NO.OF ELECTRONS,V THE SENIORITY QUAN
C TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM
C NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT
C PARAMETERS THE RESULT IS OUTPUT AS COEFP
C
COMMON/FRPAR2/K(5),IV(5,16),IL(5,16),IS(5,16),ITAB1(5,1),ITAB2(8,5
1 ),ITAB3(16,8),ITAB4(16,16),NORM1(5),NORM2(8),NORM3(16),NORM4(16)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
C
C
C TEST IF N IS IN THE FIRST HALF OF SHELL
C
IF(N-6) 40,103,103
C
C TEST IF STATE IN QUESTION IS ALLOWED
C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1
C
40 J = 0
101 J = J+1
IF(J-17) 41,11,11
41 IF(IV(N,J)-IVI) 101,42,101
42 IF(IL(N,J)-LI) 101,43,101
43 IF(IS(N,J)-ISI) 101,44,101
44 J1=J
C
C TEST IF PARENT STATE IS ALLOWED
C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2
C
IF(N-1) 45,30,45
30 IF(IVJ) 11,31,11
31 IF(LJ) 11,32,11
32 IF(ISJ-1) 11,1,11
45 J = 0
102 J = J+1
IF(J-17) 46,11,11
46 IF(IV(N-1,J)-IVJ) 102,47,102
47 IF(IL(N-1,J)-LJ) 102,48,102
48 IF(IS(N-1,J)-ISJ) 102,49,102
49 J2=J
GO TO 100
C
C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
C
103 M = 10-N
IF(M) 36,33,36
33 IF(IVI) 11,34,11
34 IF(LI) 11,35,11
35 IF(ISI-1) 11,37,11
36 J = 0
104 J = J+1
IF(J-17) 50,11,11
50 IF(IV(M,J)-IVI) 104,51,104
51 IF(IL(M,J)-LI) 104,52,104
52 IF(IS(M,J)-ISI) 104,53,104
53 J1=J
37 J = 0
105 J = J+1
IF(J-17) 54,11,11
54 IF(IV(M+1,J)-IVJ) 105,55,105
55 IF(IL(M+1,J)-LJ) 105,56,105
56 IF(IS(M+1,J)-ISJ) 105,57,105
57 J2=J
C
C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
C
100 GO TO (1,2,3,4,5,12,12,12,12,1),N
1 COEFP = 1.0
GO TO 10
2 COEFP = ITAB1(J1,J2)
IF(COEFP) 60,10,81
60 COEFP = - SQRT(-COEFP/NORM1(J1))
GO TO 10
81 COEFP = SQRT(COEFP/NORM1(J1))
GO TO 10
3 COEFP = ITAB2(J1,J2)
IF(COEFP) 61,10,82
61 COEFP = -SQRT(-COEFP/NORM2(J1))
GO TO 10
82 COEFP = SQRT(COEFP/NORM2(J1))
GO TO 10
4 COEFP = ITAB3(J1,J2)
IF(COEFP) 62,10,83
62 COEFP = -SQRT(-COEFP/NORM3(J1))
GO TO 10
83 COEFP = SQRT(COEFP/NORM3(J1))
GO TO 10
5 COEFP = ITAB4(J1,J2)
IF(COEFP) 63,10,84
63 COEFP = -SQRT(-COEFP/NORM4(J1))
GO TO 10
84 COEFP = SQRT(COEFP/NORM4(J1))
GO TO 10
C
C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
C SHELL
C
12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ)
FACTOR = SQRT(((11.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0)))
M1 =N-5
GO TO(6,7,8,9),M1
6 COEFP = ITAB4(J2,J1)
IF(COEFP) 64,10,85
64 COEFP = -SQRT(-COEFP/NORM4(J2))
GO TO 86
85 COEFP = SQRT(COEFP/NORM4(J2))
86 COEFP = COEFP*ISIGN*FACTOR
IF(MOD((IVJ-1)/2,2)) 87,10,87
87 COEFP = -COEFP
GO TO 10
7 COEFP = ITAB3(J2,J1)
IF(COEFP) 65,10,88
65 COEFP = -SQRT(-COEFP/NORM3(J2))
GO TO 89
88 COEFP = SQRT(COEFP/NORM3(J2))
89 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
8 COEFP = ITAB2(J2,J1)
IF(COEFP) 66,10,90
66 COEFP = -SQRT(-COEFP/NORM2(J2))
GO TO 91
90 COEFP = SQRT(COEFP/NORM2(J2))
91 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
9 COEFP = ITAB1(J2,J1)
IF(COEFP) 67,10,92
67 COEFP = -SQRT(-COEFP/NORM1(J2))
GO TO 93
92 COEFP = SQRT(COEFP/NORM1(J2))
93 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
C
11 continue
c 106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE)
c 11 WRITE(IWRITE,106)
coefp=9.9
10 CONTINUE
RETURN
END
▶EOF◀