|
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: 128256 (0x1f500)
Types: TextFile
Names: »cpc8«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »cpc8«
c cpc8
c
c aakp reduced tensor matrix elements 2. a new version af aakf (reduced
c tensor matrix elements) adapted to spectroscopic notation, with
c inclusion of the evaluation of matrix elements of tensor products,
c and checking of the input data. k.m.s. saxena
c ref. in comp. phys. commun. 9 (1975) 370 and
c comp. phys. commun. 13 (1977) 231 and
c comp. phys. commun. 13 (1977) 289 and
c comp. phys. commun. 16 (1978) 57.
c
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * FABUARY 1975 *
C * *
C * A NEW VERSION OF THE PROGRAM (ORIGIONALLY WRITTEN BY ROBB, *
C * W.D.) TO EVALUATE THE REDUCED MATRIX ELEMENTS OF SUMMATIONS *
C * OF ONE-PARTICLE TENSOR OPERATORS. *
C * *
C * *
C * BY *
C * *
C * *
C * C. FROESE FISCHER AND K.M.S. SAXENA *
C * *
C * DEPARTMENT OF APPLIED MATHEMATICS *
C * UNIVERSITY OF WATERLOO, WATERLOO, ONTARIO N2L 3G1 *
C * C A N A D A. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * THE PURPOSE OF THE PRESENT VERSION IS TWO-FOLD. FIRSTLY *
C * THE FORMATS OF THE INPUT-DATA AND THE PRINTED-OUTPUT ARE CHANGED *
C * TO MORE READABLE AND COMPACT SPECTROSCOPIC NOTATION. SECONDLY, IT *
C * MODIFIES THE PUNCHED-OUTPUT FORMATS SO THAT THE PUNCHED RESULTS *
C * CAN BE DIRECTLY READ AND USED BY OTHER PROGRAMS SUCH AS A TRANSI- *
C * TION PROBABILITY PROGRAM. *
C * *
C * THE PRESENT VERSION IS AN IBM S360 DOUBLE-PRECISION *
C * PROGRAM AND USES THE FOLLOWING CPC LIBRARY PROGRAMS, WHICH, FOR *
C * THE PRESENT USE, HAVE ALL BEEN CONVERTED TO DOUBLE-PRECISION *
C * PROGRAMS. *
C * *
C * (1) ACQB, THE P-SHELL CFP PROGRAM: ALLISON (CPC V1(1969)15). *
C * (2) ACRN, THE NEW D-SHELL CFP PROGRAM: CHIVERS (CPC V6(1973)88). *
C * (3) AAGD, THE NJSYM PROGRAM: BURKE (CPC V1(1970)241), ADAPTED *
C * FOR WEIGHTS USING AAGD0001: HIBBERT (CPC V2(1971)180), *
C * WITH AAGD0002: GRANT (CPC V5(1973)161) FOR IMPROVED *
C * RACAH COEFFICIENT ROUTINE, AND WITH THE CORRECTION *
C * AAGD000A: CPC V2(1971)173. *
C * *
C * IT IS TO BE NOTED HERE THAT THE ORIGIONAL VERSION OF *
C * THIS PROGRAM DUE TO ROBB DID NOT USE THE ADAPTATION AAGD0002 OF *
C * GRANT FOR AN IMPROVED RACAH COEFFICIENT ROUTINE. *
C * *
C * IT MAY ALSO BE NOTED HERE THAT THE RECENTLY PUBLISHED *
C * CORRECTIONS (DUE TO HIBBERT, 1975) TO THE ROBB'S PROGRAM HAVE *
C * BEEN INCLUDED IN THIS PRESENT VERSION. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * CONVERSION TO SINGLE-PRECISION:- *
C * ============================== *
C * *
C * AS HAS BEEN SAID ABOVE THIS PROGRAM IS AN IBM S360 *
C * DOUBLE-PRECISION PROGRAM. HOWEVER, ON COMPUTERS WITH A WORD *
C * LENGTH OF 48 BITS OR MORE IT SHOULD BE USED IN SINGLE-PRECISION *
C * ONLY. IN ORDER TO CONVERT THIS PROGRAM TO A SINGLE-PRECISION *
C * PROGRAM THE FOLLOWING SHOULD BE DONE: *
C * *
C * (1) REMOVE ALL 'IMPLICIT REAL*8(A-H,O-Z)' CARDS. *
C * (2) REMOVE '*8' FROM THE FUNCTION DEFINITION CARDS, FOR *
C * EXAMPLE, 'REAL FUNCTION TRITST*8(I,J)' WILL BE REPLACED *
C * BY 'REAL FUNCTION TRITST(I,J)' *
C * (3) CHANGE SYSTEM FUNCTION NAMES 'DSQRT','DABS','DFLOAT', ETC. *
C * TO 'SQRT','ABS','FLOAT', ETC. *
C * (4) CHANGE DOUBLE PRECISION CONSTANTS TO SINGLE PRECISION *
C * CONTANTS. *
C * (5) CHANGE D-FORMAT CODES TO E-FORMAT CODES. *
C * (6) WHEN USING THE SINGLE-PRECISION VERSION OF THIS PROGRAM, *
C * THE OTHER CPC LIBRARY PROGRAMS (ACQB,ACRN, AND AAGD ETC.) *
C * USED, OBVIOUSLY, NEED NOT BE CONVERTED TO DOUBLE-PRECISION *
C * PROGRAMS. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * THE PROGRAM STRUCTURE:- *
C * ===================== *
C * *
C * THE PROGRAM STRUCTURE REMAINS ESSENTIALLY THE SAME AS *
C * IN THE ORIGIONAL VERSION OF THE PROGRAM EXCEPT FOR THE FACT THAT *
C * THE SUBROUTINE 'PRTCON' HAS BEEN PULLED OUT AND THE INPUT-DATA *
C * READ FOR THE INITIAL- AND THE FINAL-STATE IN THE SUBROUTINES *
C * 'GSTATE' AND 'ESTATE' RESPECTIVELY IS NOW PRINTED IN THESE VERY *
C * SUBROUTINES IMMEDIATELY AFTER IT IS READ. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * MODIFICATIONS TO THE COMMON BLOCKS:- *
C * ================================== *
C * *
C * THE COMMON BLOCK /STATEM/ HAS BEEN ENLARGED TO INCLUDE *
C * THE FOLLOWING FIVE ADDITIONAL VARIABLES. *
C * *
C * (1) MMCORB(J,I),J=1,MOCCSH(I),I=1,MCFG, WHICH CONTAINS THE 3 *
C * CHARACTER ALPHANUMERIC *
C * LABELS SUCH AS '1S ', *
C * '2P ','2P1', ETC. FOR *
C * THE OCCUPIED SHELLS IN *
C * THE MCFG INITIAL-STATE *
C * CONFIGURATIONS. *
C * (2) KKCORB(J,I),J=1,KOCCSH(I),I=1,KCFG, WHICH CONTAINS THE 3 *
C * CHARACTER ALPHANUMERIC *
C * LABELS SUCH AS '1S ', *
C * '2P ','2P1', ETC. FOR *
C * THE OCCUPIED SHELLS IN *
C * THE KCFG FINAL-STATE *
C * CONFIGURATIONS. *
C * (3) IAJCMP(I),I=1,MAXOR, WHICH CONTAINS THE THREE CHARACTER *
C * ALPHANUMERIC LABELS SUCH AS '1S ', *
C * '2P ','2P1', ETC. OF ALL THE MAXOR *
C * SHELLS INVOLVED IN THE INITIAL- AND *
C * FINAL-STATES. *
C * (4) LOCATE(I),I=1,MAXOR, WHICH CONTAINS THE EXTERNAL INDICES, *
C * IF ANY, OF THE MAXOR SHELLS WHICH *
C * ARE STORED IN IAJCMP. THESE INDICES *
C * ARE USED ONLY WHEN THE PUNCHED OUTPUT *
C * IS PRODUCED. *
C * (5) JAJCMP(I,J),I=1,MAXOR,J=1,3, WHICH CONTAINS THE INDIVIDUAL *
C * THREE CHARACTERS OF EACH OF *
C * THE MAXOR LABELS OF THE SHELLS *
C * STORED IN IAJCMP(I),I=1,MAXOR. *
C * *
C * THE COMMON BLOCK /MEDFN/ HAS BEEN ENLARGED TO INCLUDE *
C * THE FOLLOWING TWO ADDITIONAL VARIABLES. *
C * *
C * (1) IJFUL(I),I=1,IHSH, AND *
C * (2) JIFUL(I),I=1,IHSH, WHICH FOR A PARTICULAR MATRIX ELEMENT *
C * CORRESPONDING TO A PAIR OF CONFIGU- *
C * RATIONS (ONE FROM THE INITIAL-STATE *
C * AND THE OTHER FROM THE FINAL-STATE) *
C * STORE THE INDICES OF THE IHSH OCCUPIED *
C * SHELLS, IN IJFUL ARRAY ACCORDING TO *
C * THE NATURAL ORDERING OF THE MAXOR *
C * SHELLS AND IN JIFUL ARRAY ACCORDING *
C * TO THE EXTERNAL ORDERING(GIVEN BY THE *
C * VARIABLE LOCATE) OF THE MAXOR SHELLS. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * NEW COMMON BLOCKS:- *
C * ================= *
C * *
C * THE FOLLOWING NEW COMMON BLOCKS HAVE BEEN ADDED IN *
C * THE PRESENT NEW VERSION. *
C * *
C * (1) /SYMM/LANK,LSYM(10) *
C * *
C * THIS CONTAINS A BLANK CHARACTER ' ' (LANK) AND THE *
C * CHARACTERS 'S','P',..,'M' (LSYM), WHICH REPRESENT THE SPEC- *
C * TROSCOPIC SYMMETRY SYMBOLS, ALL IN A1 FORMAT. *
C * *
C * (2) /NVALUE/NVAL(9) *
C * *
C * THIS CONTAINS THE CHARACTERS '1','2',..,'9', ALL IN *
C * A1 FORMAT, REPRESENTING THE NATURAL NUMBERS ONE TO NINE. *
C * *
C * (3) /SPINP/ISPINT,ISPINS *
C * *
C * THIS CONTAINS THE CHARACTERS 'T' (ISPINT) AND 'S' *
C * (ISPINS), BOTH IN A1 FORMAT, REPRESENTING THE SPIN- *
C * INDEPENDENT AND SPIN-DEPENDENT TENSOR OPERATORS. *
C * *
C * (4) /ACFG/ICFG(12) *
C * *
C * THIS CONTAINS THE FOUR CHARACTER STRINGS SUCH AS *
C * 'S(1)','P(3)','D(5)', ETC., ALL IN A4 FORMAT,REPRESENTING *
C * THE VARIOUS BASIC SINGLE-SHELL CONFIGURATIONS. *
C * *
C * (5) /PARAM/ZERO,EPSILO,HALF,ONE *
C * *
C * THIS CONTAINS THE FLOATING POINT DOUBLE-PRECISION *
C * CONSTANTS 0.D0(ZERO), 1.D-08(EPSILO), 0.5D0(HALF), AND *
C * 1.D0(ONE). *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * NEW ARRAYS:- *
C * ========== *
C * *
C * THE FOLLOWING NEW ARRAYS HAVE BEEN ADDED IN THE *
C * PRESENT NEW VERSION. *
C * *
C * (1) ARRAY M1QN(19) IN SUBROUTINE 'GSTATE':- *
C * *
C * THIS ARRAY TEMPORARILY STORES THE SYMMETRY SYMBOLS *
C * (SUCH AS 'S','P','D', ETC.) FOR THE INTERMEDIATE STATES *
C * OF THE COUPLING SCHEME OF ONE INITIAL-STATE CONFIGURA- *
C * TION AT A TIME. *
C * *
C * (2) ARRAY K1QN(19) IN SUBROUTINE 'ESTATE':- *
C * *
C * THIS IS AN ARRAY FOR THE FINAL-STATE AND IS SIMILAR *
C * TO THE ARRAY M1QN DESCRIBED ABOVE. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C * *
C * INPUT DATA ORGANIZATION FOR THE PRESENT NEW VERSION:- *
C * =================================================== *
C * *
C * FOR EACH RUN CONSISTING OF SEVERAL CASES THE INPUT *
C * DATA (THE DEFINITION OF THE VARIABLES BEING THE SAME AS IN THE *
C * ORIGIONAL VERSION, UNLESS OTHERWISE STATED) IS ORGANIZED AS *
C * FOLLOWS: *
C * *
C * (1) NCASES,IREAD,IWRITE *
C * IN FORMAT(18(1X,I3)). *
C * *
C * THIS DATA CARD IS READ FROM THE CARD-INPUT CHANNEL OF *
C * THE INSTALLATION WHICH IS SET IN THE MAIN PROGRAM BY A FOR- *
C * TRAN STATEMENT(CARD AAKP0431) OF THE TYPE 'IREAD=5'. *
C * *
C * NOTE THAT THE VALUE OF 'IREAD' READ HERE REDEFINES THE *
C * INPUT CHANNEL FOR THE REST OF THE INPUT DATA WHICH FOLLOWS. *
C * *
C * (2) FOR EACH CASE(ICASE=1,NCASES) THE FOLLOWING IS READ NOW. *
C * : *
C * :..(A) KA,ISPIN,MAXOR,IPUNCH,IBUG1,IBUG3,NBUG6 *
C * : IN FORMAT(18(1X,I3)). *
C * : *
C * : HERE 'MAXOR' IS THE TOTAL NUMBER OF THE SHELLS *
C * : INVOLVED IN CONFIGURATIONS DEFINING BOTH THE INITIAL- *
C * : AND/OR THE FINAL-STATES. THE MAXIMUM ALLOWED VALUE *
C * : OF MAXOR IS 21. *
C * : *
C * : THE VALUES FOR NO PUNCHING AND NO DEBUGGING ARE *
C * : A ZERO FOR EACH OF IPUNCH,IBIG1,IBUG3, AND NBUG6. *
C * : THUS, WHEN THESE ZERO VALUES APPLY, ONLY THE FIRST *
C * : THREE VARIABLES NEED BE PUNCHED, BECAUSE A BLANK CHAR- *
C * : ACTER IS READ AS A ZERO. *
C * : *
C * :..(B) IAJCMP(I),I=1,MAXOR *
C * : IN FORMAT(18(1X,A3)). *
C * : *
C * : HERE IAJCMP(I) IS THE THREE CHARACTER ALPHANUMERIC *
C * : LABEL (SUCH AS 2P1, WHERE '1' IS JUST AS A SUBSCRIPT) *
C * : OF THE I-TH SHELL. *
C * : *
C * : IT MAY BE NOTED HERE THAT THESE LABELS NEED NOT *
C * : ALWAYS HAVE A THIRD CHARACTER, DENOTING THE SUBSCRIPT *
C * : OF THE SHELL, AS A NON-BLANK CHARACTER. IF FOR A SHELL *
C * : A SUBSCRIPT IS REDUNDANT, IT MAY BE A BLANK CHARACTER, *
C * : SUCH AS IN '2P '. ALTERNATIVELY, IN A CASE LIKE THIS, *
C * : ONE CAN ASWELL RIGHT-ADJUST THE LABEL AS ' 2P'. *
C * : *
C * :..(C) JAJCMP(I,1),JAJCMP(I,2),JAJCMP(I,3),I=1,MAXOR *
C * : IN FORMAT(18(1X,3A1)). *
C * : *
C * : HERE JAJCMP(I,1),JAJCMP(I,2),AND JAJCMP(I,3) ARE *
C * : THE INDIVIDUAL CHARACTERS (SUCH AS '2', 'P', AND '1' *
C * : IN 2P1) OF THE THREE CHARACTER LABEL OF THE I-TH SHELL. *
C * : THESE ARE USED TO DETERMINE THE ARRAY NJCOMP(I) AND THE *
C * : ARRAY LJCOMP(I). *
C * : *
C * : IT MAY BE NOTED HERE THAT IN (C) WE ACTUALLY READ *
C * : A DUPLICATE OF THE CARD READ IN (B) ABOVE. SUCH A DUP- *
C * : LICATION CAN BE AVOIDED BY USING A FEATURE LIKE REREAD *
C * : OR BACKSPACE, IF THAT IS AVAILABLE AT THE INSTALLATION *
C * : WHERE THIS PROGRAM IS USED. *
C * : *
C * :..(D) LOCATE(I),I=1,MAXOR *
C * : IN FORMAT(18(1X,I3)). *
C * : *
C * : THIS CARD IS READ ONLY IF 'IPUNCH' READ ABOVE IN *
C * : (A) IS NOT ZERO, LOCATE(I) DENOTING THE EXTERNAL INDEX *
C * : OF THE I-TH SHELL WITH WHICH IT WILL BE REFERRED TO *
C * : IN THE PUNCHED INFORMATION. *
C * : *
C * :..(E) WE NOW READ THE FOLLOWING (IN THE SUBROUTINE *
C * : : GSTATE) FOR THE INITIAL-STATE CONSIDERED. *
C * : : *
C * : :..(E1) MCFG *
C * : : IN FORMAT(18(1X,I3)). *
C * : : *
C * : : 'MCFG' IS THE TOTAL NUMBER OF CONFIGURATIONS *
C * : : IN THE INITIAL-STATE, ITS MAXIMUM ALLOWED VALUE *
C * : : BEING 30. *
C * : : *
C * : :..(E2) MOCCSH(I),I=1,MCFG *
C * : : IN FORMAT(18(1X,I3)). *
C * : : *
C * : : MOCCSH(I) IS THE NUMBER OF OCCUPIED SHELLS IN *
C * : : THE I-TH INITIAL-STATE CONFIGURATION. THE MAXIMUM *
C * : : ALLOWED VALUE OF ANY MOCCSH(I) IS 10. *
C * : : *
C * : :..(E3) FOR EACH OF THE INITIAL-STATE CONFIGURATIONS *
C * : : : (I=1,MCFG) WE NOW READ THE FOLLOWING: *
C * : : : *
C * : : :...(E3.1) MMCORB(J,I),MELCSH(J,I),J=1,MOCCSH(I) *
C * : : : IN FORMAT(5(1X,A3,1H(,I2,1H))). *
C * : : : *
C * : : : HERE MMCORB(J,I) IS THE LABEL (SUCH *
C * : : : AS 2P1) OF THE J-TH OCCUPIED SHELL IN *
C * : : : THE I-TH INITIAL-STATE CONFIGURATION AND *
C * : : : MELCSH(J,I) IS THE NUMBER OF ELECTRONS *
C * : : : IN THIS SHELL. *
C * : : : *
C * : : : THE ARRAY MMCORB(J,I) IS USED IN THE *
C * : : : PROGRAM TO DETERMINE THE ARRAY MOCORB(J,I). *
C * : : : *
C * : : :...(E3.2) M1QNRD(J,3,I),M1QN(J),M1QNRD(J,1,I),J=1,M *
C * : : : IN FORMAT(9(1X,4X,I1,A1,I1)), *
C * : : : WHERE M=2*MOCCSH(I)-1 *
C * : : : *
C * : : : HERE WE READ THE COUPLING OF THE CON- *
C * : : : FIGURATION JUST READ ABOVE IN (E3.1). FIRST *
C * : : : THE STATES OF THE EACH OCCUPIED SHELLS AND *
C * : : : THEN THE STATES ARISING OUT OF THE COUPL- *
C * : : : ING OF THESE SHELL-STATES FROM LEFT TO *
C * : : : RIGHT ARE READ, EACH IN TERMS OF THREE VA- *
C * : : : RIABLES: INTEGER M1QNRD(J,3,I), ALPHAMERIC *
C * : : : M1QN(J), AND INTEGER M1QNRD(J,1,I). *
C * : : : *
C * : : : M1QNRD(J,3,I) REPRESENTS THE MULTIPLI- *
C * : : : CITY (2S+1 VALUE, S BEING THE SPIN QUANTUM *
C * : : : NUMBER), M1QNRD(J,1,I) REPRESENTS THE SENI- *
C * : : : ORITY, AND M1QN(J) REPRESENTS THE SYMMETRY *
C * : : : (SUCH AS 'S','P', ETC.) OF THE J-TH INTER- *
C * : : : MEDIATE STATE OF THE COUPLING SCHEME READ. *
C * : : : THE VALUES OF THE L QUANTUM NUMBER OF THESE *
C * : : : INDIVIDUAL STATES ARE EVALUATED FROM THE *
C * : : : THE SYMBOL M1QN OF THE STATES AND THESE *
C * : : : ARE STORED IN M1QNRD(J,2,I). *
C * : : : *
C * : : :..................................................... *
C * : : *
C * : :......................................................... *
C * : *
C * : *
C * :..(F) WE NOW READ (IN THE SUBROUTINE ESTATE) THE DATA *
C * : : AS BELOW FOR THE FINAL-STATE CONSIDERED. THIS DATA IS *
C * : : SIMILAR TO THE ONE READ IN (E) ABOVE FOR THE INITIAL *
C * : : STATE AND THEREFORE THE FULL EXPLANATION IS NOT RE- *
C * : : PEATED BELOW. HOWEVER, IT MAY BE REMARKED HERE THAT *
C * : : THE VARIABLES KCFG, KOCCSH, KKCORB, KELCSH, KOCORB, *
C * : : K1QNRD, AND K1QN DEALT BELOW HAVE THE SIMILAR MEANING *
C * : : AND USEFULNESS AS THE VARIABLES MCFG, MOCCSH, MMCORB, *
C * : : MELCSH, MOCORB, M1QNRD, AND M1QN FOR THE INITIAL *
C * : : STATE CONSIDERED IN (E) ABOVE. IT MAY ALSO BE NOTED *
C * : : THAT THE MAXIMIM VALUES ALLOWED FOR KCFG AND ANY OF *
C * : : OF KOCCSH(I)'S ARE SAME AS THOSE OF MCFG AND ANY OF *
C * : : MOCCSH(I)'S IN (E) ABOVE. *
C * : : *
C * : :..(F1) KCFG *
C * : : IN FORMAT(18(1X,I3)). *
C * : : *
C * : :..(F2) KOCCSH(I),I=1,KCFG *
C * : : IN FORMAT(18(1X,I3)). *
C * : : *
C * : :..(F3) FOR EACH OF THE FINAL-STATE CONFIGURATIONS *
C * : : : (I=1,KCFG) WE NOW READ THE FOLLOWING: *
C * : : : *
C * : : :...(F3.1) KKCORB(J,I),KELCSH(J,I),J=1,KOCCSH(I) *
C * : : : IN FORMAT(5(1X,A3,1H(,I2,1H))). *
C * : : : *
C * : : :...(F3.2) K1QNRD(J,3,I),K1QN(J),K1QNRD(J,1,I),J=1,M *
C * : : : IN FORMAT(9(1X,4X,I1,A1,I1)), *
C * : : : WHERE M=2*KOCCSH(I)-1 *
C * : : : *
C * : : :..................................................... *
C * : : *
C * : :......................................................... *
C * : *
C * :............................................................. *
C * *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C-----------------------------------------------------------------------
C
C *** M A I N
C
C-----------------------------------------------------------------------
C
c
program main
c
c IMPLICIT REAL*8(A-H,O-Z)
DIMENSION NJCOMP(21),LJCOMP(21),VSHELL(20)
long LSYM,LANK,ISPINT,ISPINS,NVAL,ICFG
long MMCORB,KKCORB,IAJCMP,LOCATE,JAJCMP
common/inf1/writef
common/inf2/punchf
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,icheck
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3),
1J1QN2(19,3),IJFUL(10),JIFUL(10)
COMMON/NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9
COMMON/STATEM/MOCCSH(30),KOCCSH(30),MOCORB(10,30),KOCORB(10,30),
1MELCSH(10,30),KELCSH(10,30),M1QNRD(19,3,30),K1QNRD(19,3,30),MAXOR
2,MMCORB(10,30),KKCORB(10,30),IAJCMP(21),LOCATE(21),JAJCMP(21,3)
COMMON/SYMM/LANK,LSYM(10)
COMMON/NVALUE/NVAL(9)
COMMON/SPINP/ISPINT,ISPINS
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
615 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,23HTOTAL NUMBER OF ERRORS=,I3,
2/16h DATA CHECKING: ,/16h DATA CHECKING: ,
327HPROCEEDING TO THE NEXT CASE/16H DATA CHECKING: )
1 FORMAT(18(1X,I3))
3 FORMAT(31X,F12.8,I5,I5,5X,1H<,A3,2H//,A1,1H(,I1,3H)//,A3,2H >)
5 FORMAT(F13.8,3HRI(,2I2,1H,,2I2,1H))
55 FORMAT(' *')
56 format(/,1x,' fejl. iread skal vaere lig enten 1 eller 5, ',
1 /,' iwrite skal vaere lig enten 7 eller 6. ')
57 format(/,1x,' fejl. ipunch skal vaere lig enten 0 eller 8. ')
555 FORMAT( ///32X,40HNUMBER OF TERMS IN THE ABOVE SUMMATIONS=,I3)
6 FORMAT(//9H KA =,I3,38H (ORDER OF SPACE DEPENDENT TENSOR) /
1 9H KB =,I3,38H (ORDER OF SPIN DEPENDENT TENSOR) /
1 9H ISPIN =,I3,38H (=0 ,SPACE-DEPENDENT SINGLE TENSOR /
1 9H ,3X,38H =1 ,SPIN- DEPENDENT SINGLE TENSOR /
1 9H ,3X,38H =2 ,SIMPLE PRODUCT OF ABOVE TENSORS)/
2 9H IPUNCH =,I3,38H (PUNCHED OUTPUT UNIT) /
3 9H IBUG1 =,I3,38H (DEBUG FOR COEFF. OF FP IN CFP PROG.)/
4 9H IBUG3 =,I3,38H (DEBUG IN RECOUPLING PACKAGE) /
5 9H NBUG6 =,I3,38H (DEBUG IN TENSOR PACKAGE) )
7 FORMAT(1H1,37X,29H ******************** CASE,I2,25H ********
1************)
8 FORMAT(/////9H NCASES =,I3,33H (THE NUMBER OF CASES CONSIDERED)/
1 9H IREAD =,I3,33H (DATA INPUT UNIT) /
2 9H IWRITE =,I3,33H (PRINTED OUTPUT UNIT) //)
9 FORMAT(18(1X,A3))
23 FORMAT(/10H THERE ARE,I3,21H ORBITALS AS FOLLOWS://5X,9HORBITALS:,
1 20X,21(1X,A3))
11 FORMAT(18(1X,3A1))
24 FORMAT(5X,11HN,L VALUES: ,18X,21(2X,2I1))
241 FORMAT(5X,29HORDER USED IN PUNCHED OUTPUT: ,21(1X,I3))
2 FORMAT(1H1,41X,3HSUM/19H < INITIAL STATE //,A1,1H(,I1,78H)// FINAL
1 STATE > = OVER COEFF * WEIGHT(INITIAL,I) * WEIGHT(FINAL,J) * < N
2L//,A1,1H(,I1,8H)//N'L'>)
4 FORMAT( 42X,3HI,J///36X,28HCOEFF I J < NL//
1,A1,1H(,I1,8H)//N'L'>//)
33 FORMAT(31X,F12.8,I5,I5,5X,1H<,A3,1H/,A1,1H(,I1,2H).,A1,1H(,I1,2H)/
1,A3,2H >)
22 FORMAT(1H1,44X,3HSUM/18H < INITIAL STATE /,A1,1H(,I1,2H).,A1,1H(,
1I1,76H)/ FINAL STATE > = OVER COEFF * WEIGHT(INITIAL,I) * WEIGHT(
2FINAL,J) * < NL/,A1,1H(,I1,2H).,A1,1H(,I1,7H)/N'L'>)
44 FORMAT( 45X,3HI,J///36X,27HCOEFF I J < NL/
1,A1,1H(,I1,2H).,A1,1H(,I1,7H)/N'L'>//)
c
zone readf(128,1,stderror)
zone writef(128,1,stderror)
zone punchf(128,1,stderror)
c
c set input and output channels
c
iread=1
call zassign(readf,iread)
call open(readf,4,'inf',0)
iwrite=7
call zassign(writef,iwrite)
call open(writef,4,'outf',0)
ipunch=8
call zassign(punchf,ipunch)
call open(punchf,4,'pchf',0)
c
call bldata
c
KFL1=0
READ(IREAD,1) NCASES,IREAD,IWRITE
c
if ((iread.eq.1.or.iread.eq.5).and.(iwrite.eq.7.or.iwrite.eq.6))
1 goto 900
write(6,56)
write(7,56)
goto 1000
900 continue
c
C
C PRINT OUT TABLE OF TERMS
C
CALL TMSOUT
C
C READ IN THE NUMBER OF DATA SETS AND THE GENERAL DATA
C
WRITE(IWRITE,8) NCASES,IREAD,IWRITE
DO 1000 ICASE=1,NCASES
WRITE(IWRITE,7) ICASE
READ(IREAD,1) KA,kb,ISPIN,MAXOR,IPUNCH,IBUG1,IBUG3,NBUG6
WRITE(IWRITE,6) KA,kb,ISPIN,IPUNCH,IBUG1,IBUG3,NBUG6
c
if (ipunch.eq.0.or.ipunch.eq.8) goto 901
write(6,57)
write(7,57)
goto 1000
901 continue
c
READ(IREAD,9) (IAJCMP(I), I=1,MAXOR)
WRITE(IWRITE,23) MAXOR ,(IAJCMP(I),I=1,MAXOR )
READ(IREAD,11)((JAJCMP(I,J),J=1,3),I=1,MAXOR )
DO 60 I=1,MAXOR
J=3
IF(JAJCMP(I,1).NE.LANK) J=2
DO 59 JJ=1,9
IF(JAJCMP(I,J) .EQ.LSYM(JJ)) LJCOMP(I)=JJ-1
59 IF(JAJCMP(I,J-1).EQ.NVAL(JJ)) NJCOMP(I)=JJ
60 CONTINUE
WRITE(IWRITE,24) (NJCOMP(I),LJCOMP(I),I=1,MAXOR)
IF(IPUNCH.EQ.0) GO TO 65
READ(IREAD,1) (LOCATE(I),I=1,MAXOR)
WRITE(IWRITE,241)(LOCATE(I),I=1,MAXOR)
65 CONTINUE
C
C READ IN INITIAL STATE CONFIGURATIONS ETC. AND PRINT THEM.
C
CALL GSTATE(MCFG)
C
C READ IN FINAL STATE CONFIGURATIONS ETC. AND PRINT THEM.
C
CALL ESTATE(KCFG)
C
C IF ERROR WAS FOUND IN THE INPUT DATA, JUMP TO THE NEXT CASE
C
IF(ICHECK.EQ.0) GO TO 616
WRITE(IWRITE,615) ICHECK
GO TO 1000
C
C CALCULATE THE ELEMENTS OF VSHELL
C
616 IF(ISPIN.EQ.0) WRITE(IWRITE,2) ISPINT,KA,ISPINT,KA
IF(ISPIN.EQ.0) WRITE(IWRITE,4) ISPINT,KA
IF(ISPIN.EQ.1) WRITE(IWRITE,2) ISPINS,KB,ISPINS,KB
IF(ISPIN.EQ.1) WRITE(IWRITE,4) ISPINS,KB
IF(ISPIN.EQ.2)WRITE(IWRITE,22) ISPINT,KA,ISPINS,KB
1 ,ISPINT,KA,ISPINS,KB
IF(ISPIN.EQ.2)WRITE(IWRITE,44) ISPINT,KA,ISPINS,KB
NTERMS=0
DO 10 JI=1,MCFG
DO 20 JF=1,KCFG
C
C SET UP THE OCCUPATION AND COUPLING ARRAYS
C
CALL SETUPE(JI,JF,NJCOMP,LJCOMP)
C
C CALL THE MAIN ROUTINE - TENSOR
C
CALL TENSOR(KA,kb,ISPIN,IRHO,ISIG,VSHELL)
IF(IRHO.EQ.ISIG) GO TO 30
IF(abs(VSHELL(1)).LE.EPSILO) GO TO 20
JRHO=IJFUL(IRHO)
JSIG=IJFUL(ISIG)
KRHO=JIFUL(IRHO)
KSIG=JIFUL(ISIG)
IF(ISPIN.EQ.0) WRITE(IWRITE,3) VSHELL(1),JI,JF,IAJCMP(JRHO),ISPINT
1,ka,IAJCMP(JSIG)
IF(ISPIN.EQ.1) WRITE(IWRITE,3) VSHELL(1),JI,JF,IAJCMP(JRHO),ISPINS
1,kb,IAJCMP(JSIG)
if(ispin.eq.2)write(iwrite,33) vshell(1),ji,jf,iajcmp(jrho),ispint
1,ka,ispins,kb,iajcmp(jsig)
C
C PRINT OUT THE RESULTS AND OUTPUT THEM ON CHANNEL IPUNCH IF IPUNCH
C IS NOT EQUAL TO ZERO.
C
NTERMS=NTERMS+1
IF(IPUNCH.NE.0) WRITE(IPUNCH,5) VSHELL(1),KRHO,JI,KSIG,JF
GO TO 20
30 DO 40 IS=1,IHSH
IF(abs(VSHELL(IS)).LE.EPSILO)GO TO 40
JRHO=IJFUL(IS)
KRHO=JIFUL(IS)
IF(ISPIN.EQ.0) WRITE(IWRITE,3)VSHELL(IS),JI,JF,IAJCMP(JRHO),ISPINT
1,KA,IAJCMP(JRHO)
IF(ISPIN.EQ.1) WRITE(IWRITE,3)VSHELL(IS),JI,JF,IAJCMP(JRHO),ISPINS
1,kb,IAJCMP(JRHO)
if(ispin.eq.2)write(iwrite,33)vshell(is),ji,jf,iajcmp(jrho),ispint
1,ka,ispins,kb,iajcmp(jrho)
NTERMS=NTERMS+1
IF(IPUNCH.NE.0) WRITE(IPUNCH,5) VSHELL(IS),KRHO,JI,KRHO,JF
40 CONTINUE
20 CONTINUE
10 CONTINUE
WRITE(IWRITE,555) NTERMS
IF(IPUNCH.NE.0) WRITE(IPUNCH,55)
1000 CONTINUE
call exit
END
c
c----------------------------------------------------------------------
c e x i t
c----------------------------------------------------------------------
c
subroutine exit
common/inf1/writef
common/inf2/punchf
integer eof
zone writef(128,1,stderror)
zone punchf(128,1,stderror)
4 format(/,a3)
eof=1644825
write(writef,4) eof
write(punchf,4) eof
call close(writef,.true.)
call close(punchf,.true.)
stop
return
end
c
c-------------------------------------------------------------------
c t e n s o r
c-------------------------------------------------------------------
c
SUBROUTINE TENSOR(KA,kb,ISPIN,IRHO,ISIG,VSHELL)
C
C W. D. ROBB - NOVEMBER 1971
C
C **********************************************************************
C
C A ROUTINE FOR THE EVALUATION OF ANGULAR AND SPIN FACTORS IN THE
C REDUCED MATRIX ELEMENT OF ANY ONE-ELECTRON TENSOR OPERATOR BETWEEN
C ARBITRARILY COUPLED L-S CONFIGURATIONS
C
C***********************************************************************
C
C ** NOTE THAT THE DEFINITIONS OF TENSOR OPERATORS USED ARE THOSE
C OF FANO AND RACAH, IRREDUCIBLE TENSORIAL SETS, ACADEMIC PRESS 1959
C
C***********************************************************************
C
C DIMENSION STATEMENTS
C
c IMPLICIT REAL*8(A-H,O-Z)
DIMENSION L6(40),L7(80),L8(40),LW(6,20),J2STO(10,3),J3STO(10,3),JM
1EM(5),VSHELL(20)
C
C COMMON BLOCKS
C
COMMON/COUPLE/MN1,M0,J1(40),J2(12,3),J3(12,3)
COMMON/INFORM/IREAD,IWRITE,IPUNCH,icheck
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3)
1,J1QN2(19,3),IJFUL(10),JIFUL(10)
COMMON/NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9
common/terms/nrows,itab(14),jtab(14),ntab(219),ntab1(10,5),
1 ntab2(11,5)
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
C
203 FORMAT(//7H NJ,LJ ,10(I6,I3))
204 FORMAT(//6H NOSH ,10I4)
205 FORMAT(//6H J1QN ,30I3)
208 FORMAT(// 23H PARENT TERMS NOT FOUND//)
209 FORMAT(//3H J1)
210 FORMAT(24I5)
211 FORMAT(24H J2 J3)
212 FORMAT(3I5,I10,2I5)
213 FORMAT(///26H ORBITAL RECOUPLING COEFF=,E20.8)
214 FORMAT(///23H SPIN RECOUPLING COEFF=,E20.8//)
215 FORMAT(/28H THE CONTRIBUTION FROM SHELL,I2,3H IS,F15.8)
216 FORMAT(//21H THIS IS NOT A PARENT)
217 FORMAT(///8H VSHELL=,8F15.8)
218 FORMAT(//24H FRACTIONAL PARENT TERMS,I2)
219 FORMAT(//49H THE CONTRIBUTION FROM FRACTIONAL PARENTAGE TERMS,I2,
1 3H IS,F15.8)
220 FORMAT(//6H SHELL,I2)
313 FORMAT(19H SPECTATOR SUBSHELL,I3,69H HAS DIFFERENT QUANTUM NUMBERS
1 ON THE TWO SIDES OF THE MATRIX ELEMENT/)
C
AJF=ONE
RML = ZERO
RPL = ZERO
NTOT=0
DO 100 IS=1,IHSH
VSHELL(IS)=ZERO
100 CONTINUE
IHSHP1=IHSH+1
I2HSH=IHSH*2-1
C
C PRINT OUT THE OCCUPATION AND COUPLING ARRAYS
C
IF(NBUG6-1) 101,2,101
2 WRITE(IWRITE,203) (NJ(I),LJ(I),I=1,IHSH)
WRITE(IWRITE,204)(NOSH1(J),J=1,IHSH)
WRITE(IWRITE,204)(NOSH2(J),J=1,IHSH)
WRITE(IWRITE,205) ((J1QN1(J,K),K=1,3),J=1,I2HSH)
WRITE(IWRITE,205) ((J1QN2(J,K),K=1,3),J=1,I2HSH)
C
C TEST FOR AT MOST ONE ELECTRON DIFFERENCE IN CONFIGURATIONS
C
101 NOSHUM=0
DO 102 K=1,IHSH
NOSHUM=NOSHUM+IABS(NOSH1(K)-NOSH2(K))
102 CONTINUE
IF(NOSHUM-2) 103,103,183
C
C TEST FOR TRIANGLE RELATION BETWEEN KA AND TOTAL ANGULAR MOMENTA
C
103 IF(ISPIN.EQ.0) GO TO 198
K=3
kc=kb
if(ispin.eq.2) goto 199
IF(J1QN1(I2HSH,2).NE.J1QN2(I2HSH,2)) GO TO 183
GO TO 199
198 K=2
kc=ka
IF(J1QN1(I2HSH,3).NE.J1QN2(I2HSH,3)) GO TO 183
199 LB=J1QN1(I2HSH,K)-1
NB=J1QN2(I2HSH,K)-1
mb=kc+kc
BTST=TRITST(MB,LB,NB)
IF(BTST.GT.EPSILO) GO TO 183
if(k.eq.2.or.ispin.lt.2) goto 104
k=2
kc=ka
goto 199
104 continue
C
C DETERMINE IRHO AND ISIGMA, THE NUMBERS OF THE OCCUPIED SHELLS
C
IRHO=0
ISIG=0
DO 105 J=1,IHSH
NX=NOSH1(J)-NOSH2(J)+2
GO TO (107,105,106),NX
107 ISIG=J
GO TO 105
106 IRHO=J
105 CONTINUE
IF(IRHO.NE.0 ) GO TO 108
IRHO=1
ISIG=1
108 MEMR = IRHO
C
C THE BEGINNING OF THE LOOP OVER ALL SHELLS
C
109 IF(IRHO.NE.ISIG) GO TO 309
IF(NBUG6-1) 309,4,309
4 WRITE(IWRITE,220) IRHO
309 NTOT=NTOT+1
L1=LJ(IRHO)+1
L2=LJ(ISIG)+1
AJF=float(J1QN1(I2HSH,2))/float(2*LJ(IRHO)+1)
if(ispin.eq.1) ajf=float(j1qn1(i2hsh,3))*half
if(ispin.eq.2) ajf=ajf*float(j1qn1(i2hsh,3))*half
C
C CHECK THE DIAGONAL CHARACTER OF THE QUANTUM NUMBERS OF SPACTATOR
C SHELLS
C
DO 255 J=1,IHSH
IF(J.EQ.IRHO.OR.J.EQ.ISIG) GO TO 255
DO 256 KK=1,3
IF(J1QN1(J,KK).NE.J1QN2(J,KK)) GO TO 257
256 CONTINUE
255 CONTINUE
GO TO 258
257 IF(NBUG6.EQ.1) WRITE(IWRITE,313) J
IF(IRHO.NE.ISIG) GO TO 190
GO TO 189
258 IF(IRHO-ISIG) 120,111,120
C
C FIND THE PARENT TERMS GIVEN BY ALLOWED J VALUES IN NTAB WITH IRHO
C
111 NELCTS=NOSH1(IRHO)
K1=NTAB1(NELCTS,L1)
KK1=ITAB(K1)
DO 112 JJ1=1,KK1
IJK1=3*(JJ1-1)+JTAB(K1)
DO 113 K=2,3
IJKK=IJK1+K
IF(K.EQ.3) GO TO 114
LA=NTAB(IJKK)
MA=2*LJ(IRHO)+1
NA=J1QN1(IRHO,K)
GO TO 115
114 LA=NTAB(IJKK)-1
MA=1
NA=J1QN1(IRHO,K)-1
115 ATST=TRITST(LA,MA,NA)
IF(ATST.GT.EPSILO) GO TO 116
IF(K-3) 113,118,113
116 JMEM(JJ1)=0
GO TO 112
118 JMEM(JJ1)=1
113 CONTINUE
112 CONTINUE
C
C PARENTAGE CHECK
C
120 IF(IRHO-ISIG) 121,127,121
121 NELCTS=NOSH1(IRHO)
K1=NTAB1(NELCTS,L1)
NELCTS=NOSH2(ISIG)
K2=NTAB1(NELCTS,L2)
KK1=ITAB(K1)
KK2=ITAB(K2)
DO 122 JJ1=1,KK1
IJK1=3*(JJ1-1)+JTAB(K1)
DO 123 K=2,3
IJKK=IJK1+K
MSAM1=NTAB(IJKK)-J1QN2(IRHO,K)
IF(MSAM1.NE.0) GO TO 122
IF(K.EQ.3) GO TO 124
123 CONTINUE
122 CONTINUE
IF(NBUG6-1) 192,7,192
7 WRITE(IWRITE,208)
GO TO 192
124 DO 125 JJ2=1,KK2
IJK2=3*(JJ2-1)+JTAB(K2)
DO 126 K=2,3
IJKK=IJK2+K
MSAM2=NTAB(IJKK)-J1QN1(ISIG,K)
IF(MSAM2.NE.0) GO TO 125
IF(K.EQ.3) GO TO 127
126 CONTINUE
125 CONTINUE
IF(NBUG6-1) 192,8,192
8 WRITE(IWRITE,208)
GO TO 192
C
C SET J2 AND J3 . SAME FOR L AND S
C
127 M1=IHSH-2
M2=2*M1+1
M3=3*IHSH-1
M4=M3+1
M5=M3+2
M10=M5+1
MN1=M10+1
J2(1,1)=M10
J2(1,2)=MN1
J2(1,3)=M5
J2(2,1)=IRHO
J2(2,2)=M5
J2(2,3)=M3
J3(1,1)=ISIG
J3(1,2)=M10
J3(1,3)=M4
IF(IRHO-1) 128,129,128
129 J2(3,1)=M3
GO TO 130
128 J2(3,1)=1
130 IF(IRHO-2) 131,132,131
132 J2(3,2)=M3
GO TO 133
131 J2(3,2)=2
133 J2(3,3)=IHSHP1
IF(ISIG-1) 134,135,134
135 J3(2,1)=M4
GO TO 136
134 J3(2,1) = 1
136 IF(ISIG-2) 137,138,137
138 J3(2,2)=M4
GO TO 139
137 J3(2,2)=2
139 J3(2,3)=2*IHSH
IF(IHSH-3) 149,140,140
140 DO 148 J=4,IHSHP1
L=J-1
J2(J,1)=M1+L
J2(J,3)=M1+J
J3(L,1)=M2+L
J3(L,3)=M2+J
IF(IRHO-L) 142,143,142
143 J2(J,2)=M3
GO TO 144
142 J2(J,2)=L
144 IF(ISIG-L) 145,146,145
146 J3(L,2)=M4
GO TO 148
145 J3(L,2)=L
148 CONTINUE
149 M6=IHSHP1
J3(M6,1)=M3-1
J3(M6,2)=MN1
J3(M6,3)=I2HSH
IF(IHSH-1) 450,451,450
451 J3(M6,1) = M4
J3(M6,3) = M3
450 DO 150 J=1,IHSHP1
DO 151 K=1,3
J2STO(J,K)=J2(J,K)
J3STO(J,K)=J3(J,K)
151 CONTINUE
150 CONTINUE
C
C RECOUPLING COEFFICIENTS
C
JMEM1=J1QN1(IRHO,1)
JMEM2=J1QN1(IRHO,2)
JMEM3=J1QN1(IRHO,3)
JMEM4=J1QN2(ISIG,1)
JMEM5=J1QN2(ISIG,2)
JMEM6=J1QN2(ISIG,3)
IF(IRHO-ISIG) 154,152,154
C
C BEGINNING OF LOOP OVER ALL PARENT TERMS
C
152 JJ1=1
1152 IF(NBUG6-1) 12,11,12
11 WRITE(IWRITE,218) JJ1
12 IF(JMEM(JJ1).EQ.1) GO TO 153
IF(NBUG6-1) 186,16,186
16 WRITE(IWRITE,216)
GO TO 186
153 IJK1=3*(JJ1-1)+JTAB(K1)
NI1=NTAB(IJK1+1)
NI2=NTAB(IJK1+2)
NI3=NTAB(IJK1+3)
J1QN2(IRHO,1)=NI1
J1QN1(ISIG,1)=NI1
J1QN2(IRHO,2)=NI2
J1QN1(ISIG,2)=NI2
J1QN2(IRHO,3)=NI3
J1QN1(ISIG,3)=NI3
154 K=2
M7=M3-IHSH
M9=M7+1
M11=M3-1
M12=IHSH-1
RECUPS=ONE
M0=M6+1
C
C SET UP THE J1 ARRAY FOR THE ANGULAR AND SPIN RECOUPLING
C COEFFICIENTS
C
155 IF(K-3) 156,157,157
156 J1(M5)=2*LJ(IRHO)+1
J1(M10)=2*LJ(ISIG)+1
J1(MN1)=2*KA+1
IF(ISPIN.eq.1) J1(MN1)=1
J1(M3)=JMEM2
J1(M4)=JMEM5
IF(IRHO.EQ.ISIG) GO TO 158
J1(M3)=J1QN1(IRHO,K)
J1(M4)=J1QN2(ISIG,K)
GO TO 158
157 J1(M5)=2
J1(M10)=2
j1(mn1)=kb+kb+1
if(ispin.eq.1) j1(mn1)=1
J1(M3)=JMEM3
J1(M4)=JMEM6
IF(IRHO.EQ.ISIG) GO TO 158
J1(M3)=J1QN1(IRHO,K)
J1(M4)=J1QN2(ISIG,K)
158 DO 161 J=1,IHSH
IF(IRHO-J) 160,159,160
159 J1(J)=J1QN2(IRHO,K )
GO TO 161
160 J1(J)=J1QN1(J,K)
161 CONTINUE
IF(IHSH.EQ.1) GO TO 197
DO 162 J=M6,M7
J1(J)=J1QN1(J,K)
162 CONTINUE
DO 163 J=M9,M11
JM12=J-M12
J1(J)=J1QN2(JM12,K)
163 CONTINUE
C
C PRINT OUT THE J1,J2 AND J3 ARRAYS
C
197 IF(NBUG6-1) 304,9,304
9 IF(K-3) 165,164,164
165 IF(NBUG6-1) 304,17,304
17 WRITE(IWRITE,209)
WRITE(IWRITE,210) (J1(J),J=1,MN1)
WRITE(IWRITE,211)
DO 166 I=1,IHSHP1
WRITE(IWRITE,212) ((J2(I,J),J=1,3),(J3(I,J),J=1,3))
166 CONTINUE
304 CONTINUE
C
C EVALUATE ORBITAL AND SPIN RECOUPLING COEFFICIENTS
C
164 CALL NJSYM(J6C,J7C,J8C,JWC,L6,L7,L8,LW,RECUP)
RECUPS=RECUPS*RECUP
IF(K-3) 167,170,170
167 IF(NBUG6-1) 305,18,305
18 WRITE(IWRITE,213) RECUP
305 CONTINUE
170 K=K+1
DO 168 J=1,IHSHP1
DO 169 KK=1,3
J2(J,KK)=J2STO(J,KK)
J3(J,KK)=J3STO(J,KK)
169 CONTINUE
168 CONTINUE
IF(K.EQ.3) GO TO 155
IF(NBUG6-1) 306,19,306
19 WRITE(IWRITE,214) RECUP
C
C FIRST FRACTIONAL PARENTAGE COEFFICIENT
C
306 LIJ=LJ(IRHO)
COEFP=ONE
IF(LIJ) 171,272,171
171 N=NOSH1(IRHO)
IV1=JMEM1
IL1=(JMEM2-1)/2
IS1= JMEM3
IV2=J1QN2(IRHO,1)
IL2=(J1QN2(IRHO,2)-1 )/2
IS2=J1QN2(IRHO,3)
CALL CFP(LIJ,N,IV1,IL1,IS1,IV2,IL2,IS2,COEFP)
RECUPS=RECUPS*COEFP
272 IF(IRHO-ISIG) 172,173,172
172 IF(abs(RECUPS).LT.EPSILO)GO TO 183
C
C SECOND FRACTIONAL PARENTAGE COEFFICIENT
C
173 LIJ=LJ(ISIG)
COEFP=ONE
IF(LIJ) 176,176,174
174 N=NOSH2(ISIG)
IV1=JMEM4
IL1=(JMEM5-1)/2
IS1=JMEM6
IV2=J1QN1(ISIG,1)
IL2=(J1QN1(ISIG,2)-1)/2
IS2=J1QN1(ISIG,3)
CALL CFP(LIJ,N,IV1,IL1,IS1,IV2,IL2,IS2,COEFP)
176 RECUPS=RECUPS*COEFP
IF(abs(RECUPS).LT.EPSILO.AND.IRHO.NE.ISIG)GO TO 183
C
C PERMUTATION FACTOR
C
IDELP=2
IF(IRHO-ISIG) 177,181,179
177 JRHO = IRHO+1
DO 178 J=JRHO,ISIG
178 IDELP=IDELP+NOSH1(J)
GO TO 181
179 JSIG = ISIG+1
DO 180 J=JSIG,IRHO
180 IDELP = IDELP+NOSH2(J)
181 MINUS=(-1)**IDELP
C
C MULTIPLICATIVE FACTOR
C
IF(IRHO-ISIG) 182,185,182
182 SQRN=sqrt(float(NOSH1(IRHO)*NOSH2(ISIG)))
VALML=SQRN*RECUPS*float(MINUS)
GO TO 184
183 VALML = ZERO
184 RML = RML+VALML
C
C RESULT STORED IN VSHELL
C
IF(NTOT.EQ.0) NTOT=1
VSHELL(NTOT)=RML*sqrt(AJF)
GO TO 190
185 VALUML=RECUPS
IF(NBUG6.NE.0) WRITE(IWRITE,219) JJ1,VALUML
RPL = RPL+VALUML
186 IF(IRHO.NE.ISIG)GO TO 1186
JJ1=JJ1+1
IF(JJ1.LE.KK1)GO TO 1152
1186 J1QN1(IRHO,1)=JMEM1
J1QN1(IRHO,2)=JMEM2
J1QN1(IRHO,3)=JMEM3
J1QN2(ISIG,1)=JMEM4
J1QN2(ISIG,2)=JMEM5
J1QN2(ISIG,3)=JMEM6
ANL=float(NOSH1(IRHO))*RPL
C
C RESULTS STORED IN VSHELL
C
IF(NTOT.EQ.0) NTOT=1
VSHELL(NTOT)=ANL*sqrt(AJF)
IF(NBUG6-1) 189,196,189
196 WRITE(IWRITE,215) IRHO,ANL
189 IRHO=IRHO+1
ISIG=ISIG+1
RPL=ZERO
IF(IRHO-IHSH) 109,109,190
190 IF(NBUG6-1) 192,13,192
13 WRITE(IWRITE,217) (VSHELL(N),N=1,NTOT)
192 RETURN
END
c
c---------------------------------------------------------------------
c e s t a t e
c---------------------------------------------------------------------
c
SUBROUTINE ESTATE(KCFG)
C
long LSYM,LANK,K1QN
long MMCORB,KKCORB,IAJCMP,LOCATE,JAJCMP
COMMON/INFORM/ IREAD,IWRITE,IPUNCH,icheck
COMMON/STATEM/MOCCSH(30),KOCCSH(30),MOCORB(10,30),KOCORB(10,30),
1MELCSH(10,30),KELCSH(10,30),M1QNRD(19,3,30),K1QNRD(19,3,30),MAXOR
2,MMCORB(10,30),KKCORB(10,30),IAJCMP(21),LOCATE(21),JAJCMP(21,3)
DIMENSION K1QN(19)
COMMON/SYMM/LANK,LSYM(10)
COMMON/TERMS/NROWS,ITAB(14),JTAB(14),NTAB(219),NTAB1(10,5),
1 NTAB2(11,5)
DIMENSION LJCOMP(21)
C
C DATA DEFINING THE EXCITED STATE IS READ IN AND PRINTED OUT.
C
611 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,30H : WRONG ORDERING OF SHELLS ,24x,
3/16H DATA CHECKING: )
612 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,42H : NUMBER OF ELECTRONS MORE THAN ALLOWED ,12x,
3/16H DATA CHECKING: )
613 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,30H : STATE GENERATED IS WRONG ,24x,
3/16H DATA CHECKING: )
614 FORMAT(/16H DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,36H : COUPLING ON THIS SHELL IS WRONG,18x,
3/16H DATA CHECKING: )
1 FORMAT(18(1X,I3))
5 FORMAT(5(1X,A3,1X,I2,1X))
6 FORMAT(9(1X,4X,I1,A1,I1))
24 FORMAT(//29H FINAL STATE CONFIGURATIONS:-)
25 FORMAT(/5H ,I3,3H. ,10(1X,A3,1H(,I2,1H)))
26 FORMAT(11X,10(1X,4X,I1,A1,I1))
27 FORMAT(22X,9(1X,4X,I1,A1,I1))
29 FORMAT( 29H -------------------------- /)
WRITE(IWRITE,24)
WRITE(IWRITE,29)
READ(IREAD,1) KCFG
READ(IREAD,1) (KOCCSH(I),I=1,KCFG)
DO 2 I=1,KCFG
N=KOCCSH(I)
READ(IREAD,5) (KKCORB(J,I),KELCSH(J,I),J=1,N)
WRITE(IWRITE,25) I,(KKCORB(J,I),KELCSH(J,I),J=1,N)
DO 61 J=1,N
DO 61 JJ=1,MAXOR
61 IF(KKCORB(J,I).EQ.IAJCMP(JJ)) KOCORB(J,I)=JJ
M=2*N-1
N1=N+1
READ(IREAD,6) (K1QNRD(J,3,I),K1QN(J),K1QNRD(J,1,I),J=1,M)
WRITE(IWRITE,26) (K1QNRD(J,3,I),K1QN(J),K1QNRD(J,1,I),J=1,N)
IF(N.EQ.1) GO TO 64
WRITE(IWRITE,27) (K1QNRD(J,3,I),K1QN(J),K1QNRD(J,1,I),J=N1,M)
64 CONTINUE
DO 62 J=1,M
DO 62 JJ=1,10
62 IF(K1QN(J).EQ.LSYM(JJ)) K1QNRD(J,2,I)=2*JJ-1
2 CONTINUE
C
C --- CHECK THE INPUT DATA OF THE CONFIGURATIONS(COUPLINGS) FOR ERRORS,
C --- IF ANY. ICHECK = THE NUMBER OF THE ERRORS FOUND IN THE DATA.
C
DO 1013 I=1,MAXOR
J=3
IF(JAJCMP(I,1).NE.LANK) J=2
DO 1012 JJ=1,9
1012 IF(JAJCMP(I,J).EQ.LSYM(JJ)) LJCOMP(I)=JJ-1
1013 CONTINUE
DO 1021 I=1,KCFG
N=KOCCSH(I)
JORB0=0
DO 1020 J=1,N
JORB=KOCORB(J,I)
LORB=LJCOMP(JORB)
NELACT=KELCSH(J,I)
NELMAX=4*LORB+2
IF(LORB.GE.3) NELMAX=2
NROW=NTAB2(NELACT+1,LORB+1)
NST=ITAB(NROW)
JT1=JTAB(NROW)
IS1=K1QNRD(J,3,I)
IL1=K1QNRD(J,2,I)
IV1=K1QNRD(J,1,I)
IF(J.EQ.1) GO TO 1014
J2=1
J3=N+1
IF(J.EQ.2) GO TO 1014
J2=N+J-2
J3=J2+1
C
C --- CHECKING THE ORDERING OF THE J-TH SHELL
C
1014 IF(JORB.GT.JORB0) GO TO 1015
ICHECK=ICHECK+1
WRITE(IWRITE,611) ICHECK,I,IAJCMP(JORB)
C
C ---- CHECKING THE NUMBER OF ELECTRONS IN THE J-TH SHELL
C
1015 IF(NELACT.LE.NELMAX) GO TO 1016
ICHECK=ICHECK+1
WRITE(IWRITE,612) ICHECK,I,IAJCMP(JORB)
GO TO 1018
C
C --- CHECKING THE STATE PRODUCED BY THE J-TH SHELL
C
1016 DO 1017 IST=1,NST
IF(IS1.NE.NTAB(JT1+3)) GO TO 1017
IF(IL1.NE.NTAB(JT1+2)) GO TO 1017
IF(IV1.EQ.NTAB(JT1+1)) GO TO 1018
1017 JT1=JT1+3
ICHECK=ICHECK+1
WRITE(IWRITE,613) ICHECK,I,IAJCMP(JORB)
C
C --- CHECK THE COUPLING ON THE J-TH SHELL
C
1018 IF(J.EQ.1) GO TO 1020
IS2=K1QNRD(J2,3,I)
IL2=K1QNRD(J2,2,I)
IS3=K1QNRD(J3,3,I)-1
IL3=K1QNRD(J3,2,I)-1
IF(IS3.GT.(IS1+IS2-2).OR.IS3.LT.(IABS(IS1-IS2))) GO TO 1019
IF(IL3.GT.(IL1+IL2-2).OR.IL3.LT.(IABS(IL1-IL2))) GO TO 1019
GO TO 1020
1019 ICHECK=ICHECK+1
WRITE(IWRITE,614) ICHECK,I,IAJCMP(JORB)
1020 JORB0=JORB
1021 CONTINUE
RETURN
END
c
c----------------------------------------------------------------------
c g s t a t e
c----------------------------------------------------------------------
c
SUBROUTINE GSTATE(MCFG)
C
long LSYM,LANK,M1QN
long MMCORB,KKCORB,IAJCMP,LOCATE,JAJCMP
COMMON/INFORM/ IREAD,IWRITE,IPUNCH,ICHECK
COMMON/STATEM/MOCCSH(30),KOCCSH(30),MOCORB(10,30),KOCORB(10,30),
1MELCSH(10,30),KELCSH(10,30),M1QNRD(19,3,30),K1QNRD(19,3,30),MAXOR
2,MMCORB(10,30),KKCORB(10,30),IAJCMP(21),LOCATE(21),JAJCMP(21,3)
DIMENSION M1QN(19)
COMMON/SYMM/LANK,LSYM(10)
COMMON/TERMS/NROWS,ITAB(14),JTAB(14),NTAB(219),NTAB1(10,5),
1 NTAB2(11,5)
common/dummy/ljcomp(21)
data ljcomp/21*0/
data mocorb/300*1/
c
c data defining the ground state is read in and printed out.
c
611 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,30H : WRONG ORDERING OF SHELLS ,24x,
3/16H DATA CHECKING: )
612 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,42H : NUMBER OF ELECTRONS MORE THAN ALLOWED,12x,
3/16H DATA CHECKING: )
613 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,30H : STATE GENERATED IS WRONG ,24x,
3/16H DATA CHECKING: )
614 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,
27h, SHELL,A3,36H : COUPLING ON THIS SHELL IS WRONG,18x,
3/16H DATA CHECKING: )
1 FORMAT(18(1X,I3))
5 format(10(1x,a3,1x,i2,1x))
6 FORMAT(9(1X,4X,I1,A1,I1))
24 FORMAT(//31H INITIAL STATE CONFIGURATIONS:-)
25 FORMAT(/5H ,I3,3H. ,10(1X,A3,1H(,I2,1H)))
26 FORMAT(11X,10(1X,4X,I1,A1,I1))
27 FORMAT(22X,9(1X,4X,I1,A1,I1))
28 FORMAT( 31H ---------------------------- /)
WRITE(IWRITE,24)
WRITE(IWRITE,28)
READ(IREAD,1) MCFG
READ(IREAD,1) (MOCCSH(I),I=1,MCFG)
DO 2 I=1,MCFG
N=MOCCSH(I)
READ(IREAD,5) (MMCORB(J,I),MELCSH(J,I),J=1,N)
WRITE(IWRITE,25) I,(MMCORB(J,I),MELCSH(J,I),J=1,N)
DO 61 J=1,N
DO 61 JJ=1,MAXOR
IF(MMCORB(J,I).EQ.IAJCMP(JJ)) MOCORB(J,I)=JJ
61 CONTINUE
M=2*N-1
N1=N+1
READ(IREAD,6) (M1QNRD(J,3,I),M1QN(J),M1QNRD(J,1,I),J=1,M)
WRITE(IWRITE,26) (M1QNRD(J,3,I),M1QN(J),M1QNRD(J,1,I),J=1,N)
IF(N.EQ.1) GO TO 64
WRITE(IWRITE,27) (M1QNRD(J,3,I),M1QN(J),M1QNRD(J,1,I),J=N1,M)
64 CONTINUE
DO 62 J=1,M
DO 62 JJ=1,10
62 IF(M1QN(J).EQ.LSYM(JJ)) M1QNRD(J,2,I)=2*JJ-1
2 CONTINUE
C
C --- CHECK THE INPUT DATA OF THE CONFIGURATIONS(COUPLINGS) FOR ERRORS,
C --- IF ANY. ICHECK = THE NUMBER OF THE ERRORS FOUND IN THE DATA.
C
DO 1013 I=1,MAXOR
J=3
IF(JAJCMP(I,1).NE.LANK) J=2
DO 1012 JJ=1,9
IF(JAJCMP(I,J).EQ.LSYM(JJ)) LJCOMP(I)=JJ-1
1012 CONTINUE
1013 CONTINUE
ICHECK=0
DO 1021 I=1,MCFG
N=MOCCSH(I)
JORB0=0
DO 1020 J=1,N
JORB=MOCORB(J,I)
LORB=LJCOMP(JORB)
NELACT=MELCSH(J,I)
NELMAX=4*LORB+2
IF(LORB.GE.3) NELMAX=2
C
NROW=NTAB2(NELACT+1,LORB+1)
if (nrow.eq.0) nrow=1
NST=ITAB(NROW)
JT1=JTAB(NROW)
IS1=M1QNRD(J,3,I)
IL1=M1QNRD(J,2,I)
IV1=M1QNRD(J,1,I)
IF(J.EQ.1) GO TO 1014
J2=1
J3=N+1
IF(J.EQ.2) GO TO 1014
J2=N+J-2
J3=J2+1
C
C --- CHECKING THE ORDERING OF THE J-TH SHELL
C
1014 IF(JORB.GT.JORB0) GO TO 1015
ICHECK=ICHECK+1
WRITE(IWRITE,611) ICHECK,I,IAJCMP(JORB)
C
C ---- CHECKING THE NUMBER OF ELECTRONS IN THE J-TH SHELL
C
1015 IF(NELACT.LE.NELMAX) GO TO 1016
ICHECK=ICHECK+1
WRITE(IWRITE,612) ICHECK,I,IAJCMP(JORB)
GO TO 1018
C
C --- CHECKING THE STATE PRODUCED BY THE J-TH SHELL
C
1016 DO 1017 IST=1,NST
IF(IS1.NE.NTAB(JT1+3)) GO TO 1017
IF(IL1.NE.NTAB(JT1+2)) GO TO 1017
IF(IV1.EQ.NTAB(JT1+1)) GO TO 1018
1017 JT1=JT1+3
ICHECK=ICHECK+1
WRITE(IWRITE,613) ICHECK,I,IAJCMP(JORB)
C
C --- CHECK THE COUPLING ON THE J-TH SHELL
C
1018 IF(J.EQ.1) GO TO 1020
IS2=M1QNRD(J2,3,I)
IL2=M1QNRD(J2,2,I)
IS3=M1QNRD(J3,3,I)-1
IL3=M1QNRD(J3,2,I)-1
IF(IS3.GT.(IS1+IS2-2).OR.IS3.LT.(IABS(IS1-IS2))) GO TO 1019
IF(IL3.GT.(IL1+IL2-2).OR.IL3.LT.(IABS(IL1-IL2))) GO TO 1019
GO TO 1020
1019 ICHECK=ICHECK+1
WRITE(IWRITE,614) ICHECK,I,IAJCMP(JORB)
1020 JORB0=JORB
1021 CONTINUE
RETURN
END
c
c-------------------------------------------------------------------
c s e t u p e
c-------------------------------------------------------------------
c
SUBROUTINE SETUPE(JA,JB,NJCOMP,LJCOMP)
C
DIMENSION NJCOMP(21),LJCOMP(21)
long MMCORB,KKCORB,IAJCMP,LOCATE,JAJCMP
COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH(10,2),J1QN(19,3,2),IJFUL(10)
1,JIFUL(10)
COMMON/STATEM/MOCCSH(30),KOCCSH(30),MOCORB(10,30),KOCORB(10,30),
1MELCSH(10,30),KELCSH(10,30),M1QNRD(19,3,30),K1QNRD(19,3,30),MAXOR
2,MMCORB(10,30),KKCORB(10,30),IAJCMP(21),LOCATE(21),JAJCMP(21,3)
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
J1=0
J2=0
IHSH=0
I2HSH=-1
IA=MOCCSH(JA)
IB=KOCCSH(JB)
C
C --- TEST ON WHETHER LIMIT OF I1 HAS BEEN REACHED
C
1 IF(I1-MAXOR ) 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-MOCORB(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-KOCORB(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 IF(I.GE.2) GO TO 38
NOSH(IHSH,I)=MELCSH(IC,JC)
DO 20 K=1,3
J1QN(IHSH,K,I)=M1QNRD(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=MOCCSH(JC)+IC-1
28 J1QN(I2HSH,K,I)=M1QNRD(I2,K,JC)
20 CONTINUE
GO TO 22
38 NOSH(IHSH,I)=KELCSH(ICE,JCE)
DO 30 K=1,3
J1QN(IHSH,K,I)=K1QNRD(ICE,K,JCE)
IF(IHSH.LE.1) GO TO 30
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
IF(ICE.GT.1) GO TO 31
I2=1
IF(K.NE.1) GO TO 32
J1QN(I2HSH,1,I)=0
GO TO 30
31 I2=KOCCSH(JCE)+ICE-1
32 J1QN(I2HSH,K,I)=K1QNRD(I2,K,JCE)
30 CONTINUE
22 IF(I-2) 23,24,24
23 NC=NB
I=2
ICE=J2
JCE=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
JIFUL(IHSH)=LOCATE(I1)
C
C --- RETURN TO 1 TO SEE IF MAXORB HAS BEEN REACHED
C
GO TO 1
100 RETURN
END
c
c--------------------------------------------------------------------
c t r i t s t
c--------------------------------------------------------------------
c
REAL FUNCTION TRITST(L,M,N)
c IMPLICIT REAL*8(A-H,O-Z)
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
C
C IF TRITST=ONE THE TRIANGLE RELATION IS NOT SATISFIED
C IF TRITST=ZERO THE TRIANGLE RELATION IS SATISFIED
C
LMN=IABS(L-M)
LM=L+M
IF(N-LMN) 1,2,2
2 IF(LM-N) 1,3,3
3 TRITST=ZERO
RETURN
1 TRITST=ONE
RETURN
END
c
c---------------------------------------------------------------------
c t m s o u t
c---------------------------------------------------------------------
c
SUBROUTINE TMSOUT
long LSYM,LANK,ICFG,LLSYM
COMMON/INFORM/IREAD,IWRITE,IPUNCH,icheck
common/terms/nrows,itab(14),jtab(14),ntab(219),ntab1(10,5),
1 ntab2(11,5)
DIMENSION LLSYM(46)
COMMON/SYMM/LANK,LSYM(10)
COMMON/ACFG/ICFG(14)
C
C --- PRINT-OUT OF TABLE OF TERMS, SET IN BLOCK DATA
C
1 FORMAT(1H1,41X,23HTABLE OF POSSIBLE TERMS //4x,
159h CONFIGURATION TERMS(MULTIPLICITY,SYMMETRY, AND SENIORITY) ,/)
4 FORMAT(/9X,A4,10X,16(I1,A1,I1,2X))
WRITE(IWRITE,1)
DO 5 I=1,NROWS
JI=JTAB(I)
JJ=3*ITAB(I)
JI1=JI+1
JI2=JI1+1
DO 2 J=1,JJ,3
LP=(NTAB(JI1+J )+1)/2
2 LLSYM(J)=LSYM(LP)
WRITE(IWRITE,4)ICFG(I),(NTAB(JI2+J),LLSYM(J),NTAB(JI+J),J=1,JJ,3)
5 CONTINUE
RETURN
END
c
c-----------------------------------------------------------------
c c f p
c-----------------------------------------------------------------
SUBROUTINE CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP)
c IMPLICIT REAL*8(A-H,O-Z)
COMMON/INFORM/IREAD,IWRITE,IPUNCH,icheck
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,7,6
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 IMPLICIT REAL*8(A-H,O-Z)
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
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 b l d a t a
c----------------------------------------------------------------
subroutine bldata
c
c IMPLICIT REAL*8(A-H,O-Z)
long LSYM,LANK,ISPINT,ISPINS,NVAL,ICFG
common/terms/nrows,i(14),j(14),n(219),n1(10,5),n2(11,5)
COMMON/SYMM/LANK,LSYM(10)
COMMON/NVALUE/NVAL(9)
COMMON/SPINP/ISPINT,ISPINS
COMMON/ACFG/ICFG(14)
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
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/14/
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, 7/
data i(13),i(14)/ 1, 9/
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 j(13),j(14)/ 189, 192/
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),N(172),N(173),N(174)/ 2, 3, 3, 2, 7, 3/
DATA N(175),N(176),N(177),N(178),N(179),N(180)/ 2,11, 3, 0, 1, 1/
DATA N(181),N(182),N(183),N(184),N(185),N(186)/ 2, 5, 1, 2, 9, 1/
DATA N(187),N(188),N(189),N(190),N(191),N(192)/ 2,13, 1, 1, 9, 2/
DATA N(193),N(194),N(195),N(196),N(197),N(198)/ 2, 3, 3, 2, 7, 3/
DATA N(199),N(200),N(201),N(202),N(203),N(204)/ 2,11, 3, 2,15, 3/
DATA N(205),N(206),N(207),N(208),N(209),N(210)/ 0, 1, 1, 2, 5, 1/
DATA N(211),N(212),N(213),N(214),N(215),N(216)/ 2, 9, 1, 2,13, 1/
DATA N(217),N(218),N(219) / 2,17, 1 /
DATA N1( 1,1),N1( 1,2),N1( 1,3),N1( 1,4),N1( 1,5)/2,2, 2, 2, 2/
DATA N1( 2,1),N1( 2,2),N1( 2,3),N1( 2,4),N1( 2,5)/1,3, 6,11,13/
DATA N1( 3,1),N1( 3,2),N1( 3,3),N1( 3,4),N1( 3,5)/0,4, 7, 0, 0/
DATA N1( 4,1),N1( 4,2),N1( 4,3),N1( 4,4),N1( 4,5)/0,5, 8, 0, 0/
DATA N1( 5,1),N1( 5,2),N1( 5,3),N1( 5,4),N1( 5,5)/0,4, 9, 0, 0/
DATA N1( 6,1),N1( 6,2),N1( 6,3),N1( 6,4),N1( 6,5)/0,3,10, 0, 0/
DATA N1( 7,1),N1( 7,2),N1( 7,3),N1( 7,4),N1( 7,5)/0,0, 9, 0, 0/
DATA N1( 8,1),N1( 8,2),N1( 8,3),N1( 8,4),N1( 8,5)/0,0, 8, 0, 0/
DATA N1( 9,1),N1( 9,2),N1( 9,3),N1( 9,4),N1( 9,5)/0,0, 7, 0, 0/
DATA N1(10,1),N1(10,2),N1(10,3),N1(10,4),N1(10,5)/0,0, 6, 0, 0/
DATA N2( 1,1),N2( 1,2),N2( 1,3),N2( 1,4),N2( 1,5)/2,2, 2, 2, 2/
DATA N2( 2,1),N2( 2,2),N2( 2,3),N2( 2,4),N2( 2,5)/1,3, 6,11,13/
DATA N2( 3,1),N2( 3,2),N2( 3,3),N2( 3,4),N2( 3,5)/2,4, 7,12,14/
DATA N2( 4,1),N2( 4,2),N2( 4,3),N2( 4,4),N2( 4,5)/0,5, 8, 0, 0/
DATA N2( 5,1),N2( 5,2),N2( 5,3),N2( 5,4),N2( 5,5)/0,4, 9, 0, 0/
DATA N2( 6,1),N2( 6,2),N2( 6,3),N2( 6,4),N2( 6,5)/0,3,10, 0, 0/
DATA N2( 7,1),N2( 7,2),N2( 7,3),N2( 7,4),N2( 7,5)/0,2, 9, 0, 0/
DATA N2( 8,1),N2( 8,2),N2( 8,3),N2( 8,4),N2( 8,5)/0,0, 8, 0, 0/
DATA N2( 9,1),N2( 9,2),N2( 9,3),N2( 9,4),N2( 9,5)/0,0, 7, 0, 0/
DATA N2(10,1),N2(10,2),N2(10,3),N2(10,4),N2(10,5)/0,0, 6, 0, 0/
DATA N2(11,1),N2(11,2),N2(11,3),N2(11,4),N2(11,5)/0,0, 2, 0, 0/
LANK=35322350018592
ISPINT=92496954662944
ISPINS=91397443035168
C
LSYM(1)=91397443035168
LSYM(2)=88098908151840
LSYM(3)=74904768618528
LSYM(4)=77103791874080
LSYM(5)=78203303501856
LSYM(6)=79302815129632
LSYM(7)=80402326757408
LSYM(8)=82601350012960
LSYM(9)=83700861640736
LSYM(10)=84800373268512
C
NVAL(1)=54014047690784
NVAL(2)=55113559318560
NVAL(3)=56213070946336
NVAL(4)=57312582574112
NVAL(5)=58412094201888
NVAL(6)=59511605829664
NVAL(7)=60611117457440
NVAL(8)=61710629085216
NVAL(9)=62810140712992
C
ICFG(1)=91432088576032
ICFG(2)=91432105353248
ICFG(3)=88133553692704
ICFG(4)=88133570469920
ICFG(5)=88133587247136
ICFG(6)=74939414159392
ICFG(7)=74939430936608
ICFG(8)=74939447713824
ICFG(9)=74939464491040
ICFG(10)=74939481268256
ICFG(11)=77138437414944
ICFG(12)=77138454192160
ICFG(13)=78237949042720
ICFG(14)=78237965819936
C
ZERO=0.E0
EPSILO=1.E-08
HALF=0.5E0
ONE=1.0E0
C
call cfpddata
return
END
C
C --- INSERT HERE THE FOLLOWING CPC LIBRARY PROGRAMS WITH APPROPRIATE
C CHANGES TO DOUBLE PRECISION FOR IBM S360 COMPUTER.
C
C (1) ACQB, THE P-SHELL CFP PROGRAM: ALLISON (CPC V1(1969)15).
C (2) ACRN, THE NEW D-SHELL CFP PROGRAM: CHIVERS (CPC V6(1973)88).
C (3) AAGD, THE NJSYM PROGRAM: BURKE (CPC V1(1970)241), ADAPTED
C FOR WEIGHTS USING AAGD0001: HIBBERT (CPC V2(1971)180)
C WITH AAGD0002: GRANT (CPC V5(1973)161) FOR IMPROVED
C RACAH COEFFICIENT ROUTINE.
C
C --- NOTE THAT THE CORRECTION AAGD000A: CPC V2(1971)173 IS ALSO
C TO BE APPLIED TO AAGD. ALSO NOTE THE THE ADAPTATION
C AAGD0002 OF GRANT WAS NOT APPLIED TO AAGD WHEN IT WAS
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,icheck
COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
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,icheck
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
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,icheck
COMMON/PARAM/ZERO,EPSILO,HALF,ONE
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,icheck
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
c16 format(37h fail in coefp at 8 unallowed state)
c8 write(iwrite,16)
8 continue
coepf=9.9
10 continue
RETURN
END
c
c------------------------------------------------------------------------
c c f p d d a t a
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/
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,icheck
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 coepf=9.9
c 106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE)
c 11 WRITE(IWRITE,106)
10 continue
RETURN
END
▶EOF◀