|
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: 95232 (0x17400)
Types: TextFile
Names: »per4«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »per4«
c program 4
c
c acqvweights new version. a new version af a general program
c to calculate angular momentum integrals in atomic structure.
c hibbert, a.
ref. in comp. phys. commun. 2 (1971) 180 and
comp. phys. commun. 6 (1973) 59 and
comp. phys. commun. 7 (1974) 318 and
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 newver external bldata
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)
C
1 FORMAT(4I5)
11 FORMAT(//56H IN THIS CALCULATION, THE NUMBER OF STATES CONSIDERED
1IS,I3,1H,,5X,31HTHE NUMBER OF FACTORIALS SET IS,I3/39H AND THE SIZ
2E 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 ---------------------)
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(400,1,stderror)
zone writef(400,1,stderror)
zone punchf(400,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call zassign(punchf,8)
call open(readf,4,'readfile',0)
call open(writef,4,'writefile',0)
call open(punchf,4,'punchfile',0)
IREAD=1
IWRITE=7
ipunch=8
WRITE(IWRITE,13)
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 IBUG2 IS DEFINED IN PRNTWT
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
READ(IREAD,1) IBUG1,IBUG3,ibug4
WRITE(IWRITE,12) IBUG1,IBUG3,ibug4
IBUG5=0
IBUG6=0
do 11 i=1,10
locate(i)=0
11 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)
1L/40X,22H ---------------------)
C REPLACE CARD 272 BY THE FOLLOWING 11 CARDS
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 program 4
c
c acqvweights new version. a new version af a general program
c to calculate angular momentum integrals in atomic structure.
c hibbert, a.
ref. in comp. phys. commun. 2 (1971) 180 and
comp. phys. commun. 6 (1973) 59 and
comp. phys. commun. 7 (1974) 318 and
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
ibug4 - defines printout from one-electron part cf. ibug1
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
C --- IF NO SUCH ORTHOGONALITY IS EXHIBITED, CALCULATE WEIGHTS OF SLATER
C INTEGRALS
C
8 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 PAUSE
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,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
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
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)
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)
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 continue
C
C --- NO OBVIOUS ANGULAR MOMENTUM ORTHOGONALITY
C
12 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)
1 J1QN2(19,3)
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
70 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
75 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
71 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
76 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
74 IF(ICHOP(K1).EQ.1.OR.ICHOP(K2).EQ.1) GO TO 34
CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN)
call setm
77 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)
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)
162 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)
137 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
53 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
55 I=3
CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP)
269 CALL J23SPN(IRHO,ISIG,IRHOP,ISIGP,JSNDIR)
C
C --- DIRECT SPIN INTEGRAL
C
570 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
87 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
122 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,43H RME SET ZERO SINCE TRI
1angle does not match)
if(k.gt.(l+lp).or.k.lt.iabs(l-lp) go to 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)
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(69H UNNECESSARY ATTEMPT TO FORM CFP OF AN S-ELECTRON - THER
1E 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
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
END
c
c----------------------------------------------------------------------
c p r n t w t
c----------------------------------------------------------------------
c
SUBROUTINE PRNTWT(IRHO,ISIG,IRHOP,ISIGP)
C
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),
1,ijful(10)
common/diagnl/idiag,ja,jb
COMMON/DIAGNL/IDIAG
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),fd1,fd2,fe1,fe2,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)
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/consts/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,
16x,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
13 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 20
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/CONSTS/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
COMMON/CONSTS/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)
COMMON/COMCHF/LOCATE(21)
COMMON/CONSTS/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
DIMENSION 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,38H
1RESULTS 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
▶EOF◀