|
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: 71424 (0x11700)
Types: TextFile
Names: »per«, »per11«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »per«
└─⟦this⟧ »per11«
c program 11 aakp
c
c aakpreduced 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 external bldata
c
c IMPLICIT REAL*8(A-H,O-Z)
DIMENSION NJCOMP(21),LJCOMP(21),VSHELL(20)
COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9
COMMON/DIMEN/KFL1,KFL2,KFL3,KFL4,KFL5,KFL6
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:
3,27HPROCEEDING 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(1H*)
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
c set input and output channels
c
zone readf(150,1,stderror)
zone writef(150,1,stderror)
zone punchf(150,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call zassign(punchf,8)
call open(readf,4,'readf',0)
call open(writef,4,'writef',0)
call open(punchf,4,'punchf',0)
iread=1
c
KFL1=0
READ(IREAD,1) NCASES,IREAD,IWRITE
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
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
615 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.NE.1) WRITE(IWRITE,3) VSHELL(1),JI,JF,IAJCMP(JRHO),ISPINS
1,kb,IAJCMP(JSIG)
if(ispin.eq.2)write(iwrite,33) vshell(1),j1,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.NE.1) WRITE(IWRITE,3)VSHELL(IS),JI,JF,IAJCMP(JRHO),ISPINS
1,kb,IAJCMP(JRHO)
if(ispin.eq.2)write(iwrite,33)vshell(is),j1,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
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=DFLOAT(J1QN1(I2HSH,2))/DFLOAT(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
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,7H,
2SHELL,A3,54H : WRONG ORDERING OF SHELLS
3/16H DATA CHECKING: )
612 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : NUMBER OF ELECTRONS MORE THAN ALLOWED
3/16H DATA CHECKING: )
613 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : STATE GENERATED IS WRONG
3/16H DATA CHECKING: )
614 FORMAT(/16H DATA CHECKING:
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : COUPLING ON THIS SHELL IS WRONG
3/16H DATA CHECKING: )
1 FORMAT(18(1X,I3))
5 FORMAT(5(1X,A3,1H(,I2,1H)))
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
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
2 CONTINUE
RETURN
END
c
c----------------------------------------------------------------------
c g s t a t e
c----------------------------------------------------------------------
c
SUBROUTINE GSTATE(MCFG)
C
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)
DIMENSION LJCOMP(21)
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,7H,
2SHELL,A3,54H : WRONG ORDERING OF SHELLS
3/16H DATA CHECKING: )
612 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : NUMBER OF ELECTRONS MORE THAN ALLOWED
3/16H DATA CHECKING: )
613 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : STATE GENERATED IS WRONG
3/16H DATA CHECKING: )
614 format(/16h DATA CHECKING: ,
1/16H DATA CHECKING: ,12HERROR NUMBER,I2,15H, CONFIGURATION,I3,7H,
2SHELL,A3,54H : COUPLING ON THIS SHELL IS WRONG
3/16H DATA CHECKING: )
1 FORMAT(18(1X,I3))
5 FORMAT(5(1X,A3,1H(,I2,1H)))
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
61 IF(MMCORB(J,I).EQ.IAJCMP(JJ)) MOCORB(J,I)=JJ
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
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
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
NROW=NTAB2(NELACT+1,LORB+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
2 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)
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
COMMON/INFORM/IREAD,IWRITE,IPUNCH,icheck
common/terms/nrows,itab(14),jtabs(14),ntabs(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,41X23HTABLE OF POSSIBLE TERMS //4x,62H CONFIGURATION
1N 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
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)
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/
DATA LANK,ISPINT,ISPINS/1H ,1HT,1HS/
DATA LSYM(1),LSYM(2),LSYM(3),LSYM(4),LSYM(5),LSYM(6),LSYM(7)
1 ,LSYM(8),LSYM(9),LSYM(10)/1HS,1HP,1HD,1HF,1HG,1HH,1HI,1HK,1HL
2 ,1HM/
DATA NVAL(1),NVAL(2),NVAL(3),NVAL(4),NVAL(5),NVAL(6),NVAL(7)
1 ,NVAL(8),NVAL(9)/1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ICFG(1),ICFG(2),ICFG(3),ICFG(4),ICFG(5),ICFG(6),ICFG(7)
1 ,ICFG(8),ICFG(9),ICFG(10),ICFG(11),ICFG(12),ICFG(13),ICFG(14)/
2 4HS(1),4HS(2),4HP(1),4HP(2),4HP(3),4HD(1),4HD(2),4HD(3),
3 4HD(4),4HD(5),4HF(1),4HF(2),4HG(1),4HG(2)/
data zero,epsilo,half,one/0.e0,1.e-08,0.5e0,1.e0/
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 USED BY ROBB IN THE PREVIOUS VERSION OF THIS PROGRAM.
▶EOF◀