atsp/004077500002010000036000000000000631543042700114225ustar00cffcsf00000400000020atsp/src/004077500002010000036000000000000632023250400122015ustar00cffcsf00000400000020atsp/src/ANG.f010064400002010000036000002017060623374500400127650ustar00cffcsf00000400000020* * Routines for MCHF_LIB_ANG * * C O P Y R I G H T -- 1994 * * Computer Physics Communication, Vol. 64, 399-405 (1991) * * NOTE: This file contains routines for programs using one atomic * state and two atomic states as in transitions. The COMMONS * are different, thus there will be warning messages if this * file compiled without first using fsplit. * ------------------------------------------------------------------ * A N A L Y S E 1 * ------------------------------------------------------------------ * SUBROUTINE ANALY1(IREAD,IWRITE,NCLOSD,MAXORB,N,NCFG,NOCCSH,LIST, : NCD) * * This routine analyzes the format of the configuration input * data and determines a consistent ordering of the electrons * PARAMETER (NWD=30) INTEGER NOCCSH(NCD),AFTER(NWD,NWD),IEL(5) CHARACTER LIST(NWD)*3, LINE*72, OF(NWD)*3, EL(5)*3 * 1 FORMAT(A72) * DO 2 I = 1,(NWD) DO 3 J = 1,(NWD) AFTER(I,J) = 0 3 CONTINUE 2 CONTINUE * * --- Determine the number of common closed subshells * READ(IREAD,'(/A72)' ) LINE NCLOSD = 0 J = 2 10 IF (LINE(J:J+2) .NE. ' ' ) THEN NCLOSD = NCLOSD + 1 J = J+4 IF (J .LT. 72) GO TO 10 END IF * * --- Determine the number or configurations and electrons * MAXORB = 0 NCFG = N 20 READ(IREAD,1,END=55) LINE IF (LINE(1:1) .NE. '*' .AND. LINE(2:2) .NE. '*' ) THEN * * ------ A new configuration has been read; find the electrons * NCFG = NCFG + 1 IF (NCFG .GT. NCD ) : WRITE(IWRITE,'(A,I5)') ' TOO MANY CONFIGURATIONS: MAX=',NCD J = 2 I = 0 30 IF (LINE(J:J+2) .NE. ' ' .AND. I.LT.(5)) THEN * * --------- An electron has been found; is it a new one? * I = I+1 EL(I) = LINE(J:J+2) K = 1 40 IF (K .LE. MAXORB) THEN IF ( OF(K) .NE. EL(I) ) THEN K = K+1 IF (K .GT. NWD) THEN WRITE(IWRITE,*) ' TOO MANY ELECTRONS: MAX=',NWD STOP END IF GO TO 40 ELSE IEL(I) = K END IF ELSE * * ------------ A new electron has been found; add it to the list * MAXORB = K OF(MAXORB) = EL(I) IEL(I) = K END IF J = J+8 GO TO 30 END IF NOCCSH(NCFG) = I * * ------ Add data to the AFTER matrix * DO 50 I1 = 2,I DO 51 I2 = 1,I1-1 AFTER(IEL(I1),IEL(I2)) = 1 51 CONTINUE 50 CONTINUE READ(IREAD,*) IF (I .GT. 5) READ(IREAD,*) GO TO 20 END IF * * --- Check if the ordering of the electrons is inconsistent * 55 DO 60 I = 1,MAXORB DO 61 J = 1,MAXORB IF (AFTER(I,J) .EQ. 1 .AND. AFTER(J,I) .EQ. 1) THEN WRITE(IWRITE,*) ' The order of ',OF(I),' and ', : OF(J),' is inconsistent' STOP END IF 61 CONTINUE 60 CONTINUE * * --- Reorder the electrons to satisfy the after relations found * in the different configurations * IORD = 1 70 IF (IORD .LE. MAXORB ) THEN * * ------ Search for a row with no 1's * DO 71 I = 1,MAXORB DO 72 J = 1,MAXORB IF (AFTER(I,J) .EQ. 1 ) GO TO 71 72 CONTINUE * * --------- The current row contains all 0's or 2's * IF (AFTER(I,I) .NE. 2 ) THEN * * ------------ We have the next electron; delete the corresponding * rows and columns from the AFTER matrix * LIST(IORD) = OF(I) IORD = IORD+1 DO 73 J = 1,MAXORB AFTER(I,J) = 2 AFTER(J,I) = 2 73 CONTINUE GO TO 70 END IF 71 CONTINUE END IF RETURN END * * ------------------------------------------------------------------ * A N A L Y S 2 * ------------------------------------------------------------------ * SUBROUTINE ANALY2(NCLOSI,NCLOSF,MCFG,KCFG,LIST,LORTH) * * This routine analyzes the format of the configuration input * data, for two sets, not necessarily orthogonal. * PARAMETER (NWD=30,NWD2=2*NWD,NCD=100,NCD4=4*NCD) INTEGER AFTER(3*NWD,3*NWD),IEL(5),NORB(2),NCLOS(2),ICFG(2) CHARACTER*3 LIST(*), LINE*72, OF(NWD,2), ELC(NWD), EL(5), FIND CHARACTER*7 LABEL(2) CHARACTER*6 ANS LOGICAL LORTH COMMON/INFORM/ IREADI,IWRITE,IOUT,IREADF,ISC(7) COMMON/STATES/NCFG,MAXORB,IAJCMP(2*NWD),LJCOMP(2*NWD), :NJCOMP(2*NWD),NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4), :J1QNRD(9,NCD4) COMMON/NOR/NCOM,NORBI,NORBF,IWAR DATA LABEL/'Initial','Final '/ * 1 FORMAT(A72) 4 FORMAT(/10H THERE ARE,I3,' INITIAL STATE ORBITALS AS FOLLOWS: '/ : (1X,18(1X,A3))) 5 FORMAT(/10H THERE ARE,I3,' FINAL STATE ORBITALS AS FOLLOWS: '/ : (1X,18(1X,A3))) 6 FORMAT(' List common orbitals, terminating with a blank orbital.'/ : ' Upper and lower case characters must match.'/ : ' Fixed format (18(1X,A3)) as inicated below:'/ : ' AAA AAA AAA AAA AAA AAA AAA .... etc (up to 18/line)') 7 FORMAT(18(1X,A3)) 8 FORMAT(/10H THERE ARE,I3,' COMMON ORBITALS AS FOLLOWS: '/ : (1X,18(1X,A3))) * DO 2 I = 1,(3*NWD) DO 3 J = 1,(3*NWD) AFTER(I,J) = 0 3 CONTINUE 2 CONTINUE * IREAD = IREADI NCFG = 0 DO 100 ISTATE = 1,2 * * --- Determine the number of common closed subshells * READ(IREAD,'(/A72)' ) LINE NCLO = 0 J = 2 10 IF (LINE(J:J+2) .NE. ' ' ) THEN NCLO = NCLO + 1 J = J+4 IF (J .LT. 72) GO TO 10 END IF NCLOS(ISTATE) = NCLO * * --- Determine the number or configurations and electrons * IORB = 0 20 READ(IREAD,1,END=55) LINE IF (LINE(1:1) .NE. '*' .AND. LINE(2:2) .NE. '*' ) THEN * * ------ A new configuration has been read; find the electrons * NCFG = NCFG + 1 IF (NCFG .GT. (NCD4) ) THEN WRITE(IWRITE,*) ' TOO MANY CONFIGURATIONS: MAX=',NCD4 STOP END IF J = 2 I = 0 30 IF (LINE(J:J+2) .NE. ' ' .AND. I.LT.(5)) THEN * * --------- An electron has been found; is it a new one? * I = I+1 EL(I) = LINE(J:J+2) K = 1 40 IF (K .LE. IORB) THEN IF ( OF(K,ISTATE) .NE. EL(I) ) THEN K = K+1 IF (K .GT. (NWD)) THEN WRITE(IWRITE,*) ' TOO MANY ELECTRONS: MAX=',NWD STOP END IF GO TO 40 ELSE IEL(I) = K END IF ELSE * * ------------ A new electron has been found; add it to the list * IORB = K OF(IORB,ISTATE) = EL(I) IEL(I) = K END IF J = J+8 GO TO 30 END IF NOCCSH(NCFG) = I * * ------ Add data to the AFTER matrix * DO 50 I1 = 2,I DO 51 I2 = 1,I1-1 J1 = (NWD)*ISTATE + IEL(I1) J2 = (NWD)*ISTATE + IEL(I2) AFTER(J1,J2) = 1 51 CONTINUE 50 CONTINUE READ(IREAD,*) GO TO 20 END IF 55 NORB(ISTATE) = IORB ICFG(ISTATE) = NCFG IREAD = IREADF 100 CONTINUE * * --- SET PARAMETERS * NORBI = NORB(1) NORBF = NORB(2) * * --- DETERMINE THE COMMON INITIAL/FINAL STATE ORBITALS * WRITE(0,4) NORBI,(OF(I,1),I=1,NORBI) WRITE(0,5) NORBF,(OF(I,2),I=1,NORBF) ANS = 'Y' IF (.NOT. LORTH) THEN WRITE(0,'(/A)') : ' Initial & final state orbitals an orthonormal set ? (Y/N) ' READ(5,'(A1)') ANS END IF IF ( ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN DO 53 I = 1,NORBI ELC(I) = OF(I,1) 53 CONTINUE NCOM = NORBI * * --- ADD OTHERS FROM FINAL STATE * DO 54 I = 1,NORBF DO 56 J = 1,NORBI IF (OF(I,2) .EQ. OF(J,1)) GO TO 54 56 CONTINUE NCOM = NCOM + 1 IF (NCOM .GT. (NWD)) : STOP ' Too many common electrons: MAX=(30)' ELC(NCOM) = OF(I,2) 54 CONTINUE ELSE WRITE(0,6) READ(5,7) (ELC(I),I=1,18) IF (ELC(18) .NE. ' ') READ(5,7) (ELC(I),I=19,(NWD)) NCOM = 0 52 IF (ELC(NCOM+1) .NE. ' ') THEN NCOM = NCOM + 1 IF (NCOM .LT. (NWD)) GO TO 52 END IF END IF WRITE(0,'(//)') * * --- Transfer electrons to common orthogonal set * DO 200 ISTATE = 1,2 IORIG = (NWD)*ISTATE LAST = NORB(ISTATE) DO 201 I=1,NCOM * * Find electron and transfer AFTER information * J = 1 202 IF (J .LE. LAST) THEN IF (ELC(I) .NE. OF(J,ISTATE) ) THEN J = J+1 GO TO 202 ELSE II = IORIG + J DO 210 K = 1, IORIG+LAST IF (AFTER(I,K) .EQ. 0) AFTER(I,K) = AFTER(II,K) IF (AFTER(K,I) .EQ. 0) AFTER(K,I) = AFTER(K,II) AFTER(II,K) = 2 AFTER(K,II) = 2 210 CONTINUE NORB(ISTATE) = NORB(ISTATE) - 1 END IF ELSE WRITE(0,*) ' Common electron ',ELC(I),' not found in ', : LABEL(ISTATE),' state' END IF 201 CONTINUE 200 CONTINUE * * --- Check if the ordering of the electrons is inconsistent * DO 60 I = 1,(NWD)*3 EL(1) = FIND(I,OF,ELC) DO 61 J = 1,(NWD)*3 EL(2) = FIND(J,OF,ELC) IF (AFTER(I,J) .EQ. 1 .AND. AFTER(J,I) .EQ. 1) THEN WRITE(0,*) ' The order of ',EL(1),' and ', : EL(2),' is inconsistent' STOP END IF 61 CONTINUE 60 CONTINUE * * --- Reorder the electrons to satisfy the after relations found * in the different configurations * IORD = 1 70 IF (IORD .LE. NCOM ) THEN * * ------ Search for a row with no 1's in the NCOM rows * DO 71 I = 1,NCOM DO 72 J = 1,(NWD)*2+NORBF IF (AFTER(I,J) .EQ. 1 ) GO TO 71 72 CONTINUE * * --------- The current row contains all 0's or 2's * IF (AFTER(I,I) .NE. 2 ) THEN * * ------------ We have the next electron; delete the corresponding * rows and columns from the AFTER matrix * LIST(IORD) = ELC(I) IORD = IORD+1 DO 74 J = 1,(NWD)*2+NORBF AFTER(I,J) = 2 AFTER(J,I) = 2 74 CONTINUE GO TO 70 END IF 71 CONTINUE END IF IF (IORD .NE. NCOM+1) THEN * * SEARCH FOR THE ELECTRON NOT INCLUDED * DO 73 I = 1,NCOM IF (AFTER(I,I) .NE. 2) THEN DO 75 J = (NWD)+1,(NWD)*2+NORBF IF (AFTER(I,J) .EQ. 1) THEN WRITE(0,*) ELC(I),' cannot be included in the common set' IL = 1 IF ( J .GT. (NWD)*2 ) IL = 2 WRITE(0,*) ' Occurs AFTER ',FIND(J,OF,ELC),' in ', : LABEL(IL),' state' STOP END IF 75 CONTINUE END IF 73 CONTINUE END IF * * --- ORDER THE REMAINING ELECTRONS FOR THE INITIAL AND FINAL STATE * LAST = NCOM LASTEL = NORBI DO 300 ISTATE = 1,2 LAST = LAST + NORB(ISTATE) 304 IF (IORD .LE. LAST) THEN IORIG = (NWD)*ISTATE DO 301 I = IORIG+1, IORIG+LASTEL DO 302 J = 1,IORIG+LASTEL IF (AFTER(I,J) .EQ. 1) GO TO 301 302 CONTINUE * * The current row contains no 1's * IF (AFTER(I,I) .NE. 2) THEN * * We have the next electron * IF (IORD.GT.(2*NWD)) THEN WRITE(IWRITE,*) ' Too many electrons: MAX=',2*NWD STOP END IF LIST(IORD) = OF(I-IORIG,ISTATE) IORD = IORD+1 DO 303 J = 1,IORIG+LASTEL AFTER(I,J) = 2 AFTER(J,I) = 2 303 CONTINUE GO TO 304 END IF 301 CONTINUE END IF LASTEL = NORBF 300 CONTINUE * NORBI = NORB(1) NORBF = NORB(2) NCLOSI = NCLOS(1) NCLOSF = NCLOS(2) MCFG = ICFG(1) KCFG = ICFG(2) - MCFG IF (NCOM .GT. 0) WRITE(IWRITE,8) NCOM,(LIST(I),I=1,NCOM) WRITE(IWRITE,4) NORBI,(LIST(I),I=NCOM+1,NCOM+NORBI) NOR11 = NCOM + NORBI WRITE(IWRITE,5) NORBF,(LIST(I),I=NOR11+1,NOR11+NORBF) RETURN END * * ------------------------------------------------------------------ * C F G I N 2 * ------------------------------------------------------------------ * SUBROUTINE CFGIN2(MCFG,KCFG,LORTH,INPUT) * * Read two sets of configurations and determine the orthogonality * conditions between them * IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD4=4*NCD) CHARACTER*3 EL(2*NWD), ELC(NWD), JAJCMP(2*NWD,3)*1 CHARACTER INPUT(2)*24,HEADI*72,HEADF*72,HEADER*72 LOGICAL LORTH COMMON/INFORM/ IREADI,IWRITE,IOUT,IREADF,ISC(7) COMMON/STATES/NCFG,MAXORB,IAJCMP(2*NWD),LJCOMP(2*NWD), :NJCOMP(2*NWD),NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4), :J1QNRD(9,NCD4) COMMON/NOR/NCOM,NORBI,NORBF,IWAR * 3 FORMAT(18(1X,A3)) 7 FORMAT(A72) 22 FORMAT(// 7H STATE ,' (WITH',I3,' CONFIGURATIONS):'/1H ,31(1H-)/) 23 FORMAT(/10H THERE ARE,I3,21H ORBITALS AS FOLLOWS:// 1 5X,21(1X,A3):/5X,21(1X,A3)) * * The "readonly" option is needed on some computers when the * two files are in fact the same. Others ignore the option * which is OK in most cases. * Microsoft Fortran requires "READ" instead of "READONLY" * OPEN(UNIT=1,FILE=INPUT(1),STATUS='OLD',READONLY) * OPEN(UNIT=2,FILE=INPUT(2),STATUS='OLD',READONLY) OPEN(UNIT=1,FILE=INPUT(1),STATUS='OLD') OPEN(UNIT=2,FILE=INPUT(2),STATUS='OLD') * * --- ANALYZE INITIAL AND FINAL STATE DATA * CALL ANALY2(NCLOSI,NCLOSF,MCFG,KCFG,EL,LORTH) REWIND(UNIT=IREADI) REWIND(UNIT=IREADF) * MAXORB = NCOM + NORBI + NORBF * SET UP THE ELECTRONS * READ(EL,'(A3)') (IAJCMP(I),I=1,MAXORB) READ(EL,'(3A1)')((JAJCMP(I,J),J=1,3),I=1,MAXORB) * * SET UP OF LJCOMP * DO 60 I = 1,MAXORB IF (JAJCMP(I,1) .EQ. ' ') THEN JAJCMP(I,1) = JAJCMP(I,2) JAJCMP(I,2) = JAJCMP(I,3) JAJCMP(I,3) = ' ' ENDIF LJCOMP(I) = LVAL(JAJCMP(I,2)) NJCOMP(I) = ICHAR(JAJCMP(I,1)) - ICHAR('1') + 1 60 CONTINUE * * ---- CHECK COMMON CLOSED SHELLS * IF (NCLOSI .NE. NCLOSF) : STOP ' Common closed shells not the same in the two states' * READ(IREADI,7) HEADI READ(IREADF,7) HEADF HEADER = HEADI(1:34)//'=>'//HEADF(1:34) WRITE(IOUT,7) HEADER * * --- CHECK CLOSED SHELLS FURTHER * READ(IREADI,3) (ELC(I),I=1,NCLOSI) READ(IREADF,3) (EL(I),I=1,NCLOSF) DO 1 I = 1,NCLOSF J = 1 2 IF (EL(I) .NE. ELC(J) ) THEN J = J+1 IF (J .LE. NCLOSI) THEN GO TO 2 ELSE STOP ' Common closed sub-shells not the same' END IF END IF 1 CONTINUE * * MAXORB < 2*NWD+1... LINKED TO JAJCMP(2*NWD,3) * IAJCMP(2*NWD) * LJCOMP(2*NWD) * NJCOMP(2*NWD) * THE DIMENSION OF IORTH IS GIVEN BY THE PRODUCT OF THE ALLOWED * NORBI AND NORBF, I.E. ACTUALLY NWD by NWD = NWD^2 * * * GET INITIAL STATE CONFIGURATIONS * CALL GSTATE(1,MCFG) * * MCFG1 = MCFG + 1 NCFG = MCFG + KCFG CALL GSTATE(MCFG1,NCFG) * * --- CHECK THE DATA * CALL CFGTST(NCFG,LJCOMP,NOCCSH,NELCSH,NOCORB,J1QNRD,NCD4) RETURN END * * ------------------------------------------------------------------ * C F G N 1 * ------------------------------------------------------------------ * * Read the configurations for a state and determine the * non-orthogonal orbitals * SUBROUTINE CFGN1(INPUT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100) * CHARACTER BUFFER*3 CHARACTER*1 JAJCMP(NWD,3), INPUT*24 COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC1, :JSC2,JSC3 COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU, : ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP, : IORTH(NWD*(NWD-1)/2) COMMON/STATES/NCFG,MAXORB,IAJCMP(NWD),LJCOMP(NWD), :NJCOMP(NWD),NOCCSH(NCD),NELCSH(5,NCD),NOCORB(5,NCD),J1QNRD(9,NCD) INTEGER IEL(2),IBUFF(2) DATA IASTER,IBLANK/3H* ,3H / * CALL CFGO1(NCFG,MAXORB,IAJCMP,LJCOMP,NJCOMP,NOCCSH,NELCSH, : NOCORB,J1QNRD,NCD,INPUT) * * --- SEPARATE THE ELECTRON LABEL CHARACTERS AND LEFT JUSTIFY * DO 10 I = 1,MAXORB WRITE(BUFFER,'(A3)') IAJCMP(I) READ(BUFFER,'(3A1)') (JAJCMP(I,J),J=1,3) IF (JAJCMP(I,1) .EQ. ' ') THEN JAJCMP(I,1) = JAJCMP(I,2) JAJCMP(I,2) = JAJCMP(I,3) JAJCMP(I,3) = ' ' END IF 10 CONTINUE * * --- INITIALIZE THE ORTHOGONALITY ARRAY * M1 = (MAXORB*(MAXORB-1))/2 DO 20 I = 1,M1 IORTH(I) = -1 20 CONTINUE * * --- SET ORBITALS IN THE SAME CONFIGURATION TO BE ORTHOGONAL * DO 63 I = 1,NCFG N = NOCCSH(I) DO 66 J = 1,N-1 DO 66 JJ = J+1,N I1 = NOCORB(J,I) J1 = NOCORB(JJ,I) IF (J1 .GT. I1) THEN M = I1 I1 = J1 J1 = M ENDIF IORTH(J1+((I1-1)*(I1-2))/2) = 0 66 CONTINUE 63 CONTINUE * * --- DETERMINE THE NON-ORTHOGONAL ORBITALS * NORTH = 0 DO 18 J = 1,MAXORB-1 DO 19 I = J+1,MAXORB IJ = J + ((I-1)*(I-2))/2 IF (JAJCMP(I,2) .EQ. JAJCMP(J,2) .AND. : JAJCMP(I,3) .NE. ' ' .AND. : JAJCMP(J,3) .NE. ' ' .AND. : JAJCMP(I,3) .NE. JAJCMP(J,3) .AND. : IORTH(IJ) .NE. 0 ) THEN NORTH = NORTH + 1 IORTH(IJ) = 1 ENDIF 19 CONTINUE 18 CONTINUE * READ(IREAD,*,END=90) 79 READ(IREAD,'(2(1X,A3))',END=90) IBUFF(1),IBUFF(2) IF (IBUFF(1) .NE. IASTER .AND. IBUFF(1) .NE. IBLANK) THEN DO 80 I = 1,2 DO 81 J = 1,MAXORB IF (IBUFF(I) .EQ. IAJCMP(J)) THEN IEL(I) = J GO TO 80 ENDIF 81 CONTINUE WRITE(*,'(A,A3,A)') ' ELECTRON ',IBUFF(I),' NOT FOUND' STOP 80 CONTINUE IF (IEL(1) .GT. IEL(2) ) THEN I = IEL(1) IEL(1) = IEL(2) IEL(2) = I END IF IJ = IEL(1) + ((IEL(2)-1)*(IEL(2)-2))/2 IF (IORTH(IJ) .EQ. 1) NORTH = NORTH - 1 IORTH(IJ) = 0 WRITE(IWRITE,'(1X,A3,A,A3)') : IBUFF(1),' is orthogonal to ',IBUFF(2) GO TO 79 END IF 90 RETURN END * * ------------------------------------------------------------------ * C F G O 1 * ------------------------------------------------------------------ * * Read configurations for one state, assuming orthogonality of * the orbitals * SUBROUTINE CFGO1(NCFG,MAXORB,IAJCMP,LJCOMP,NJCOMP,NOCCSH, : NELCSH,NOCORB,J1QNRD,NCD,INPUT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30) * CHARACTER BUFFER(NWD)*3, HEADER*72, INPUT*24 CHARACTER*1 JAJCLD(NWD,3),JAJCMP(NWD,3),JCQN(9) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC(3) COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK * DIMENSION IAJCMP(NWD),LJCOMP(NWD),NJCOMP(NWD),NOCCSH(NCD), : NELCSH(5,NCD),NOCORB(5,NCD),J1QNRD(9,NCD), : J3QN(9),J2QN(9),J1QN(9) * 3 FORMAT(18(1X,A3)) 4 FORMAT(3A1) 5 FORMAT(9(1X,A3,1H(,I2,1H))) 6 FORMAT(9(1X,4X,I1,A1,I1)) 7 FORMAT(A72) 8 FORMAT(A3) 22 FORMAT(// 7H STATE ,' (WITH',I3,' CONFIGURATIONS):'/1H ,31(1H-)/) 23 FORMAT(/10H THERE ARE,I3,21H ORBITALS AS FOLLOWS:// : 5X,21(1X,A3):/5X,21(1X,A3)) 25 FORMAT(/14H CONFIGURATION,I3,' ( OCCUPIED ORBITALS=',I2,' ):' : ,5(1X,A3,1H(,I2,1H))) 26 FORMAT(26X,17H COUPLING SCHEME:,5(1X,4X,I1,A1,I1)) 27 FORMAT(54X,4(1X,4X,I1,A1,I1)) 28 FORMAT(/10H THERE ARE ,I3,31H CLOSED SUBSHELLS COMMON TO ALL , : 27H CONFIGURATIONS AS FOLLOWS: // : 5X, 21(1X,A3)) * * --- ANALYZE INPUT DATA * OPEN(UNIT=4,FILE=INPUT,STATUS='OLD') CALL ANALY1(IREAD,IWRITE,NCLOSD,MAXORB,0,NCFG,NOCCSH,BUFFER,NCD) REWIND(UNIT=IREAD) * * --- Process the configuration data * READ(BUFFER,8) (IAJCMP(I),I=1,MAXORB) WRITE(IWRITE,22) NCFG WRITE(IWRITE,23) MAXORB,(IAJCMP(I),I=1,MAXORB) READ(BUFFER,4)((JAJCMP(I,J),J=1,3),I=1,MAXORB) DO 60 I=1,MAXORB IF (JAJCMP(I,1) .EQ. ' ') THEN JAJCMP(I,1) = JAJCMP(I,2) JAJCMP(I,2) = JAJCMP(I,3) JAJCMP(I,3) = ' ' ENDIF LJCOMP(I) = LVAL(JAJCMP(I,2)) NJCOMP(I) = ICHAR(JAJCMP(I,1)) - ICHAR('1') + 1 60 CONTINUE * * --- READ HEADER CARD FOR THE CASE * READ(IREAD,7) HEADER WRITE(IOUT,7) HEADER * * --- READ IN THE COMMON SET OF CLOSED SUBSHELLS * READ(IREAD,3) (BUFFER(I),I=1,NCLOSD) IF (NCLOSD .EQ. 0) GO TO 70 READ(BUFFER,8) (IAJCLD(I),I=1,NCLOSD) WRITE(IWRITE,28) NCLOSD,(IAJCLD(I),I=1,NCLOSD) READ(BUFFER,4) ((JAJCLD(I,J),J=1,3),I=1,NCLOSD) DO 71 I=1,NCLOSD J = 3 IF (JAJCLD(I,1) .NE. ' ') J = 2 LJCLSD(I) = LVAL(JAJCLD(I,J)) 71 CONTINUE 70 CONTINUE * * --- READ IN (AND PRINT OUT) CONFIGURATIONS ETC. FOR THE STATE UNDER * --- CONSIDERATION * DO 63 I=1,NCFG N=NOCCSH(I) READ(IREAD,5) (NOCORB(J,I),NELCSH(J,I),J=1,N) WRITE(IWRITE,25) I,N,(NOCORB(J,I),NELCSH(J,I),J=1,N) DO 61 J=1,N DO 61 JJ=1,MAXORB 61 IF(NOCORB(J,I).EQ.IAJCMP(JJ)) NOCORB(J,I)=JJ M=2*N-1 N1=N+1 READ(IREAD,6) (J3QN(J),JCQN(J),J1QN(J),J=1,M) WRITE(IWRITE,26) (J3QN(J),JCQN(J),J1QN(J),J=1,N) IF(N.GT.1) WRITE(IWRITE,27) (J3QN(J),JCQN(J),J1QN(J),J=N1,M) DO 62 J=1,M J2QN(J) = 2*LVAL(JCQN(J)) + 1 J1QNRD(J,I) = (J3QN(J)*64 + J2QN(J))*64 + J1QN(J) 62 CONTINUE 63 CONTINUE CALL CFGTST(NCFG,LJCOMP,NOCCSH,NELCSH,NOCORB,J1QNRD,NCD) RETURN END * * ------------------------------------------------------------------ * C F G T S T * ------------------------------------------------------------------ * SUBROUTINE CFGTST(NCFG,LJCOMP,NOCCSH,NELCSH,NOCORB,J1QNRD,NCD) * * THIS SUBROUTINE CHECKS ALL THE CONFIGURATION SET TO ENSURE THAT * IT SATISFIES ALL THE FOLLOWING CONDITIONS: * (1) EACH CONFIGURATION HAS THE SAME NUMBER OF ELECTRONS * (2) NO SUBSHELL HAS TOO MANY (.GT.2*(2*L+1)) ELECTRONS * (3) THE ELECTRONS IN ANY ONE SUBSHELL ARE COUPLED TO FORM AN * ALLOWED TRIAD OF QUANTUM NUMBERS * (4) THE TRIADS COUPLE TOGETHER IN AN ALLOWED WAY * * IN THE EVENT OF AN ERROR, THE PROGRAM HALTS AT THE COMPLETION * OF THE CHECKING. ANY NUMBER OF S, P, D ELECTRONS ARE ALLOWED, * (BUT .LE.2*(2*L+1)), BUT ONLY UP TO TWO ELECTRONS, L >=3. * WHEN L>4, THE ONLY ALLOWED TERMS ARE THOSE FOR L=4. * A FILLED F-SHELL IS ALSO ALLOWED AS WELL AS A SINGLE ELECTRON * WITH L.GT.4 * COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC(3) COMMON/TERMS/NROWS,ITAB(24),JTAB(24),NTAB(333) * DIMENSION LJCOMP(*),NOCCSH(NCD),NELCSH(5,NCD),NOCORB(5,NCD), : J1QNRD(9,NCD) * 5 FORMAT(/38H THE TRIAD OF QUANTUM NUMBERS OF SHELL,I3,17H IN CONFIG :URATION,I3,24H IS NOT A RECOGNIZED SET) 7 FORMAT(/22H THE COUPLING OF SHELL,I3,17H IN CONFIGURATION,I3, : 38H RESULTS IN AN ILLEGAL COUPLING SCHEME) 12 FORMAT(//41H CONFIGURATION DATA WRONG, PROGRAM HALTED//) 15 FORMAT(/17H IN CONFIGURATION,I3,7H, SHELL,I3,28H CONTAINS TOO MANY : ELECTRONS) 17 FORMAT(/14H CONFIGURATION,I3,68H INCLUDES A SHELL OF ANGULAR MOMEN :TUM L.GE.3 WITH TOO MANY ELECTRONS) 18 FORMAT(/14H CONFIGURATION,I3,28H HAS AN INCORRECT NUMBER OF , : 9HELECTRONS) * IALLOW=1 DO 1 I=1,NCFG NELSUM = 0 N=NOCCSH(I) DO 2 J=1,N NA=NOCORB(J,I) LQU=LJCOMP(NA) NC=NELCSH(J,I) NELSUM = NELSUM + NC JD = J1QNRD(J,I) JA = MOD(JD,64) JD = JD/64 JB = MOD(JD,64) JC = JD/64 LQUMAX = 4*LQU + 2 IF (NC .GT. LQUMAX) THEN WRITE(IWRITE,15) I,J IALLOW = 0 GO TO 2 ELSE IF ((LQU.EQ.3 .AND. NC.GT.2 .AND. NC.LT.14) .OR. : (LQU.GT.4.AND.NC.GT.2)) THEN WRITE(IWRITE,17) I IALLOW = 0 GO TO 2 ELSE IF (NC .EQ. 1) THEN IF (JA.EQ.1 .AND. JB.EQ.(2*LQU+1) .AND. JC.EQ.2) GO TO 21 ELSE IF (LQU .GT. 4 .AND. NC .EQ. 2) LQU = 4 IF (NC .EQ. LQUMAX) THEN NROW = 2 ELSE NROW = NTAB1(NC+1,LQU+1) END IF I1 = ITAB(NROW) I2 = JTAB(NROW) DO 4 IA = 1,I1 I3 = I2+3*IA-1 IF (JB .EQ. NTAB(I3)) THEN I3 = I3+1 IF (JC .EQ. NTAB(I3)) THEN I3 = I3-2 IF (JA .EQ. NTAB(I3)) GO TO 21 END IF END IF 4 CONTINUE END IF IALLOW = 0 WRITE(IWRITE,5) J,I GO TO 2 * * CHECK ON THE COUPLING OF THE TRIADS * 21 IF (N.GT.1 .AND. J.GT.1) THEN J2 = N+J-1 J1 = J2-1 IF (J.EQ.2) J1 = 1 JE = J1QNRD(J1,I)/64 JD = MOD(JE,64) JE = JE/64 JG = J1QNRD(J2,I)/64 JF = MOD(JG,64) JG = JG/64 IF (JF.GE.(JB+JD) .OR. JF.LE.IABS(JB-JD) .OR. : JG.GE.(JC+JE) .OR. JG.LE.IABS(JC-JE) .OR. : MOD(JC+JE-JG,2).EQ.0 ) THEN WRITE(IWRITE,7) J,I IALLOW = 0 END IF END IF 2 CONTINUE IF (I .EQ. 1) THEN NELCS = NELSUM ELSE IF (NELSUM .NE. NELCS) THEN WRITE(IWRITE,18) I IALLOW = 0 END IF 1 CONTINUE IF (IALLOW .EQ. 0) THEN WRITE(IWRITE,12) STOP END IF END * * ------------------------------------------------------------------ * B L O C K D A T A * ------------------------------------------------------------------ * BLOCK DATA INITT * COMMON/KRON/IDEL(10,10) COMMON/TERMS/NROWS,I(24),J(24),N(333) * * --- SETS QUANTUM NUMBERS OF TERMS WHICH CAN BE FORMED FROM * CONFIGURATIONS L**Q . ONLY THE FIRST HALF OF THAT PART OF THE * TABLE, CORRESPONDING TO A GIVEN L, IS INCLUDED, BECAUSE OF THE * SYMMETRY OF THE TABLE. E.G. D**7 FORMS THE SAME TERMS AS D**3 * * The tables are set for a maximum value of L=9; the terms * for L>3 are assumed to be the same as those for L=3 * * S - SHELLS (ROWS 1 AND 2) * * P - SHELLS (ROWS 3 TO 5) * * D - SHELLS (ROWS 6 TO 10) * * F - SHELLS (ROWS 11 AND 12) * * G - SHELLS (ROWS 13 AND 14) * * H - SHELLS (ROWS 15 AND 16) * * I - SHELLS (ROWS 17 AND 18) * * K - SHELLS (ROWS 19 AND 20) * * L - SHELLS (ROWS 21 AND 22) * * M - SHELLS (ROWS 23 AND 24) * DATA NROWS/24/ * * THE ARRAYS I,J,N CORRESPOND TO THE ARRAYS ITAB,JTAB,NTAB * DATA I/1,1, 1,3,3, 1,5,8,16,16, 1,7, 1,7, 1,7, 1,7, 1,7, 1,7, 1,7/ DATA J/0,3, 6,9,18, 27,30,45,69,117, 165,168, 189,192, : 213,216, 237,240, 261,264, 285,288, 309,312/ DATA N/1,1,2, 0,1,1, 1,3,2, 0,1,1, 2,5,1, 2,3,3, 1,3,2, : 3,5,2, 3,1,4, 1,5,2, 0,1,1, 2,5,1, 2,9,1, 2,3,3, 2,7,3, : 1,5,2, 3,3,2, 3,5,2, 3,7,2, 3,9,2, 3,11,2, 3,3,4, 3,7,4, : 0,1,1, 2,5,1, 2,9,1, 2,3,3, 2,7,3, 4,1,1, 4,5,1, 4,7,1, 4,9,1, : 4,13,1, 4,3,3, 4,5,3, 4,7,3, 4,9,3, 4,11,3, 4,5,5, : 1,5,2, 3,3,2, 3,5,2, 3,7,2, 3,9,2, 3,11,2, 3,3,4, 3,7,4, 5,1,2, : 5,5,2, 5,7,2, 5,9,2, 5,13,2, 5,5,4, 5,9,4, 5,1,6, : 1,7,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,9,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,11,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,13,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,15,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,17,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1, : 1,19,2, 2,3,3, 2,7,3, 2,11,3 ,0,1,1, 2,5,1, 2,9,1 ,2,13,1/ * * --- READ IN OTHER INITIALIZATION DATA * DATA IDEL/1,10*0,1,10*0,1,10*0,1,10*0,1,10*0,1,10*0,1,10*0, : 1,10*0,1,10*0,1/ * END * * ------------------------------------------------------------------ * C F P * ------------------------------------------------------------------ * SUBROUTINE CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) * MicroSoft FORTRAN does not allow the EXTERNAL declaration here EXTERNAL INITT * * === CHOOSES APPROPRIATE FRACTIONAL PARENTAGE SUBROUTINE * 9 FORMAT(69H UNNECESSARY ATTEMPT TO FORM CFP OF AN S-ELECTRON - THER :E IS AN ERROR) K=LIJ+1 IF (K .GT. 4) K = 4 * * IF F-SHELL OR G-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINES * ARE INCLUDED, THIS COMPUTED GO TO NEEDS MODIFYING TO ACCOUNT FOR * THIS * GO TO (1,2,3,4,4) K * * --- FALSE CALL FOR S-SHELLS * 1 WRITE(IWRITE,9) STOP * * --- P-SHELLS * 2 CALL CFPP(N,ILI,ISI,ILJ,ISJ,COEFP) RETURN * * --- D-SHELLS * 3 CALL CFPD(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) RETURN * * --- F-SHELLS, G-SHELLS ETC. WITH UP TO TWO ELECTRONS * 4 CALL CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) RETURN END * * ------------------------------------------------------------------ * C F P D * ------------------------------------------------------------------ * SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP) IMPLICIT DOUBLE PRECISION(A-H,O-Z) * * * THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE * FOR EQUIVALENT D SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER * QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960) * IN THE SUBROUTINE LIST N,THE NO.OF ELECTRONS,V THE SENIORITY QUAN * TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM * NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT * PARAMETERS THE RESULT IS OUTPUT AS COEFP * * COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) DIMENSION IV(5,16),IL(5,16),IS(5,16), : ITAB1(5,1),ITAB2(8,5),ITAB3(16,8),ITAB4(16,16), : NORM1(5),NORM2(8),NORM3(16),NORM4(16) DATA IV/1,2,3,4,5,0,2,3,4,5,0,2,3,4,3,0,2,3,2,5,0,0,3,4,3,0,0,1,4, : 5,0,0,3,2,3,0,0,3,4,3,0,0,0,4,5,0,0,0,2,3,0,0,0,4,5,0,0,0,4,1, :0,0,0,2,3,0,0,0,4,5,0,0,0,0,3,0,0,0,4,5/ DATA IL/2,3,3,2,0,0,1,1,5,4,0,4,5,4,3,0,2,4,3,2,0,0,3,3,1,0,0,2,2, : 6,0,0,2,1,5,0,0,1,1,4,0,0,0,6,4,0,0,0,4,3,0,0,0,4,3,0,0,0,3,2, : 0,0,0,2,2,0,0,0,2,2,0,0,0,0,1,0,0,0,0,0/ DATA IS/2,3,4,5,6,0,3,4,3,4,0,1,2,3,4,0,1,2,3,4,0,1,2,3,4,0,0,2,3, : 2,0,0,2,3,2,0,0,2,3,2,0,0,0,1,2,0,0,0,1,2,0,0,0,1,2,0,0,0,1,2, : 0,0,0,1,2,0,0,0,1,2,0,0,0,1,2,0,0,0,1,2/ DATA ITAB1/1,1,1,1,1/ DATA ITAB2/4,-7,-1,21,7,-21,21,-8,-1,-8,0,0,28,-9,-49,7,0,0,1,11, : -25,-9,-25,0,0,0,0,-10,-10,-5,45,15,0,0,0,0,0,16,0,0/ DATA ITAB3/7,20,-560,224,-112,-21,-56,16,0,0,0,0,0,0,0,0,3,0,0,-56 : ,-448,49,-64,-14,0,0,0,0,0,0,0,0,0,26,308,110,220,0,0,0,7,-154, : -28,-132,0,0,0,0,0,-9,297,90,-405,45,0,0,3,66,-507,-3,-60,15, : 0,0,0,5,315,-14,-175,-21,-56,-25,0,70,385,-105,28,63,0,0,0,0, : 0,315,0,0,135,0,0,189,0,0,105,0,1,0,0,0,200,15,120,60,-35,10,0, : -25,88,200,45,20,0,1,0,0,0,16,-200,-14,-14,25,0,0,0,120,-42,42, : 0,0/ DATA ITAB4/1,-105,-175,-175,-75,12*0,154,-110,0,0,231,286,924,-308 : ,220,-396,6*0,-66,-90,180,0,99,-99,891,-5577,-405,-9,0,45,45,0, : 0,0,0,224,0,-56,0,-220,1680,0,112,0,-21,21,0,-16,0,0,-70,14,-84 : ,56,0,55,945,4235,-175,-315,0,-21,189,-25,0,0,25,-15,-135,35,0, : 0,600,968,120,600,0,60,60,10,3,0,0,-56,0,-64,4*0,448,0,-9,-49, : 0,14,0,0,0,-16,126,14,4*0,-200,360,0,-14,126,25,0,5*0,-175,182, : -728,-2184,7*0,6*0,220,880,0,-400,0,-9,-25,0,0,0,5*0,-45,-5,845 : ,-1215,275,495,0,-11,99,0,0,6*0,33,-7,-2541,105,-525,0,35,35, : -15,0,7*0,-800 ,0,-160,0,-5,45,0,30,0,7*0,-100,1452,180,-100,0, : -10,90,15,-2,11*0,6,16*0,-14,-56,0,0/ DATA NORM1/1,1,1,1,1/ DATA NORM2/5,15,2,42,70,60,140,30/ DATA NORM3/10,60,1680,840,1680,210,360,90,10,504,1008,560,280,140, : 1,1/ DATA NORM4/1,420,700,700,300,550,1100,8400,18480,2800,2800,50,350, : 700,150,5/ * * READ IN D SHELL PARAMETERS AND TABLES * PERIPHERAL 1 IS THE CARD READER * * TEST IF N IS IN THE FIRST HALF OF SHELL * 99 IF(N-6) 40,103,103 * * TEST IF STATE IN QUESTION IS ALLOWED * IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1 * 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 * * TEST IF PARENT STATE IS ALLOWED * IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2 * 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 * * SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL * 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 * * IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2) * 100 GO TO (1,2,3,4,5,12,12,12,12,1),N 1 COEFP = 1.0D0 GO TO 10 2 COEFP = ITAB1(J1,J2) IF(COEFP) 60,10,81 60 COEFP = - DSQRT(-COEFP/NORM1(J1)) GO TO 10 81 COEFP = DSQRT(COEFP/NORM1(J1)) GO TO 10 3 COEFP = ITAB2(J1,J2) IF(COEFP) 61,10,82 61 COEFP = -DSQRT(-COEFP/NORM2(J1)) GO TO 10 82 COEFP = DSQRT(COEFP/NORM2(J1)) GO TO 10 4 COEFP = ITAB3(J1,J2) IF(COEFP) 62,10,83 62 COEFP = -DSQRT(-COEFP/NORM3(J1)) GO TO 10 83 COEFP = DSQRT(COEFP/NORM3(J1)) GO TO 10 5 COEFP = ITAB4(J1,J2) IF(COEFP) 63,10,84 63 COEFP = -DSQRT(-COEFP/NORM4(J1)) GO TO 10 84 COEFP = DSQRT(COEFP/NORM4(J1)) GO TO 10 * * USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF * SHELL * 12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ) FACTOR = DSQRT(DFLOAT((11-N)*ISJ*(2*LJ+1))/DFLOAT(N*ISI*(2*LI+1))) M1 =N-5 GO TO(6,7,8,9),M1 6 COEFP = ITAB4(J2,J1) IF(COEFP) 64,10,85 64 COEFP = -DSQRT(-COEFP/NORM4(J2)) GO TO 86 85 COEFP = DSQRT(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 = -DSQRT(-COEFP/NORM3(J2)) GO TO 89 88 COEFP = DSQRT(COEFP/NORM3(J2)) 89 COEFP = COEFP * ISIGN * FACTOR GO TO 10 8 COEFP = ITAB2(J2,J1) IF(COEFP) 66,10,90 66 COEFP = -DSQRT(-COEFP/NORM2(J2)) GO TO 91 90 COEFP = DSQRT(COEFP/NORM2(J2)) 91 COEFP = COEFP * ISIGN * FACTOR GO TO 10 9 COEFP = ITAB1(J2,J1) IF(COEFP) 67,10,92 67 COEFP = -DSQRT(-COEFP/NORM1(J2)) GO TO 93 92 COEFP = DSQRT(COEFP/NORM1(J2)) 93 COEFP = COEFP * ISIGN * FACTOR GO TO 10 * * AN UNALLOWED STATE OR AN UNALLOWED PARENT * 11 WRITE(IWRITE,1111) 1111 FORMAT(' ERROR IN SUBROUTINE CFPD - THE STATE OR IT''S PARENT IS N :OT ALLOWED') CALL EXIT 10 CONTINUE RETURN END * * ------------------------------------------------------------------ * C F P F * ------------------------------------------------------------------ * SUBROUTINE CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IMPLICIT DOUBLE PRECISION(A-H,O-Z) * * THIS IS A DUMMY SUBROUTINE TO CALCULATE CFP OF F-ELECTRONS. IT IS * VALID ONLY FOR ONE OR TWO ELECTRONS IN THE F-SHELL UNDER * CONSIDERATION. * COEFP=1.D0 RETURN END * * ------------------------------------------------------------------ * C F P P * ------------------------------------------------------------------ * SUBROUTINE CFPP(N,LI,ISI,LJ,ISJ,COEFP) IMPLICIT DOUBLE PRECISION(A-H,O-Z) * * THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE * FOR EQUIVALENT P SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER * QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960) * IN THE SUBROUTINE LIST N,THE NO. OF ELECTRONS,L THE ANGULAR * MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM NO. OF BOTH THE STATE * IN QUESTION AND ITS PARENT STATE ARE INPUT PARAMETERS.THE RESULT * IS OUTPUT AS COEFP * COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) DIMENSION IL(3,3),IS(3,3),ITAB1(3,1),ITAB2(3,3),NORM1(3),NORM2(3) DATA IS(1,2),IS(1,3)/0,0/ DATA IL(1,2),IL(1,3)/0,0/ * * * SET UP P SHELL PARAMETERS AND TABLES * DATA IL(1,1),IL(2,1),IL(2,2),IL(2,3),IL(3,1),IL(3,2),IL(3,3)/1,1,2 : ,0,0,2,1/ DATA IS(1,1),IS(2,1),IS(2,2),IS(2,3),IS(3,1),IS(3,2),IS(3,3)/2,3,1 : ,1,4,2,2/ DATA ITAB1(1,1),ITAB1(2,1),ITAB1(3,1)/1,1,1/ DATA ITAB2(1,1),ITAB2(1,2),ITAB2(1,3),ITAB2(2,1),ITAB2(2,2),ITAB2( : 2,3),ITAB2(3,1),ITAB2(3,2),ITAB2(3,3)/1,0,0,1,-1,0,-9,-5,4/ DATA NORM1(1),NORM1(2),NORM1(3)/1,1,1/ DATA NORM2(1),NORM2(2),NORM2(3)/1,2,18/ * * TEST IF N IS IN THE FIRST HALF OF SHELL * 99 IF(N-4) 40,103,103 * * TEST IF STATE IN QUESTION IS ALLOWED * IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1 * 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 * * TEST IF PARENT STATE IS ALLOWED * IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2 * 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 * * SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL * 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 * * * IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2) * 100 GO TO (1,2,3,4,4,1),N 1 COEFP = 1.D0 GO TO 10 2 COEFP = ITAB1(J1,J2) IF(COEFP) 54,10,31 54 COEFP = -DSQRT(-COEFP/NORM1(J1)) GO TO 10 31 COEFP = DSQRT(COEFP/NORM1(J1)) GO TO 10 3 COEFP = ITAB2(J1,J2) IF(COEFP) 55,10,32 55 COEFP = -DSQRT(-COEFP/NORM2(J1)) GO TO 10 32 COEFP =DSQRT(COEFP/NORM2(J1)) GO TO 10 * * USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF * SHELL * 4 ISIGN = (-1)**((ISI+ISJ-5)/2+LI+LJ) FACTOR=DFLOAT((7-N)*ISJ*(2*LJ+1))/DFLOAT(N*ISI*(2*LI+1)) IF(N-5) 56,5,8 56 COEFP = ITAB2(J2,J1) IF(COEFP) 57,10,33 57 COEFP = -DSQRT(-COEFP/NORM2(J2)) GO TO 34 33 COEFP = DSQRT(COEFP/NORM2(J2)) 34 COEFP = COEFP * ISIGN * DSQRT(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 = -DSQRT(-COEFP/NORM1(J2)) GO TO 37 36 COEFP = DSQRT(COEFP/NORM1(J2)) 37 COEFP = COEFP * ISIGN * DSQRT(FACTOR) GO TO 10 * * AN UNALLOWED STATE OR AN UNALLOWED PARENT * 8 WRITE(IWRITE,8888) 8888 FORMAT(' ERROR IN SUBROUTINE CFPP - THE STATE OR IT''S PARENT IS N :OT ALLOWED') CALL EXIT 10 CONTINUE RETURN END * * ------------------------------------------------------------------ * N T A B 1 * ------------------------------------------------------------------ * FUNCTION NTAB1(NELCTS,K) INTEGER IROW(0:9) DATA IROW/0,2,5,10,12,14,16,18,20,22/ * * THIS SUBROUTINE CALCULATES THE ROW OF NTAB CORRESPONDING TO THE * PARENTS WHICH MAY GIVE RISE TO THE TERM ASSOCIATED WITH SHELL * LAMBDA . E.G. IF WE SEEK THE ROW OF NTAB CONTAINING THE PARENTS * OF ONE OF THE P**3 TERMS, THE ROW = VALUE OF NTAB1 IS THAT * CONTAINING THE P**2 TERMS * * USE IS MADE OF THE FACT THAT THE LIST OF POSSIBLE PARENTS (SEE * WHITE - ATOMIC SPECTRA - APPENDIX) IS SYMMETRICAL ABOUT THE * CONFIGURATION L**(2L+1) * * * --- FOR ONE ELECTRON IN A TERM, THE PARENT IS ALWAYS A SINGLET S TERM * IF (NELCTS .EQ. 1) THEN NTAB1 = 2 ELSE NPAR = NELCTS - 1 L = K-1 LHALF = 2*L+1 IF (NPAR .GT. LHALF) NPAR = 2*LHALF - NPAR NTAB1 = IROW(L) + NPAR END IF END * * ------------------------------------------------------------------ * M U M D A D * ------------------------------------------------------------------ * SUBROUTINE MUMDAD(II,IJ,IK,M,X) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH(10,2),J1QN(19,3,2),IJFUL(10) COMMON/INTERM/J1B(10,3,2),J1T(3,2) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC1, :JSC2,JSC3 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL * * NOTICE THE NAMES IN THE COMMON BLOCKS. SEE SETUP FOR DESCRIPTION * * --- CALLS AND EVALUATES FRACTIONAL PARENTAGE COEFFICIENTS * 10 FORMAT(8H COEFP =,F15.9) X=1.0D0 LIJ=LJ(IJ) IF(LIJ) 12,12,11 12 IF(M)4,5,4 11 N=NOSH(IJ,II) IVI=J1QN(IJ,1,II) ILI=(J1QN(IJ,2,II)-1)/2 ISI=J1QN(IJ,3,II) * * IF M=0 THERE ARE QUANTUM NUMBERS WITH TILDES TO CONSIDER * IF(M) 1,2,1 1 IVJ=J1B(IJ,1,II) ILJ=(J1B(IJ,2,II)-1)/2 ISJ= J1B(IJ,3,II) GO TO 3 2 IVJ=J1T(1,II) ILJ=(J1T(2,II)-1)/2 ISJ=J1T(3,II) 3 CALL CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IF(IBUG2.GT.0) WRITE(IWRITE,10) COEFP X=X*COEFP IF(DABS(X).LT.1.D-14) GO TO 5 4 LIJ=LJ(IK) IF(LIJ) 5,5,14 14 IF(M) 6,7,6 6 N=NOSH(IK,II) IVI=J1QN(IK,1,II) ILI=(J1QN(IK,2,II)-1)/2 ISI=J1QN(IK,3,II) IVJ = J1B(IK,1,II) ILJ =(J1B(IK,2,II)-1)/2 ISJ = J1B(IK,3,II) GO TO 8 7 N=NOSH(IJ,II)-1 IVI=IVJ ILI=ILJ ISI=ISJ IVJ=J1B(IJ,1,II) ILJ=(J1B(IJ,2,II)-1)/2 ISJ = J1B(IJ,3,II) 8 CALL CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IF(IBUG2.GT.0) WRITE(IWRITE,10) COEFP X=X*COEFP 5 CONTINUE RETURN END * * ------------------------------------------------------------------ * F I N D * ------------------------------------------------------------------ * CHARACTER*3 FUNCTION FIND (I,OF,EL) * * --- THIS ROUTINE FINDS ELECTRONS IN ONE OF THREE LISTS * PARAMETER (NWD=30) CHARACTER*3 OF(NWD,2),EL(NWD) * IF ( I .LE. (NWD)) THEN FIND = EL(I) ELSE IF ( I .LE. (NWD)*2 ) THEN FIND = OF(I-(NWD),1) ELSE FIND = OF(I-2*(NWD),2) END IF RETURN END * * ------------------------------------------------------------------ * G S T A T E * ------------------------------------------------------------------ * SUBROUTINE GSTATE(NFIRST,NLAST) PARAMETER (NWD=30,NCD=100,NWD2=2*NWD,NCD4=4*NCD) * COMMON/INFORM/ IREADI,IWRITE,IOUT,IREADF,ISC(7) COMMON/STATES/NCFG,MAXORB,IAJCMP(NWD2),LJCOMP(NWD2),NJCOMP(NWD2), :NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4),J1QNRD(9,NCD4) COMMON/NOR/NCOM,NORBI,NORBF,IWAR CHARACTER*1 JCQN(9) DIMENSION J1QN(9),J2QN(9),J3QN(9) CHARACTER*8 LABEL(2) DATA LABEL/'INITIAL','FINAL'/ * * DATA DEFINING THE STATE IS READ IN AND PRINTED OUT. * 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 ---------------------------- /) 29 FORMAT(//29H FINAL STATE CONFIGURATIONS:-) 30 FORMAT(2X,'ELECTRON ',A3,' NOT FOUND IN THE LIST OF ELECTRONS', : ' FOR THE ',A8,' STATE') IF (NFIRST .EQ. 1) THEN WRITE(IWRITE,24) IREAD =IREADI ELSE WRITE(IWRITE,29) IREAD = IREADF END IF WRITE(IWRITE,28) DO 2 I=NFIRST,NLAST N=NOCCSH(I) READ(IREAD,5) (NOCORB(J,I),NELCSH(J,I),J=1,N) K=I IF(NFIRST.NE.1) K=I-NFIRST+1 WRITE(IWRITE,25) K,(NOCORB(J,I),NELCSH(J,I),J=1,N) NCOM1 = NCOM + 1 NOR11 = NCOM1 + NORBI DO 61 J=1,N DO 63 JJ = 1,MAXORB IF (NFIRST .EQ. 1 .AND. JJ .GE. NOR11) GO TO 65 IF(NFIRST .NE. 1 .AND. JJ .GE. NCOM1 .AND. JJ .LT. NOR11) GO TO 63 IF(NOCORB(J,I).EQ.IAJCMP(JJ)) THEN NOCORB(J,I) = JJ GO TO 61 END IF 63 CONTINUE * * ELECTRON NOT FOUND IN THE LIST * 65 WRITE(IWRITE,30) NOCORB(J,I),LABEL(NFIRST) STOP 61 CONTINUE M=2*N-1 N1=N+1 READ(IREAD,6) (J3QN(J),JCQN(J),J1QN(J),J=1,M) WRITE(IWRITE,26) (J3QN(J),JCQN(J),J1QN(J),J=1,N) IF(N.EQ.1) GO TO 64 WRITE(IWRITE,27) (J3QN(J),JCQN(J),J1QN(J),J=N1,M) 64 CONTINUE DO 62 J=1,M J2QN(J) = 2*LVAL(JCQN(J)) + 1 62 J1QNRD(J,I)= (J3QN(J)*64 + J2QN(J))*64 + J1QN(J) 2 CONTINUE RETURN END * * ------------------------------------------------------------------ * O R T H * * ------------------------------------------------------------------ * SUBROUTINE ORTH * * Determine the orthogonality between initial and final state * IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD4=4*NCD) COMMON/STATES/NCFG,MAXORB,IAJCMP(2*NWD),LJCOMP(2*NWD), :NJCOMP(2*NWD),NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4), :J1QNRD(9,NCD4) COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU, 1 ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP, 2 IORTH(NWD*NWD) COMMON/NOR/NCOM,NORBI,NORBF,IWAR * * SET UP OF IORTH VECTOR * THE COMMON SET (NCOM) IS ASSUMED TO BE ORTHOGONAL TO BOTH * NORBI AND NORBF SETS * IF (NORBI .EQ. 0) RETURN M1 = NORBI*NORBF DO 70 I = 1,M1 IORTH(I) = 0 70 CONTINUE NORTH = 0 * * | 1....NCOM | NCOM1.....NOR1 | NOR11.....NOR2| * | NCOM | NORBI | NORBF | * | <= NWD | <= NWD | <=NWD | * * THIS LIMITATION IS LINKED TO THE DIMENSION OF BUFFER(NWD) IN * ANALYSE SUBROUTINE, where <= stands for LESS THAN or EQUAL. * NCOM1 = NCOM+1 NOR1 = NCOM + NORBI NOR11 = NOR1 + 1 NOR2 = NOR1 + NORBF DO 78 J = NCOM1,NOR1 DO 79 I = NOR11,NOR2 IJ = NORBF*(J-NCOM1) + I - NOR1 IF (LJCOMP(I) .EQ. LJCOMP(J)) THEN NORTH = NORTH + 1 IORTH(IJ) = 1 ENDIF 79 CONTINUE 78 CONTINUE RETURN END * ------------------------------------------------------------------ * T E N S O R * ------------------------------------------------------------------ * SUBROUTINE TENSOR(KA,KB,ISPIN,IRHO,ISIG,VSHELL) * IMPLICIT REAL *8(A-H,O-Z) PARAMETER(KFL1=60,KFL2=12) * * * W. D. ROBB - NOVEMBER 1971 * * Modified by C. FROESE FISCHER for use with NJGRAF * ************************************************************************ * * A ROUTINE FOR THE EVALUATION OF ANGULAR AND SPIN FACTORS IN THE * REDUCED MATRIX ELEMENT OF ANY ONE-ELECTRON TENSOR OPERATOR BETWEEN * ARBITRARILY COUPLED L-S CONFIGURATIONS * * * ** NOTE THAT THE DEFINITIONS OF TENSOR OPERATORS USED ARE THOSE * OF FANO AND RACAH, IRREDUCIBLE TENSORIAL SETS, ACADEMIC PRESS 1959 * ************************************************************************ * * DIMENSION STATEMENTS * DIMENSION J2STO(KFL2,3),J3STO(KFL2,3),JMEM(119),VSHELL(20) LOGICAL FAIL,FREE * * COMMON BLOCKS * COMMON/COUPLE/MN1,M0,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(7),IALL COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3) : ,J1QN2(19,3),IJFUL(10) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/TERMS/NROWS,ITAB(24),JTAB(24),NTAB(333) * 203 FORMAT(//7H NJ,LJ ,10(I6,I3)) 204 FORMAT(//6H NOSH ,10I4) 205 FORMAT(//6H J1QN ,30I3) 207 FORMAT(8F15.8) 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=,D20.8) 214 FORMAT(///23H SPIN RECOUPLING COEFF=,D20.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, : 3H IS,F15.8) 220 FORMAT(//6H SHELL,I2) 302 FORMAT(/5X,89H NO CONTRIBUTION FROM TENSOR SINCE MORE THAN ONE ELE :CTRON DIFFERENT IN THE CONFIGURATIONS/) 303 FORMAT(/5X,114H NO CONTRIBUTION FROM TENSOR SINCE THE TRIANGLE REL :ATION BETWEEN KA AND THE TOTAL ANGULAR MOMENTA IS NOT SATISFIED/) 313 FORMAT(19H SPECTATOR SUBSHELL,I3,69H HAS DIFFERENT QUANTUM NUMBERS : ON THE TWO SIDES OF THE MATRIX ELEMENT/) * AJF=1.D0 RML=0.D0 RPL=0.D0 NTOT=0 DO 100 IS=1,IHSH VSHELL(IS)=0.D0 100 CONTINUE IHSHP1=IHSH+1 I2HSH=IHSH*2-1 * * PRINT OUT THE OCCUPATION AND COUPLING ARRAYS * 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) * * TEST FOR AT MOST ONE ELECTRON DIFFERENCE IN CONFIGURATIONS * 101 NOSHUM=0 DO 102 K=1,IHSH NOSHUM=NOSHUM+IABS(NOSH1(K)-NOSH2(K)) 102 CONTINUE IF(NOSHUM.GT.2) GO TO 300 * * TEST FOR TRIANGLE RELATION BETWEEN KA AND TOTAL ANGULAR MOMENTA * 103 IF(ISPIN.EQ.0) GO TO 198 K=3 KC=KB IF(ISPIN.EQ.2) GO TO 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(DABS(BTST).GT.1.D-14) GO TO 301 IF(K.EQ.2.OR.ISPIN.LT.2) GO TO 104 K=2 KC=KA GO TO 199 * * DETERMINE IRHO AND ISIGMA, THE NUMBERS OF THE OCCUPIED SHELLS * 104 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 * * THE BEGINNING OF THE LOOP OVER ALL SHELLS * 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=J1QN1(I2HSH,3)/2.D0 IF(ISPIN.EQ.2) AJF=AJF*J1QN1(I2HSH,3)/2.D0 * * CHECK THE DIAGONAL CHARACTER OF QUANTUM NUMBERS OF SPECTATOR * SHELLS * 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(NBUG7.EQ.1) WRITE(IWRITE,313) J IF(IRHO.NE.ISIG) GO TO 190 GO TO 189 258 IF(IRHO-ISIG) 120,111,120 * * FIND THE PARENT TERMS GIVEN BY ALLOWED J VALUES IN NTAB WITH IRHO * 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(DABS(ATST).GT.1.D-14) GO TO 116 117 IF(K-3) 113,118,113 116 JMEM(JJ1)=0 GO TO 112 118 JMEM(JJ1)=1 113 CONTINUE 112 CONTINUE * * PARENTAGE CHECK * 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 * * SET J2 AND J3 . SAME FOR L AND S * 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 141 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 * * RECOUPLING COEFFICIENTS * 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 * * BEGINNING OF LOOP OVER ALL PARENT TERMS * 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=1.D0 M0=M6+1 * * SET UP THE J1 ARRAY FOR THE ANGULAR AND SPIN RECOUPLING * COEFFICIENTS * 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.0) 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 * * PRINT OUT THE J1,J2 AND J3 ARRAYS * 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 * * EVALUATE ORBITAL AND SPIN RECOUPLING COEFFICIENTS * 164 DO 500 I = 1,MN1 FREE(I) = .FALSE. 500 CONTINUE * CALL NJGRAF(RECUP,FAIL) * 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 * * FIRST FRACTIONAL PARENTAGE COEFFICIENT * 306 LIJ=LJ(IRHO) COEFP=1.D0 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(DABS(RECUPS).LT.1.D-14) GO TO 183 * * SECOND FRACTIONAL PARENTAGE COEFFICIENT * 173 LIJ=LJ(ISIG) COEFP=1.D0 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(DABS(RECUPS).LT.1.D-14.AND.IRHO.NE.ISIG) GO TO 183 * * PERMUTATION FACTOR * 175 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 * * MULTIPLICATIVE FACTOR * IF(IRHO-ISIG) 182,185,182 182 SQRN=DSQRT(DFLOAT(NOSH1(IRHO)*NOSH2(ISIG))) VALML=SQRN*RECUPS*DFLOAT(MINUS) GO TO 184 183 VALML=0.D0 184 RML = RML+VALML * RESULT STORED IN VSHELL IF(NTOT.EQ.0) NTOT=1 VSHELL(NTOT)=RML*DSQRT(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=DFLOAT(NOSH1(IRHO))*RPL * * RESULTS STORED IN VSHELL * IF(NTOT.EQ.0) NTOT=1 VSHELL(NTOT)=ANL*DSQRT(AJF) 194 IF(NBUG6-1) 189,196,189 196 WRITE(IWRITE,215) IRHO,ANL 189 IRHO=IRHO+1 ISIG=ISIG+1 RPL=0.D0 IF(IRHO-IHSH) 109,109,190 190 IF(NBUG6-1) 192,13,192 13 WRITE(IWRITE,217) (VSHELL(N),N=1,NTOT) 192 RETURN 300 IF(NBUG6.NE.0) WRITE(IWRITE,302) RETURN 301 IF(NBUG6.NE.0) WRITE(IWRITE,303) RETURN END *----------------------------------------------------------------------- * Q S O R T *----------------------------------------------------------------------- * The method use to sort the data is quick sort with a pivot value * that is the larger value of the first 2 different value from the * the sublist to be sorted. * This sorting method used a stack to maintain the unsorted section, * and sorting will be finished when the stack is empty. subroutine qsort(n,key,pt,stack,nstack,ierr) integer top, from, to, pivot, left, right integer key(*),pt(*),stack(*) * * Set the initial pointer values * do 10 i=1,n 10 pt(i)=i * * Initialize the stack and error indicator * top=1 stack(top)=1 ierr = 0 * * Repeat Until the Stack is empty * 100 continue * * Determine the next section * if (top .ne. 0) then from=stack(top) if (top.ne.1) then to=stack(top-1) - 1 else to=n endif top=top-1 * * Find the position k of the pivot value that partitions * the current section. Return a value of k=0 when there is * no disinct value. * if (from .eq. to) then k=0 else k=0 ismall=key( pt(from) ) do 210 i=from+1,to if (key( pt(i) ) .ne. ismall) then k=i goto 200 endif 210 continue endif 200 continue if (k.ne.0) then if( ismall .gt. key(pt(k)) ) then k=from endif endif if (k .ne. 0)then * * Rearange the section of the keys such that all values * smaller than the pivot value are stored on the left and * larger values on the right. * pivot=key(pt(k)) left=from right=to 300 continue 310 if ( key(pt(left)) .lt. pivot ) then left = left+1 goto 310 endif 320 if ( key(pt(right)) .ge. pivot ) then right = right-1 goto 320 endif if (left .lt. right) then i=pt(left) pt(left)=pt(right) pt(right)=i goto 300 endif kp=left if (top+2 .le. nstack) then stack(top+1)=kp stack(top+2)=from top=top+2 else ierr =1 return endif endif goto 100 endif * * Keys are sorted * return end *----------------------------------------------------------------------- * S A V E *----------------------------------------------------------------------- * SUBROUTINE SAVE(ICASE,C,K,I1,I2,I3,I4,JA,JB,IPTR) * IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /FOUT/NOV(2),IOVLAP(10,2),NCOUNT(8),IFLAG,NIJ COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) IF (ICASE .LE. 2 .or. ICASE .EQ. 4 .or. ICASE .EQ. 5) THEN * * Fk, Gk, L, or Z data * IF (I2 .GT. I4) THEN II2 = I4 II4 = I2 ELSE II2 = I2 II4 = I4 END IF IPACK = (K*64 + II2)*64 + II4 IF (ICASE .NE. 4) THEN WRITE(ISC(ICASE)) C,IPACK,JA,JB ELSE WRITE(ISC(ICASE)) C,IPACK,JA,JB,IPTR END IF ELSE IF(ICASE .EQ. 3) THEN J = 1 IMIN = I1 IF (I2 .LT. IMIN) THEN IMIN=I2 J = 2 END IF IF (I3 .LT. IMIN) THEN IMIN = I3 J = 3 END IF IF (I4 .LT. IMIN) THEN IMIN = I4 J = 4 END IF GO TO (10,20,30,40) J 10 II1 = I1 II2 = I2 II3 = I3 II4 = I4 Go to 50 20 II1 = I2 II2 = I1 II3 = I4 II4 = I3 GO TO 50 30 II1 = I3 II2 = I4 II3 = I1 II4 = I2 GO TO 50 40 II1 = I4 II2 = I3 II3 = I2 II4 = I1 50 IPACK = (((K*64+II1)*64+II2)*64+II3)*64+II4 WRITE(ISC(3)) C,IPACK,JA,JB,IPTR ELSE II1 = I1 II3 = I3 IF (I2 .GT. I4) THEN II2 = I4 II4 = I2 ELSE II2 = I2 II4 = I4 END IF IF (ICASE .NE. 7) THEN IF (I1 .GT. I3) THEN II1 = I3 II3 = I1 END IF END IF * * ... Because the k-value may be -1, for these integrals, a * value of k+1 is stored. * KK = K + 1 IPACK = (((KK*64+II1)*64+II2)*64+II3)*64+II4 WRITE(ISC(ICASE)) C,IPACK,JA,JB END IF NCOUNT(ICASE) = NCOUNT(ICASE) + 1 IFLAG = 1 END * * ------------------------------------------------------------------ * * T R I T S T * ------------------------------------------------------------------ * DOUBLE PRECISION FUNCTION TRITST(L,M,N) * * * IF TRITST=1.0 THE TRIANGLE RELATION IS NOT SATISFIED * IF TRITST=0.0 THE TRIANGLE RELATION IS SATISFIED * LMN=IABS(L-M) LM=L+M IF(N-LMN) 1,2,2 2 IF(LM-N) 1,3,3 3 TRITST=0.D0 RETURN 1 TRITST=1.D0 RETURN END * * ------------------------------------------------------------------ * V I J O U T * ------------------------------------------------------------------ * SUBROUTINE VIJOUT(JA,JB) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC1, :JSC2,JSC3 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) * * THIS SUBROUTINE IS ENTERED ONLY IF IBUG2 IS GREATER THAN ZERO * * --- PRINT OUT OF QUANTUM NUMBERS AND COUPLING SCHEMES FOR EACH * MATRIX ELEMENT AS DEFINED BY SETUP * 5 FORMAT(//48H L.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY) 6 FORMAT(//48H R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY) 7 FORMAT(9H1(CONFIG ,I2,10H/V/CONFIG ,I2,1H)) 8 FORMAT(/7H NJ,LJ ,10(I6,I3)) 9 FORMAT(/6H NOSH ,10I4) 10 FORMAT(6H J1QN ,10(I5,2I3)) I2HSH=2*IHSH-1 WRITE(IWRITE,7) JA,JB WRITE(IWRITE,8) (NJ(I),LJ(I),I=1,IHSH) WRITE(IWRITE,5) WRITE(IWRITE,9) (NOSH1(J),J=1,IHSH) WRITE(IWRITE,10) ((J1QN1(J,K),K=1,3),J=1,I2HSH) WRITE(IWRITE,6) WRITE(IWRITE,9) (NOSH2(J),J=1,IHSH) WRITE(IWRITE,10) ((J1QN2(J,K),K=1,3),J=1,I2HSH) 1 RETURN END J1QN2(IRHO,2)=NI2 J1QN1(ISIG,2)=NI2 J1QNatsp/src/AUTO.f010064400002010000036000002670410625613235400131370ustar00cffcsf00000400000020* ------------------------------------------------------------------ * AUTOIONIZATION PROGRAM * * Written by : Charlotte Froese Fischer * and * Tomas Brage * Department of Computer Science * Vanderbilt University * Modified by: Jinhua Xi, Vanderbilt University * December, 1994 * ------------------------------------------------------------------ * * * All comments in the program listing assume the radial function P * is the solution of an equation of the form * * P" + ( 2Z/R - Y - L(L+1)/R**2 - E)P = X + T * * where Y is called a potential function * X is called an exchange function, and * T includes contributions from off-diagonal energy parameter, * interactions between configurations, etc. * * The program uses LOG(Z*R) as independent variable and * P/SQRT(R) as dependent variable. * * * ------------------------------------------------------------------ * M A I N P R O G R A M * ------------------------------------------------------------------ * The main program: * - sets unit numbers and opens files. * - prompts for type of calculation. * - initializes variabels. (by calling ADATA). * - determines data about problem. * - performs calculations. (by calling CALCAUTO). * * PROGRAM AUTO IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON /INPUT/ ECB,ICASE * CHARACTER NAME(6)*24 LOGICAL PRINT CSUN REAL TIMES(2),DTIME * CSUN RTIME = DTIME(TIMES) * * ***** Define unit numbers and open files ********************* * * * UNIT NUMBERS AND FILE NAMES MAY BE MACHINE * * DEPENDENT. CHECK THE FOLLOWING SECTION. * * * * IN - Standard input unit, normally the terminal * * OUT- Standard output unit, normally the terminal * * ERR- Prompts and Error messages, always the terminal * * PRI- Printer output unit or file. * * 10- Data file (auto.dat). * * * IN = 5 OUT = 6 ERR = 0 PRI = 3 * * * IUC - Input unit for configuration list. * * IUD - Input unit for integral list. * * IUF - Input unit for wave functions. * * * OUC - Output unit for configuration list. (Not used). * * OUD - Output unit for integral list. (Not used). * * OUF - Output unit for wave functions. * * IUC = 21 IUD = 22 IUF = 23 OUC = 0 OUD = 0 OUF = 26 * * ***** Write out header * WRITE(OUT,9) 9 FORMAT(//10X,'============================================'/ : 10X,' A U T O _ I O N I Z A T I O N '/ : 10X,'============================================') * * ***** Write out dimension information * WRITE(OUT,99) 'NCD',NCD,'NWD',NWD,'NO',NOD 99 FORMAT(//10X,'THE DIMENSIONS FOR THE CURRENT VERSION ARE:'/ : (10X,3(A6,'=',I3,4X)/)/) * * ***** Initialize common data arrays * CALL INITA CALL INITR * 1 WRITE(ERR,'(//A/A//)') ' START OF CASE',' =============' * * ***** Get parameters for the case * 999 NAME(2) = 'int.lst' NAME(6) = 'wfn.out' write(ERR,*) ' Name of State' read(IN,'(A)') NAME(1) j = index(NAME(1),' ') if (j .eq. 1) then WRITE(ERR,*) ' Names may not start with a blank' GO TO 999 else NAME(1) = NAME(1)(1:j-1)//'.c' NAME(3) = NAME(1)(1:j-1)//'.w' NAME(4) = NAME(1)(1:j-1)//'.l' NAME(5) = NAME(1)(1:j-1)//'.j' end if * OPEN(UNIT=IUC,FILE=NAME(1),STATUS='OLD') OPEN(UNIT=IUD,FILE=NAME(2),STATUS='OLD') OPEN(UNIT=IUF,FILE=NAME(3),STATUS='OLD', : FORM='UNFORMATTED') OPEN(UNIT=OUF,FILE=NAME(6),STATUS='UNKNOWN', : FORM='UNFORMATTED') OPEN(UNIT=3, FILE='auto.log',STATUS='UNKNOWN',FORM='formatted') * * ************************************************************ * The input for the discrete state can be made in four * different ways: * ICASE weights from ECORE from EBOUND from * ==================================================== * 1 .c file terminal .c file * 2 .l file .c file .l file * 3 .j file .c file .j file * ************************************************************ * WRITE(ERR,'(//A/A/A/A)') :'Select input file for discrete state(s):', :' 1 name.c', ' 2 name.l ',' 3 name.j' READ(IN,*) ICASE IF(ICASE.EQ.2) THEN OPEN(UNIT=9,FILE=NAME(4),STATUS='OLD') ELSE IF(ICASE.EQ.3) THEN OPEN(UNIT=9,FILE=NAME(5),STATUS='OLD') END IF OPEN(UNIT=10,FILE='auto.dat',STATUS='UNKNOWN') * * ***** END OF INPUT/OUTPUT INTERFACE ************************** * FAIL = .FALSE. DO 4 I=1,(NWD) DPM(I) = D10 IEPTR(I) = 0 4 CONTINUE DO 5 I = 1,(98) IJE(I) = 0 5 CONTINUE * * ***** Determine data about the problem * CALL ADATA(ECORE) * * * ***** Set parameters to their default value * 13 PRINT = .FALSE. SCFTOL = 1.D-6 NSCF = 20 IC = 0 ACFG = D0 TRACE = .FALSE. WRITE(OUT,2) PRINT,CFGTOL,SCFTOL,NSCF,IC,ACFG,ID,TRACE 2 FORMAT(/L3,2D6.1,2I3,F3.1,I3,L3) * * ***** Start actual calculations. * CALL CALCAUTO(ECORE,ACFG,SCFTOL,PRINT) * * ***** Determine end of case * 6 CONTINUE CSUN RTIME = DTIME(TIMES) CSUN WRITE(ERR,'(//A/A//A/3F10.3//)') ' END OF CASE',' ===========', CSUN : ' Real User System Time (in minutes)', CSUN : RTIME/60.,TIMES(1)/60., TIMES(2)/60. END * * ------------------------------------------------------------------ * A D A T A * ------------------------------------------------------------------ * * ADATA performs the following tasks: * * 1) Prompts user for ATOM, TERM, Z. * 2) Reads the cfile. * 3) interprets the cfile. * 4) determine continuum data. * 5) interprets configuration data. * 6) sets orthogonality constraints. * 7) first print outs. * 8) Initialize arrays. (wavefunctions and integrals) * * The following routines are called during different stages: * * 5) EPTR. * 6) EIJSET and EPTR. * 7) WAVEFN and ANTGRL. * * SUBROUTINE ADATA(ECORE) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3, ans COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON ZZ(NWD),IND(NWD),IELI(5),NOCCSH(NCD) * COMMON /INPUT/ ECB,ICASE * LOGICAL SETORT,STRONG CHARACTER*3 EL1,EL2,ELCLSD(18),ELORT(10,2),ELI(5),STRING*40 * 1 FORMAT(18(1X,A3)) 7 FORMAT(A3,F6.0,I3,I3,F3.1) * * ***** Read 'ATOM' card * 5 WRITE(ERR,'(/A)') ' ATOM, TERM, Z in FORMAT(A,A,F) : ' READ(IN,'(A)') STRING I = INDEX(STRING,',') IF ( I .EQ. 0) THEN WRITE(ERR,*) ' ATOM, TERM, and Z must be separated by commas ' GO TO 5 END IF ATOM = STRING(1:I-1) J = INDEX(STRING(I+1:),',') IF ( J .EQ. 0) THEN WRITE(ERR,*) ' ATOM, TERM, and Z must be separated by commas ' GO TO 5 END IF TERM = STRING(I+1:I+J-1) * Some compilers do not allow the list directe I/O here. In such * cases use the following, but then Z must have an overriding * decimal point or expressed as a three digit integer with * leading blanks, if necessary * READ(STRING(I+J+1:),'(F3.0)') Z READ(STRING(I+J+1:),*) Z * * ***** Read configuration cards and normalize the weights * ***** Read configurations from a file * READ(IUC,'(15X,F14.7/18(1X,A3))') ECB,(ELCLSD(I),I=1,18) NCFG = 0 3 READ(IUC,'(A40,F10.8)',END=10) STRING,W IF (STRING(1:1) .NE. '*' .AND. STRING(1:3) .NE. ' ') THEN NCFG = NCFG+1 IF (NCFG .LE. (NCD) ) THEN CONFIG(NCFG) = STRING WT(NCFG) = W READ(IUC,'(9(5X,A3))') (COUPLE(NCFG,J),J=1,9) GO TO 3 ELSE WRITE(ERR,*) ' TOO MANY CONFIGURATIONS: MAX =', NCD STOP END IF END IF 10 CONTINUE ID = -1 * * ***** Determine NCLOSD shells * I = 0 SS = D0 12 IF (ELCLSD(I+1) .NE. ' ') THEN I = I+1 VARIED(I) = .TRUE. EL(I) = ELCLSD(I) J = 3 IF (EL(I)(1:1) .NE. ' ') J = 2 L(I) = LVAL(EL(I)(J:J)) N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 IFULL = 2*(2*L(I)+1) S(I) = SS + IFULL/2 SS = SS + IFULL METH(I) = 1 ACC(I) = D0 IND(I) = 0 SUM(I) = 4*L(I)+2 IF (IUF .NE. 0) IND(I) = -1 IF( I .LT. 18) GO TO 12 STOP ' TOO MANY CLOSED SHELLS: MAX = 18' END IF NCLOSD = I * * ***** Determine the other electrons * MAXORB = NCLOSD DO 15 NC = 1,NCFG STRING = CONFIG(NC) J = 2 I = 0 16 IF (STRING(J:J+2) .NE. ' ' ) THEN * * ***** An electron has been found; is it a new one? * I = I+1 EL1 = STRING(J:J+2) K = NCLOSD + 1 17 IF (K .LE. MAXORB) THEN IF ( EL(K) .NE. EL1 ) THEN K = K+1 IF (K .GT. (NWD)) THEN WRITE(ERR,*) ' TOO MANY ELECTRONS: MAX=',NWD STOP 1 END IF GO TO 17 END IF ELSE * * ***** A new electron has been found; add it to the list * MAXORB = K EL(MAXORB) = EL1 IF ((EL1(1:1) .EQ. 'k' .OR. EL1(2:2) .EQ. 'k' .OR. : EL1(1:1) .EQ. 'n' .OR. EL1(2:2) .EQ. 'n') .AND. : ID .EQ. -1) ID = NC-1 END IF J = J+8 IF (J .LT. 40) GO TO 16 END IF NOCCSH(NC) = I 15 CONTINUE IF (ID .EQ. -1) THEN WRITE(ERR,*) ' STOP in ADATA: No continuum function found' CALL EXIT(1) ELSE IF (ID.EQ.0) THEN ICASE = 4 END IF IF(ICASE.EQ.1) THEN WRITE(ERR,*) ' Give energy of core state (a.u.):' READ(IN,*) ECORE ELSE IF(ICASE.EQ.2 .OR. ICASE.EQ.3) THEN ECORE = ECB ELSE IF(ICASE.EQ.4) THEN WRITE(ERR,*) 'Give energy of continuum electron (a.u.):' READ(IN,*) ECB END IF * * ***** The list of electrons has been determined * NWF = MAXORB WRITE(ERR,19) MAXORB,(EL(J),J=1,MAXORB) 19 FORMAT(/' There are ',I3,' orbitals as follows:'/(1X,18(1X,A3))) * write(err,*) ' Is continuum function to be computed? (y/n)' read (in,'(A)') ans if (ans .eq. 'y ' .or. ans .eq. 'Y ') then NIT = 1 else NIT = 0 end if IB = NWF - NIT + 1 DO 20 I = NCLOSD+1,NWF S(I) = SS METH(I) = 3 ACC(I) = D0 IND(I) =-1 VARIED(I) = .TRUE. J = 2 IF (EL(I)(1:1) .EQ. ' ') J = 3 L(I) = LVAL(EL(I)(J:J)) N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 IF (EL(I)(J-1:J-1) .EQ. 'n') METH(I) = 5 20 CONTINUE * * ***** Check that last electron is a continuum orbital. * EL1 = EL(NWF) IF (.NOT. (EL1(1:1).EQ.'k' .OR. EL1(2:2).EQ.'k')) : STOP ' Last orbital not a continuum orbital' * * ***** Check method and initialize arrays for the continuum * ***** electron. * IF (METH(NWF) .NE. 4) THEN METH(NWF) = 4 * IND(NWF) = 1 DO 95 J = 1,NO P(J,NWF) = D0 95 CONTINUE AZ(NWF) = D1 MAX(NWF) = NO END IF DO 35 NC = 1,NCFG STRING = CONFIG(NC) J = 2 I = 0 30 IF (STRING(J:J+2) .NE. ' ' ) THEN * * ***** An electron has been found; find its index * I = I+1 ELI(I) = STRING(J:J+2) CALL EPTR(EL,ELI(I),IELI(I),*99) READ(STRING(J+4:J+5),'(I2)') IQ J = J+8 IF (J .LT. 40) GO TO 30 END IF * * ***** Define all orbitals in the configuration to be orthogonal * DO 34 I1 = 2,I J1 = IELI(I1) DO 33 I2 = 1,I1-1 J2 = IELI(I2) IF (L(J1) .EQ. L(J2) ) THEN CALL EIJSET(J1,J2,1.D-5) CALL EIJSET(J2,J1,1.D-5) END IF 33 CONTINUE 34 CONTINUE 35 CONTINUE * * ***** Set the following orbitals orthogonal * * 1) Orbitals with different l's * 2) In the same orthogonal set * 3) Specified orthogonality * * ***** * DO 38 I = 2,NWF DO 39 J = 1,I-1 IF (L(I) .EQ. L(J) .AND. SETORT(EL(I),EL(J)) ) THEN C = 1.D-5 IF (I.LE.NCLOSD .AND. J.LE.NCLOSD) C = 1.D-10 CALL EIJSET(I,J,C) CALL EIJSET(J,I,C) END IF 39 CONTINUE 38 CONTINUE * * ***** Determine additional orthogonality pairs * I = 0 IF ( IUC .NE. IN) THEN 40 READ(IUC,1,END=50) EL1,EL2 IF ( EL1 .NE. '* ' .AND. EL2 .NE. ' ') THEN ELORT(I,1) = EL1 ELORT(I,2) = EL2 CALL EPTR(EL,EL1,I1,*99) CALL EPTR(EL,EL2,I2,*99) CALL EIJSET(I1,I2,1.D-5) CALL EIJSET(I2,I1,1.D-5) I = I +1 IF (I .GT. (10)) STOP ' TOO MANY ORTHOGONALITIES: MAX=(10)' GO TO 40 END IF NORT = I END IF 50 CONTINUE * * ***** Additional parameters * NO = (NOD) REL = .FALSE. STRONG = .FALSE. IF (NCFG .GT. 1) STRONG = .TRUE. ND = NO - 2 WRITE(OUT,61) ATOM,TERM,Z,NO,NWF,NIT,NCFG,REL,STRONG 61 FORMAT(/1X,2A6,F6.0,I6,3I3,2L3) WRITE(PRI,62) ATOM,TERM,Z,(EL(I),4*L(I)+2,I=1,NCLOSD) 62 FORMAT(1H1///9X,33HHARTREE-FOCK WAVE FUNCTIONS FOR ,2A6,4H Z =, 1 F5.1//14X,'CORE = ',5(A3,'(',I2,')')) WRITE(PRI,'(//11X,A,37X,A//)') 'CONFIGURATION','WEIGHT' OMIT = .NOT. STRONG * * ***** Write 'CONFIGURATION' cards and check the weights * DO 68 I = 1,NCFG NOCC=NOCCSH(I) WRITE(PRI,70) I, CONFIG(I), WT(I),(COUPLE(I,J),J=1,NOCC) 70 FORMAT(/3X,I3,6X,A40,F19.8/12X,9(5X,A3)) WRITE(PRI,73) (COUPLE(I,J),J=NOCC+1,2*NOCC-1) 73 FORMAT(23X,4(5X,A3)) 68 CONTINUE WRITE(PRI,71) 71 FORMAT(//9X,10HINPUT DATA/9X,10H----- ----//13X,13HWAVE FUNCTION, 1 11H PROCEDURE/17X,22HNL SIGMA METH ACC OPT///) DO 79 I = 1,NWF WRITE(PRI,78) I,EL(I),N(I),L(I),S(I),METH(I),ACC(I),IND(I) 78 FORMAT(I8, 2X,A3,2I3,F7.1,I4,F4.1,I4) 79 CONTINUE * * ***** Initialize arrays, if necessary * CALL WAVEFN DO 100 I=1,6 INTPTR(I) = 0 100 CONTINUE * IF (IUD .NE. IN) CALL ANTGRL * * ***** Define SUM(I) * IBEGIN = INTPTR(5)+1 IEND = INTPTR(6) DO 80 I = IBEGIN,IEND IF (IEL(I,1).EQ.IEL(I,2)) SUM(IEL(I,1)) = -2*COEF(I) 80 CONTINUE RETURN 99 STOP END * * ------------------------------------------------------------------ * A G R A N G E * ------------------------------------------------------------------ * * Controls the calculation of off-diagonal energy parameters. * It searches for all localized orbitals, i, to which the continuum * orbital, P , is constrained to be orthogonal. If P must be * NWF NWF * orthogonal not only to P but also to P , a system of equations * i j * must be solved, the exact form depending on whether or not any of * the functions are part of the frozen core. * SUBROUTINE AGRANGE IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON W(NCD,NCD),U(NCD),DWT(NCD),AC(30,NWD),BC(NWD), : JV(NWD),IV(NWD) LOGICAL DIAG, FIRST * * * ***** For l=L(NWF) compute off-diagonal energy parameters * IL = L(NWF) IJ = 0 DO 12 J = 1,NWF-1 IF (DABS(E(NWF,J)) .GT. 1.D-10 ) THEN IJ = IJ + 1 IF ( IJ .GT. NWD) STOP ' TOO MANY LAGRANGE MULTIPLIERS' IV(IJ) = NWF JV(IJ) = J END IF 12 CONTINUE * * ***** IJ is the number of lagrange multipliers for l = L(NWF) * IF (IJ .EQ. 0) GO TO 10 DO 13 II = 1,IJ BC(II) = D0 DO 14 III = 1,IJ AC(II,III) = D0 14 CONTINUE 13 CONTINUE FIRST = .TRUE. DO 18 II = 1,IJ J = 0 IF ( IV(II) .EQ. NWF) THEN J = JV(II) IF (FIRST) THEN CALL CXCH(NWF,2) CALL POTL(NWF) DO 20 JJ = 1,NO YK(JJ) = YR(JJ) 20 CONTINUE FIRST = .FALSE. END IF DO 22 JJ = 1,NO YR(JJ) = P(JJ,J) 22 CONTINUE BC(II) = BC(II) + : HL(EL,NWF,J,REL)-D2*QUADS(NWF,J,1)-QUAD(J,NO,YR,X) END IF 18 CONTINUE DO 24 II = 1,IJ DO 26 III = 1,II IF ( II .EQ. III) THEN AC(II,II) = D1/SUM(IV(II)) ELSE IF (IV(II) .EQ. IV(III) .AND. : E(JV(II),JV(III)) .EQ. D0 ) THEN AC(II,III) = QUADR(JV(II),JV(III),0)/SUM(IV(II)) AC(III,II) = AC(II,III) DIAG = .FALSE. END IF 26 CONTINUE 24 CONTINUE IF ( .NOT. DIAG ) CALL LINEQN(30,IJ,AC,BC) DO 28 II = 1,IJ CALL EIJSET(IV(II),JV(II),BC(II)/SUM(IV(II))) 28 CONTINUE 10 CONTINUE * * ***** Print the off-diagonal energy parameters * DO 32 J = 1,NWF-1 IF (DABS(E(NWF,J)) .GT. 1.D-10) THEN WRITE(OUT,35) EL(NWF),EL(J),E(NWF,J),EL(J),EL(NWF),E(J,NWF) 35 FORMAT(7X,2(3X,'E(',2A3,') =',1PE12.5)) END IF 32 CONTINUE RETURN END * *----------------------------------------------------------------------- * A N T G R L *----------------------------------------------------------------------- * * Read the integrals that define the energy expression * SUBROUTINE ANTGRL IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 character*3 eltemp(2) COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR PARAMETER (IDIM=550,NCDIM=5000) COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) CHARACTER END*1, EL1*3, EL2*3, EL3*3, EL4*3 * 1 FORMAT(1X,A1,I2,1X,A3,1X,A3,1X,I5) 2 FORMAT(1X,A1,I2,1X,2A3,1X,2A3,1X,I5) 3 FORMAT(1X,A1,I2,1X,A3,1X,A3,2X,I2,1X,A3,1X,A3,I5) 4 FORMAT(F14.8,A1,3I3) * * ***** READ THE LIST OF INTEGRALS * LAST = 0 IC = 1 I = 1 READ(IUD,'()') DO 10 INT = 1,6 IF (INT.NE.4 .AND. INT.NE.5) THEN * * ...F, G, L, or O1 integrals.... * 12 READ(IUD,1) END, KVAL(I), EL1, EL2, ICPTR IF (END .EQ. '*') GO TO 16 CPTR(I) = ICPTR + LAST CALL EPTR(EL, EL1,IEL(I,1),*999) CALL EPTR(EL, EL2,IEL(I,2),*999) I = I + 1 IF (I .LE. (IDIM) ) GO TO 12 WRITE(ERR,*) ' Too many integrals - MAX =',IDIM STOP ELSE 14 IF (INT.EQ.5) THEN * * ... R integrals ... * READ(IUD,2) END, KVAL(I), EL1, EL2, EL3, EL4, ICPTR if((el1(1:1).eq.' ' .and. el1(2:2).eq.'k') .or. : (el3(1:1).eq.' '. and .el3(2:2).eq.'k') .or. : el1(1:1) .eq. 'k' .or. el3(1:1).eq.'k') then eltemp(1) = el1 eltemp(2) = el3 el1 = el2 el3 = el4 el2 = eltemp(1) el4 = eltemp(2) end if * ELSE * * ... O2 integrals ... * READ(IUD, 3) END, K1, EL1, EL2, K2, EL3, EL4 KVAL(I) = 64*K1 + K2 END IF CPTR(I) = ICPTR + LAST * IF ( END .EQ. '*') GO TO 16 CALL EPTR(EL, EL1, IEL(I,1), *999) CALL EPTR(EL, EL2, IEL(I,2), *999) CALL EPTR(EL, EL3, IEL(I,3), *999) CALL EPTR(EL, EL4, IEL(I,4), *999) I = I + 1 IF (I .LE. (IDIM) ) GO TO 14 STOP ' Too many integrals - MAX = (IDIM)' END IF 16 IF (INT .EQ. 3 .OR. INT .EQ. 4) GO TO 18 * * ... Read the data ... * 20 READ(IUD,4) COEFF(IC), END, IH(IC), JH(IC), OPTR(IC) IF ( END .NE. '*') THEN IF (INT .LE. 2) THEN COEFF(IC) = ACURAT(COEFF(IC)) ELSE * * ... Shift origin for overlap integrals * IF (OPTR(IC).GT.512) THEN OPTR(IC) = INTPTR(3) + OPTR(IC) - 512 ELSE IF (OPTR(IC).GT.0) THEN OPTR(IC) = INTPTR(2) + OPTR(IC) END IF END IF IC = IC + 1 IF (IC .LE. NCDIM) GO TO 20 STOP ' Too much data - current dimensions = (NCDIM)' END IF * * ... Initialize for next set .. * 18 INTPTR(INT) = I-1 LAST = IC-1 10 CONTINUE RETURN * 999 WRITE(ERR,*)' Electron in ',END,'-data not found in ', : 'configuration list data' STOP END * * ------------------------------------------------------------------ * A O R T H O * ------------------------------------------------------------------ * * This routine orthogonalizes the set of radial functions when an * orthogonality constraint applies. A Gram-Schmidt type of process * is used. When more than one radial function with a given (nl) is * present, it may be necessary to solve a 2x2 system of equations. * * SUBROUTINE AORTHO IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL DIAG COMMON AC(30,NWD),BC(NWD) * IF (NWF .EQ. 1 .OR. IB .GT. NWF) RETURN I=NWF DIAG = .TRUE. IBEGIN = IEPTR(NWF-1)+1 IP = IBEGIN IJ = 0 60 JV = IJE(IP) IF (JV .LT. NWF .AND. IP .LE. IEPTR(I)) THEN IJ = IJ+1 IF ( IJ .GT. (NWD)) STOP ' TOO MANY ORTHOGONALITY CONDITIONS' BC(IJ) = QUADR(NWF,JV,0) AC(IJ,IJ) = D1 DO 62 JJ = IBEGIN,IP-1 IK = JJ - IBEGIN + 1 IF (E(IJE(IP),IJE(JJ)) .NE. D0 ) THEN AC(IJ,IK) = D0 AC(IK,IJ) = D0 ELSE AC(IJ,IK) = QUADR(IJE(IP),IJE(JJ),0) AC(IK,IJ) = AC(IJ,IK) DIAG = .FALSE. END IF 62 CONTINUE IP = IP+1 GO TO 60 END IF IF ( IJ .GT. 0) THEN IF ( .NOT. DIAG .AND. IJ.GT.1) CALL LINEQN(30,IJ,AC,BC) M = MAX(NWF) AZZ = AZ(NWF) IP = IBEGIN CTOTAL = D0 DO 65 JJ = 1,IJ C = BC(JJ) IF (DABS(C) .GT. 1.D-10) THEN WRITE(OUT,63) EL(IJE(IP)),EL(NWF),C 63 FORMAT(6X,'<',A3,'|',A3,'>=',1PD8.1) DO 64 J = 1,M P(J,NWF) = P(J,NWF) - C*P(J,IJE(IP)) 64 CONTINUE AZZ = AZZ - C*AZ(IJE(IP)) END IF IP = IP + 1 CTOTAL = CTOTAL + ABS(C) 65 CONTINUE IF (CTOTAL .GT. 1.D-10 ) THEN AZ(NWF) = AZZ VARIED(NWF) = .TRUE. END IF END IF END * * ------------------------------------------------------------------ * A O U T P U T * ------------------------------------------------------------------ * * The radial functions and orthogonality integrals are printed, * if PRINT is .TRUE. The functions will also be punched (or * stored) on unit OUF, if OUF .NE. 0. * * SUBROUTINE AOUTPUT(PRINT,DELTA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) INTEGER MMX * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL PRINT, REL/.false./ DIMENSION POUT(8) IF ( .NOT. PRINT ) GO TO 31 C C ***** PRINT RADIAL FUNCTIONS, 7 PER PAGE C ML = 1 2 MU = MIN0(ML+7,NWF) I = MU - ML + 1 MX = 0 DO 1 J = ML,MU 1 MX = MAX0(MX,MAX(J)) WRITE(PRI,5) ATOM,TERM,(EL(J),J=ML,MU) 5 FORMAT(1H1,9X,19HWAVE FUNCTIONS FOR ,2A6//10X,1HR,8(10X,A3)) K= 0 KK = 0 DO 6 J = 1,MX DO 9 JJ = ML,MU IJ = JJ - ML + 1 POUT(IJ) = P(J,JJ)*R2(J) 9 CONTINUE K = K+1 IF (K .LE. 10) GO TO 6 K = 1 KK = KK+1 IF (KK .LT. 5) GO TO 21 KK = 0 WRITE(PRI,23) 23 FORMAT(1H1//) GO TO 6 21 WRITE(PRI,8) 8 FORMAT(1X) WRITE(PRI,10) R(J),(POUT(JJ),JJ=1,I) 6 CONTINUE 10 FORMAT(F13.5,F15.6,7F13.6) DO 15 J = ML,MU IJ = J - ML + 1 POUT(IJ) = DPM(J) 15 CONTINUE WRITE(PRI,16) (POUT(J),J=1,I) 16 FORMAT(4X,10HMAX. DIFF. ,F15.7,7F13.7) ML = ML+8 IF (ML .LE. NWF) GO TO 2 31 IF ( NWF .LE. 1) GO TO 30 * * ***** PRINT ORTHOGONALITY INTEGRALS * WRITE(PRI,11) ATOM,TERM 11 FORMAT(////10X,33HORTHOGONALITY INTEGRALS FOR ATOM ,A6,6H TERM ,A6 : //20X, 4H(NL),3X,4H(NL),7X,8HINTEGRAL //) LM = IB ML = MAX0(2,LM) DO 12 I = ML,NWF JF = I - 1 DO 13 J = 1,JF IF (L(I) .NE. L(J)) GO TO 13 T = QUADR(I,J,0) WRITE(PRI,17) EL(I),EL(J),T 17 FORMAT(21X,A3,4X,A3,F15.8) 13 CONTINUE 12 CONTINUE 30 IF ( OUF .EQ. 0) GO TO 14 * * ***** Output functions on unit OUF for future input * * EKI retained only for compatibility with MCHF format * DO 3 I = NCLOSD+1,NWF IF (METH(I) .NE. 4) THEN EKI = -D5*HL(EL,I,I,REL) ELSE EKI = DELTA END IF MMX = MAX(I) WRITE (OUF) ATOM,TERM,EL(I),MMX,Z,E(I,I),EKI,AZ(I), : (P(J,I),J=1,MMX) 3 CONTINUE WRITE (OUF) ATOM,TERM,EL(NWF),0,Z,E(NWF,NWF),EKI,AZ(NWF) * 14 RETURN END * ------------------------------------------------------------------ * A R A T E * ------------------------------------------------------------------ * * The ARATE subroutine computes an energy matrix, H-E. * From the Golden Rule, the autoionisation rate is calculated as * square of the interaction element: * * Sum C * H * A * i,j i ij j * * Where C and A is the coefficient vectors for the discrete and the * continuum states respectively. The sum over i runs from 1 to ID * (number of discrete configuration states) and the sum over j runs * from ID+1 to NCFG. * Strictly speeking, the whole matrix is not needed. It is still * calculated for future purposes. The time wasted is minor in most * cases. * * SUBROUTINE ARATE(ETOTAL,ACFG) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON WP(NCD),W(NCD,NCD) * DO 1 I = 1,NCFG DO 2 J = 1,NCFG W(I,J) = D0 2 CONTINUE W(I,I) = -ETOTAL 1 CONTINUE * IBEGIN = 1 IEND = INTPTR(6) J = 0 DO 10 I = IBEGIN,IEND 11 IF (CPTR(I) .GT. J) THEN J = J + 1 C = COEFF(J)*VALUE(I) IF (OPTR(J) .NE. 0) C = C*VALUE(OPTR(J)) W(IH(J),JH(J)) = W(IH(J),JH(J)) + C GO TO 11 END IF 10 CONTINUE * * ***** Symmetrize the matrix * DO 12 I = 1,NCFG-1 DO 13 J = I+1,NCFG W(I,J) = W(J,I) 13 CONTINUE 12 CONTINUE IF (TRACE) THEN WRITE(OUT,'(/2(10X,A,F16.8)/)') : 'ETOTAL =',ETOTAL,'K**2=',-ED WRITE(OUT,'(4X,6F12.7/(4X,6F12.7))') : (W(I,NCFG),I=1,NCFG-1) END IF WRITE(PRI,'(/2(10X,A,F16.8)//10X,A/)') : 'ETOTAL =',ETOTAL,'K**2 =',-ED, : 'Interaction elements (H)' DO 17 K = ID+1,NCFG WRITE(PRI,'((4X,6F12.7))') (W(I,K),I=1,ID) 17 CONTINUE WRITE(PRI,'(/10X,A/(4X,6F12.7))') : 'Coefficients - discrete',(WT(I),I=1,ID) WRITE(PRI,'(/10X,A/(4X,6F12.7))') : 'Coefficients - continuum',(WT(I),I=ID+1,NCFG) IF (ID .GE. 1) THEN V = D0 DO 20 I = 1,ID DV = D0 DO 21 J = ID+1,NCFG DV = DV + WT(J)*W(I,J) 21 CONTINUE V = V + WT(I)*DV 20 CONTINUE IF (V .NE. D0) THEN VSQ = V*V PI = ACOS(-D1) WIDTH = PI*VSQ A = 2.5976E+17*VSQ TAU = D1/A WRITE (10,19) V, WIDTH,27.21*WIDTH,219474.*WIDTH,A,TAU WRITE (PRI,19) V,WIDTH,27.21*WIDTH,219474.*WIDTH,A,TAU 19 FORMAT(/10X,'Auto-ionization Data'/ : 10X,'--------------------'// : 20X,' Interaction, V =',1PE13.4,' au'/ : 20X,' Half-Line Width =',1PE13.4,' au'/ : 20X,' ',1PE13.4,' ev'/ : 20X,' ',1PE13.4,' cm-1'/ : 20X,' Auto-ionization rate =',1PE13.4,' s-1'/ : 20X,' Half-Life =',1PE13.4,' s'//) END IF END IF * RETURN END * * ------------------------------------------------------------------ * A S C F * ----------------------------------------------------------------- * * This routine controls the 'SCF' procedure for the continuum * function through the following steps. * 1. Set parameters. * If certain input parameters are zero (or blank) * they will be set to their default value. * * Parameter Default Value (set in MAIN). * -------- ------------- * SCFTOL 1.D-6 * NSCF 20 * * The self-consistency convergence criterion is * * Z2 = SCFTOL * * It is increased by a factor 1.3 at the end of each iteration * * 2. Call COULOM to calculate direct function in outer region. * * 3. Find initial estimate of the continuum function (by calling * CSOLVE) and orthogonalize (AORTHO). * * 4. Do SCF-iterations in the following steps (from 1 to NSCF unless * converged): * i) Calculates off-diagonal Energy parameters (AGRANGE). * ii) Solve the Differential Equation (CSOLVE). * iii) Orthogonalize (AORTHO). * iv) Update the integrals (UPDATE). * * 5. Calculate the autoionization properties (ARATE) and do final * printouts (AOUTPUT and ASUMMRY). * SUBROUTINE ASCF(ECORE,EKK,ACFG,SCFTOL,PRINT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON /INPUT/ ECB,ICASE * LOGICAL LAST,PRINT CHARACTER ANS*1 * * ***** Set the SCF convergence parameter to an optimistic value * ETOTAL = ECORE - D5*EKK TOL = DSQRT(Z)*1.D-10 Z2 = SCFTOL WRITE(OUT,15) 15 FORMAT(//) WRITE(OUT,16) OMIT,ACFG,Z2,NO,REL 16 FORMAT(10X,44HWEAK ORTHOGONALIZATION DURING THE SCF CYCLE=,L4/ : 10X,44HACCELERATING PARAMETER FOR MCHF ITERATION =,F5.2/ : 10X,44HSCF CONVERGENCE TOLERANCE (FUNCTIONS) =,1PD9.2 : /10X,44HNUMBER OF POINTS IN THE MAXIMUM RANGE =,I4/ : 10X,44HRELATIVISTIC DIAGONAL ENERGY CORRECTIONS =,L4//) IPR = 0 * * ***** Calculate the direct function in the asymptotic region. * CALL COULOM(NWF,EKK) * * ***** Get initial estimates of the continuum function. * IF (P(1,NWF) .EQ. D0) THEN CALL CSOLVE(NWF,DELTA) CALL AORTHO END IF * * ***** Set iteration parameters * LAST = .FALSE. ICYCLE = 0 CALL UPDATE IF ( IB .GT. NWF ) GO TO 17 19 IF ( ID .EQ. 0 .OR. NCFG .EQ. 1) GO TO 9 * * ***** Perform NSCF self-consistent field iterations * 9 DO 100 I = 1,NSCF ICYCLE = ICYCLE + 1 WRITE(OUT,7) ICYCLE,Z2 7 FORMAT(//10X,17HITERATION NUMBER ,I2/10X,16H----------------/ : 10X,'CONVERGENCE CRITERIA =',1PD9.1/) DP1 = D0 IF (IB .GT. NWF) GO TO 17 CALL AGRANGE * * ***** Solve the differential equation * WRITE(OUT,14) 14 FORMAT(/20X,' EL',6X,'ED/DELTA',10X,'AZ',11X,'NORM',7X,'DPM') CALL CSOLVE(NWF,DELTA) DP1 = DPM(NWF)*DSQRT(SUM(NWF)) CALL AORTHO CALL UPDATE IF ( LAST ) GO TO 17 IF ( I .EQ. NSCF ) GO TO 1 * * ***** If function appear to have converged,solve and test again * IF (DP1 .LE. Z2) LAST =.TRUE. 1 CONTINUE WRITE(OUT,8) EL(NWF),DP1 8 FORMAT(/ 6X,34HLEAST SELF-CONSISTENT FUNCTION IS ,A3, : 27H :WEIGHTED MAXIMUM CHANGE =,1PD10.2) Z2=1.3*Z2 100 CONTINUE 18 WRITE(ERR,13) 13 FORMAT(10X/' SCF ITERATIONS HAVE CONVERGED TO THE ABOVE ACCURACY') WRITE(PRI,13) WRITE(ERR,*) ' Do you wish to continue ? (Y/N) ' READ(IN,'(A)') ANS IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN WRITE(ERR,*) ' Enter the additional iterations ' READ(IN,*) NSCF CALL UPDATE GO TO 19 END IF FAIL = .TRUE. * * ***** Perform final calculations * 17 ACFG = D0 IF(ICASE.NE.4) THEN CALL ARATE(ETOTAL,ACFG) END IF CALL AOUTPUT(PRINT,DELTA) CALL ASUMMRY(DELTA) NIT = NWF - IB + 1 WRITE(PRI, 105) DELTA,DP1 105 FORMAT(//10X,'PHASE SHIFT FOR CONTINUUM FUNCTION =',F10.6/ : 10X,'FINAL WEIGHTED CHANGE IN FUNCTION =',D10.2) RETURN END * * ------------------------------------------------------------------ * A S U M M R Y * ------------------------------------------------------------------ * * The results of a calculation are summarized. These include * the following for each electron: * * E(NL) - diagonal energy parameter * AZ(NL) - starting parameter, P(r)/r**(l+1) as r -> 0. * SIGMA - screening parameter as defined by Eq. (7-2). * 1/R**3 - expected value of <1/r**3> * 1/R - expected value of <1/r> * R - expected mean radius * R**2 - expected value of * I(NL) - -(1/2) * KE - I(NL) + Z * REL - Relativistic shift (mass-velocity, Darwin term, * spin-spin contact term) * * These results are followed by: * k k k * The values of all F , G , R and integrals which enter * into the calculation are printed, but only if OUD > 0. * * SUBROUTINE ASUMMRY(DELTA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON R3(NWD),SS(3),R1,RM,RMM,RH,SC,QI,QJ,SP,C,CC, : EKINP,EN,EPOT,RATIO,LI,LJ,K,KF,I1,I2,J1,J2,I,J,MIN CHARACTER*1 SYMBOL * WRITE(PRI,'(///9X,A)') 'FINAL RESULTS:' WRITE(PRI,9) ATOM,TERM 9 FORMAT(/ 24X,'ATOM',1X,A6,3X,'TERM',1X,A6// : 2X,'nl',7X,'E(nl)', : 5X,'I(nl)/Delta',5X,'Rel(nl)',3X,'S(nl)',5X,'Az(nl)') * * ***** Compute and print one-electron parameters * DO 10 I = 1,NWF EK = DELTA S(I) = D0 IF (METH(I) .NE. 4) THEN RM = QUADR(I,I,1) EK = -D5*HL(EL,I,I,REL) RH = 3*N(I)*N(I) - L(I)*(L(I) + 1) SC = Z - D5*RH/RM S(I) = SC END IF RELS = RLSHFT(I,I) WRITE (PRI,15)EL(I),E(I,I),EK,RELS,S(I),AZ(I) 15 FORMAT(1X,A3,F14.7,2F13.6,F7.2,F13.5) 10 CONTINUE * * ***** Compute and print moments. * WRITE(PRI,8) 8 FORMAT(//2X,'nl',7X,'1/R**3',8X,'1/R',10X,'R',11X,'R**2') DO 11 I = 1,NWF R1 = D0 RM = D0 RMM = D0 IF (METH(I) .NE. 4) THEN R1 = QUADR(I,I,-1) RM = QUADR(I,I,1) RMM = QUADR(I,I,2) R3(I) = D0 END IF IF (L(I) .NE. 0) R3(I) = QUADR(I,I,-3) WRITE(PRI,16) EL(I),R3(I),R1,RM,RMM 16 FORMAT(1X,A3,F14.3,F13.4,F13.5,F13.5,F13.5) 11 CONTINUE * * ***** Print tables of 'FK' and 'GK' integrals which were used in * ***** determining the energy * IF ( OUD .EQ. 0 ) GO TO 13 WRITE (OUD,126) 126 FORMAT(//2X,27HVALUES OF F AND G INTEGRALS //) IBEGIN = 1 IEND = INTPTR(2) DO 17 I = IBEGIN,IEND SYMBOL = 'F' IF (I .GT. INTPTR(1)) SYMBOL = 'G' 17 WRITE(OUD,19) SYMBOL,KVAL(I),EL(IEL(I,1)),EL(IEL(I,2)),VALUE(I) 19 FORMAT( 2X,A1,I2,1H(,A3,1H,,A3,4H ) =, F10.7) * * ***** Print tables of 'RK' integrals * WRITE (OUD,21) 21 FORMAT(//2X,21HVALUES OF R INTEGRALS //) IBEGIN = INTPTR(4) + 1 IEND = INTPTR(5) DO 22 I = IBEGIN,IEND I1 = IEL(I,1) I2 = IEL(I,2) J1 = IEL(I,3) J2 = IEL(I,4) 22 WRITE (OUD,23) KVAL(I),EL(I1),EL(I2),EL(J1),EL(J2),VALUE(I) 23 FORMAT(2X,1HR,I2,1H(,2A3,1H,, 2A3,3H) =, F11.7 ) * * ***** Print tables of 'L' integrals * WRITE (OUD,28) 28 FORMAT(//2X,21HVALUES OF L INTEGRALS //) IBEGIN = IEND + 1 IEND = INTPTR(6) DO 29 I = IBEGIN,IEND 29 WRITE(OUD,30) EL(IEL(I,1)),EL(IEL(I,2)),VALUE(I) 30 FORMAT(2X,2HL(,A3,1H,,A3,4H) = ,F12.7) 13 RETURN END * * ------------------------------------------------------------------ * C A L C A U T O * ------------------------------------------------------------------ * * Calcauto performs the following tasks: * 1) some printouts. * 2) determines maximum range of the discrete orbitals * (this will define the maximum R) by searching for an * MX; ABS(PJ(R)) < 10**(-5) for all J; 0 < J < NWF * if R > R(MX). * 3) it can follow two branches, depending on the value * of ICASE. * * If ICASE = 1 or 4: * all data is known from the array WT and the * variables ECB and ECORE and we can procede quickly * to the scf-routine. * * If ICASE = 2 or 3: * it reads in data from unit 9 (.l or .j). * For each J-value (if ICASE = 2) we do calculation * for all states found (1 to MFOUND) and * read in weights and discrete energy. * * SUBROUTINE CALCAUTO(ECORE,ACFG,SCFTOL,PRINT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON ZZ(NWD),IND(NWD),IELI(5),NOCCSH(NCD) * COMMON /INPUT/ ECB,ICASE * CHARACTER*72 HEADER,LSI*2,LSJ*2 LOGICAL PRINT * * ***** Some printouts. * IF(ICASE.NE.4) THEN WRITE(10,'(/10X,A/10X,A/10X,A//)') : '====================================' : , ' AUTOIONIZATION CALCULATION ' : , '====================================' WRITE(10,3) ECORE 3 FORMAT(//10X,'Energy of Target:',F14.8// : 10X,'Continuum State:'/10X,'===============') END IF DO 5 I = ID+1,NCFG WRITE(10,4) CONFIG(I),(COUPLE(I,J),J=1,9) 4 FORMAT(/10X,A40/10X,9(5X,A3)/) 5 CONTINUE * * ***** Determine extent of outer region of bound functions * MX = 0. DO 1 I = 1,NWF-1 J = MAX(I) 2 IF (ABS(P(J,I)) .LT. 1.D-5) THEN J = J-1 GO TO 2 END IF MX = MAX0(MX,J) 1 CONTINUE SUM(NWF) = 1. * * ***** ICASE = 1: * ***** Eigen vector (WT) and Discrete energy (EBOUND = ECB) from cfile. * IF(ICASE.EQ.1) THEN ICFG = 1 EBOUND = ECB V = D0 DO 40 I = 1,ID DV = D0 CALL LSTERM(COUPLE,I,LSI) DO 42 J = ID+1,NCFG CALL LSTERM(COUPLE,J,LSJ) IF (LSI .EQ. LSJ) DV = DV + ABS(WT(J)) 42 CONTINUE V = V + ABS(WT(I))*DV 40 CONTINUE IF ( V .NE. D0) THEN EKK = 2*(ECORE-EBOUND) WRITE(10,6) -EKK/2 WRITE(10,'(10X,A)') : '=======================================' WRITE(10,'(//10X,A)') 'Discrete State, main component:' WRITE(10,'(10X,A)') '------------------------------' WRITE(OUT,'(//A,F10.5/)') ' *** CALCULATIONS FOR k^2 =',-EKK WRITE(10,103) ICFG,CONFIG(ICFG), : (COUPLE(ICFG,J),J=1,9) WRITE(PRI,103) ICFG,CONFIG(ICFG), : (COUPLE(ICFG,J),J=1,9) IF(EKK.GT.D0) THEN WRITE(OUT,'(/A/)') 'THIS IS A BOUND STATE: ENJ * NJ = M 5 IF ( FK(NJ) .LT. D0 ) THEN NJ = NJ-1 IF (NJ .GT. 90 ) GO TO 5 END IF NJ = NJ+1 * * 3) Search for the point, MP, outside which YR is constant * and we can define a Zeff. * MP = M 6 IF ( YR(MP) - YR(MP-1) .LT. r(mP)*1.D-4 ) THEN MP = MP-1 IF (MP .GE. NJ) GO TO 6 END IF MP = MP+1 * * 4) Interpolate FK to obtain FH in "half-grid-points". * EXPH = EXP(H/D2) CHH = CH/D4 JH = 1 MM = MIN0(NO-2,NJ+129) DO 50 J = NJ,MM FH(JH) = FK(J)/D4 FHC(JH) = FKC(J)/D4 YRH = (9.*(YR(J)+YR(J+1))-YR(J-1)-YR(J+2))/D16 RHH = R(J)*EXPH RRH = RHH*RHH FH(JH+1) = (-D2*(Z-YRH)*RHH +CD + EKK*RRH)*CHH FHC(JH+1) = (-D2*ZF*RHH +CD + EKK*RRH)*CHH JH = JH+2 50 CONTINUE IX = 0 END * * ------------------------------------------------------------------ * C S O L V E * ------------------------------------------------------------------ * Modified by Jinhua Xi, December 1994 * CSOLVE performs the following tasks: * * 1) Computes the Exchange function, X(r), by calling CXCH. * 2) Redefines the outer region; * * Initialization stage (IX = 0) - first call: * reduce outer region (MAX(NWF) -> M) if step size is too * big (R(I) - R(I-1) > 2/K) and where NJ <= M <= MAX(NWF). * M-NJ is also, by dimensions, bound to be less than 130. * * During SCF-cycle (IX = 1): * find MJ; MP < MJ < M and * X(r)/FK(r) < 0.0025 if R > R(MJ). * This will be used to calculate phase shift. If MJ = M * the X function might be truncated -> warning. * 3) Interpolates X(r) to XH(r), for half the step size, in * the azymptotic region; r(NJ) <= r <= r(M). * 4) Prepares for the Numerov method of solving the * differential equation, both in azymptotic and inner region. * 5) Solves the differential equation, by calling CNMRV. * 6) Calculates the phase shift and renormalization, by using * regular, FC, and irregular, GC, Coulomb functions; * Renormalizes the continuumfunction. * 7) Orthogonalize the continuum function. * The following subroutines are called in the different * steps: * 1) CXCH * 5) CNMRV * 6) FGCOUL * * SUBROUTINE CSOLVE(I,DELTA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON /CONTIN/FK(NOD),FH(260),XH(260),rh(260),r2h(260),ph(260), : CD,FL,ZL,ZF,V,NJ,MJ,MP,IX COMMON /COULFG/FKC(NOD),XC(NOD),PDC(NOD),FHC(260),PHC(260),NJM * PI = ACOS(-D1) ED = E(I,I) ekk = -ed eK = SQRT(ekk) icase = 0 AZD = AZ(I) IPR = NWF M = MAX(NWF) * * ***** Computes the Exchange function. * CALL CXCH(I,3) cxi cxi save X(J) for repeated use with different cxi E(I,J) values cxi do 12 j=1,no p(j,nwf+1) = X(j) 12 continue * * ***** Redefine the outer region. * 678 IF (IX .EQ. 0) THEN 5 IF (eK*(R(M)-R(M-1)) .GT. 2.0D0) THEN M = M-1 IF (M .GT. MP) GO TO 5 END IF IF (M .LT. MAX(NWF)) THEN WRITE(OUT,*) 'Outer region reduced by ',MAX(NWF)-M,'points', : ' in CSOLVE. ' END IF MJ = M print *, ' End of range: ', r(m), ' au.' ELSE 2 IF (ABS(X(MJ)/FK(MJ)) .LT. 0.0025) THEN MJ = MJ-1 IF (MJ .GT. MP) GO TO 2 END IF END IF IF (M-NJ .GE. (130)) THEN WRITE(OUT,*) ' Outer region contains ',M-NJ+1,' points' WRITE(OUT,*) ' Maximum allowed value is (130)' STOP 'In CSOLVE - Too large outer region' END IF IF (MJ .EQ. M .AND. IX.NE.0) THEN if( icase .eq. 0 ) then WRITE(OUT,'(/1X,A,I4)') : 'WARNING: Outer region may be truncated. M = MJ =',M WRITE(OUT,'(A)') : ' Exchange function not small at M!' endif ELSE IX = 1 END IF * * ***** Interpolate X in outer region to obtain XH. * ehh = exp(h/2.d0) e2hh = exp(h/4.d0) JH = 1 DO 3 J = NJ,M XH(JH) = X(J) rh(jh) = r(j) r2h(jh) = r2(j) XH(JH+1) = (9.*(X(J)+X(J+1)) -X(J-1)-X(J+2))/D16 rh(jh+1) = r(j)*ehh r2h(jh+1) = r2(j)*e2hh JH = JH + 2 3 CONTINUE * * ***** Prepare for Numerovs method. * ***** i) Compute the RHS of the Numerov equation for the outer region * CHH = CH/D4 JH = JH-2 X1 = XH(1) X2 = XH(2) DO 4 J = 2,JH X3 = XH(J+1) XH(J) = CHH*(X1 + D10*X2 +X3) X1 = X2 X2 = X3 4 CONTINUE * * ***** ii) Compute the RHS of the Numerov equation * XY = X(1) XP = X(2) X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) DO 1 J = 3,NJ X5 = X(J+2) X(J) =CH*(-X5+24.D0*(X4+X2) + 194.D0*X3 - X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 1 CONTINUE * * ***** iii) Add the deferred difference correction to the exchange * ***** for the outward integration region * X1 = P(1,I)*FK(1) X2 = P(2,I)*FK(2) X3 = P(3,I)*FK(3) X4 = P(4,I)*FK(4) DO 7 J = 3,NJ X5 = P(J+2,I)*FK(J+2) X(J) = X(J) - (X5 -D4*(X2 + X4) + D6*X3 +X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 7 CONTINUE RL = L(I) + 2.5 X(2) = R(2)**RL*(X(5)/R(5)**RL - D3*(X(4)/R(4)**RL - : X(3)/R(3)**RL)) * * ***** iv) Compute starting values from series expansion * CC = D2*FL + D3 A2 = (V + ED/D2 + ZL*Z)/CC A3 = -((V + ED/D2)*ZL + Z*A2)/(D3*(FL+D2)) DO 6 J = 1,2 6 PDE(J) = AZ(I)*R(J)**L(I)*R2(J)* : (R(J)*(R(J)*(R(J)*A3 + A2) -ZL) +D1) PDE(1) = PDE(1) + XY/(D2*CC) PDE(2) = PDE(2) + XP/(D2*CC) * * ***** Solve the differential equation. * cxi CALL CNMRV(NJ,M,1,AZ(I),FK,X,FH,XH,PH,PDE) CALL FGCOUL(I,M,CN,DELTA) cxi cxi note: the sign of the overlop depends on cn, cxi because we need to adjust the off-diagonal parameters cxi repeatedly to find a zero overlap, we can not change the sign of cxi the wavefunction cxi so, save the sign in cnn cxi if( cn .lt. 0.d0 ) then cnn = -1.d0 cn = - cn else cnn = 1.d0 endif * * ***** Renormalise. * DO 92 J = 1,M PDE(J) = PDE(J)*CN 92 CONTINUE AZ(I)=CN*AZ(I) DO 13 J = 1,M DIF = P(J,I) - PDE(J) P(J,I) = PDE(J) + acc(i)*dif 13 CONTINUE AZ(I) = (1.d0 - acc(i))*AZ(i) + acc(i)*AZD cxi cxi if the acc(i) is used, the wavefunction needs to be cxi re-normalized cxi MAX(I) = M * * ***** Orthogonalize the continuum function * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1)+1 IP = IBEGIN 50 JI = IJE(IP) IF ( JI .NE. I) THEN CC = QUADR(I,JI,0) if( ip .eq. ibegin ) then cxi cxi the first orthogonal requirements, use new approach cxi if( e(i,ji) .eq. 0.d0 .or. dabs(cc) .lt. 1.d-7) goto 65 azcc= CC*AZ(JI)/az(i) if( dabs(azcc) .gt. 0.1d0) goto 66 endif 65 WRITE(OUT,63) EL(JI),EL(I),CC, e(i,ji) 63 FORMAT(1X,'<',A3,'|',A3,'>=',D8.2, ' eij=',d18.10) AZ(I) = AZ(I) - CC*AZ(JI) DO 51 J = 1,M P(J,I) = P(J,I) - CC*P(J,JI) 51 CONTINUE c cxi re-normalize the wavefunction cxi cnn=cnn*pde(M)/P(M,i) if (az(i) .lt. 0.d0) cnn = - cnn Az(i) = cnn*Az(i) do 52 j = 1,m p(j,i) = cnn*p(j,i) 52 continue cxi cxi normalize the off diagonal parameters cxi eijv = cn*cnn*e(i,ji) call eijset(i,ji,eijv) IP = IP+1 IF (IP .LE. IEPTR(I)) GO TO 50 END IF * VARIED(I) = .TRUE. DP = ABS((AZD - AZ(I))/AZ(I)) DPM(I) = DP WRITE(OUT,17) EL(I),DELTA,AZ(I),CN,'c',DP 17 FORMAT(20X,A3,2F15.7,F12.7,A2,1PD10.2) return cxi cxi adjusting the off-diagonal parameters E(I,JI) cxi 66 eijv = e(i,ji) call geteij(icase,eijv,cc) deteij = eijv - e(i,ji) call eijset(i,ji,eijv) cxi cxi for new E(i,j) values, always keep updating cxi the X function cxi do 18 j=1,no p(j,nwf+1) = p(j,nwf+1) + deteij*P(j,ji)*rr(j) x(j) = p(j,nwf+1) 18 continue az(i)= azd goto 678 END * *---------------------------------------------------------------------- * C X C H *---------------------------------------------------------------------- * * This subroutine computes the function X(r) for the continuum * orbital. It includes contributions from Exchange, Configuration * Interaction, One-electron part and off-diagonal Lagrange * Multipiers. * SUBROUTINE CXCH(I,IOPT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * DO 1 J=1,NO 1 X(J) = D0 DO 2 J = 1,NWF IF ((I.LE.NCLOSD .AND. I.NE.J) .OR. : (I.GT.NCLOSD .AND. J.LE.NCLOSD)) THEN DO 4 K = IABS(L(I)-L(J)),L(I)+L(J),2 C = - D2*CB(L(I),L(J),K)*SUM(J) CALL YKF(J,I,K,REL) DO 6 JJ = 1,NO X(JJ) = X(JJ) + C*YK(JJ)*P(JJ,J) 6 CONTINUE 4 CONTINUE END IF 2 CONTINUE SUMI = SUM(I) IF (I .LE. NCLOSD) GO TO 71 * IBEGIN = INTPTR(1)+1 IEND = INTPTR(2) DO 7 INT = IBEGIN,IEND IE1 = 0 IF (IEL(INT,1) .EQ. I) THEN IE1 = IEL(INT,1) IE2 = IEL(INT,2) ELSE IF (IEL(INT,2) .EQ. I) THEN IE1 = IEL(INT,2) IE2 = IEL(INT,1) END IF IF (IE1 .NE. 0) THEN C = D2*COEF(INT)/SUMI CALL YKF(IE1,IE2,KVAL(INT),REL) DO 8 JJ = 1,NO X(JJ) = X(JJ) + C*YK(JJ)*P(JJ,IE2) 8 CONTINUE END IF 7 CONTINUE * 71 GO TO (75,76,77),IOPT 76 DO 78 J = 1,NO X(J) = X(J)/R(J) 78 CONTINUE GO TO 75 77 DO 79 J =1,NO X(J) = R(J)*X(J) 79 CONTINUE DO 74 J = 1,NWF IF (J .NE. I) THEN C = E(I,J) IF (DABS(C) .LE. 1.D-20 ) GO TO 74 DO 73 JJ = 1,NO 73 X(JJ) = X(JJ) + C*P(JJ,J)*RR(JJ) END IF 74 CONTINUE C C ***** Check if exchange is zero: if so, method 2 should be used. C 75 IF (METH(I) .GE. 2) RETURN IF ( DABS(X(1)) + DABS(X(2)) + DABS(X(3)) .EQ. D0 ) METH(I) = 2 END * *----------------------------------------------------------------------- * E *----------------------------------------------------------------------- * Returns the value of the off-diagonal energy parameter * for the (i,j) pair from the data structure. * DOUBLE PRECISION FUNCTION E(I,J) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1) + 1 IEND = IEPTR(I) E = 0.D0 DO 10 II = IBEGIN,IEND IF (IJE(II) .EQ. J) THEN E = EIJ(II) RETURN END IF 10 CONTINUE END * *----------------------------------------------------------------------- * E I J S E T *----------------------------------------------------------------------- * * Stores the value of the off-diagonal energy parameter for the * pair (i,j) in the data structure * SUBROUTINE EIJSET(I,J,E) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1)+1 IEND = IEPTR(I) DO 10 II = IBEGIN,IEND IF (IJE(II) .EQ. J) THEN EIJ(II) = E RETURN END IF 10 CONTINUE * * ***** J-value not found - enter into list * IF (IJE(98) .NE. 0) : STOP ' Too many off-diagonal energy parameters' * * ***** Find point at which the insertion should be made * IEND = IEPTR(I) IF (IEND .NE. 0) THEN IP = 1 IF (I .GT. 1) IP = IEPTR(I-1)+1 30 IF (IJE(IP) .LT. J .AND. IP .LE. IEND) THEN IP = IP + 1 GO TO 30 END IF ELSE IP = 1 END IF * * ***** IP is the location in which EIJ should be stored * Move other data * DO 40 JJ = (98)-1,IP,-1 IJE(JJ+1) = IJE(JJ) EIJ(JJ+1) = EIJ(JJ) 40 CONTINUE * * ***** Space has been made - insert data * IJE(IP) = J EIJ(IP) = E * * ***** Update pointers * DO 50 II = I,NWF IEPTR(II) = IEPTR(II) +1 50 CONTINUE END * * ------------------------------------------------------------------ * L S T E R M * ------------------------------------------------------------------ * * Determine the LS term value from the COUPLE array * SUBROUTINE LSTERM(COUPLE,I,LS) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH CHARACTER*3 COUPLE(NCD,9),LS*2 * J = 9 10 IF (COUPLE(I,J) .EQ. ' ') THEN J = J-1 IF ( J .GT. 0) THEN GO TO 10 ELSE WRITE(ERR,*) 'COUPLING information missing' STOP END IF END IF LS = COUPLE(I,J)(1:2) IF (LS(2:2) .GE. 'a' .AND. LS(2:2) .LE. 'z') : LS(2:2) = CHAR(ICHAR(LS(2:2)) + ICHAR('A') - ICHAR('a')) END * * ------------------------------------------------------------------ * P O T L * ------------------------------------------------------------------ * * Computes and stores the potential function * 2(k-1) * YR = SUM a Y (j,j;r) * j,k ijk * SUBROUTINE POTL(I) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR PARAMETER (IDIM=550,NCDIM=5000) COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * DO 1 J=1,NO 1 YR(J) = D0 DO 2 J = 1,NWF IF (I.GT.NCLOSD .AND. J.GT.NCLOSD) GO TO 2 C = SUM(J) IF ( I.EQ.J ) C = C - D1 CALL YKF(J,J,0,REL) DO 3 JJ = 1,NO YR(JJ) = YR(JJ) + C*YK(JJ) 3 CONTINUE IF ( I.EQ.J .AND. L(I) .GT. 0) THEN DO 4 K = 2,2*L(I),2 CC = -C*CA(L(I),K) CALL YKF(I,I,K,REL) DO 5 JJ = 1,NO YR(JJ) = YR(JJ) + CC*YK(JJ) 5 CONTINUE 4 CONTINUE END IF 2 CONTINUE * SUMI = SUM(I) IBEGIN = 1 IEND = INTPTR(1) DO 10 J = IBEGIN,IEND IE = 0 IF (IEL(J,1) .EQ. I) THEN IE = IEL(J,2) ELSE IF (IEL(J,2) .EQ. I) THEN IE = IEL(J,1) END IF IF (IE .NE. 0) THEN C = COEF(J)/SUMI IF (IEL(J,1) .EQ. IEL(J,2)) C = 2*C CALL YKF(IE,IE,KVAL(J),REL) DO 12 JJ = 1,NO YR(JJ) = YR(JJ) + C*YK(JJ) 12 CONTINUE END IF 10 CONTINUE END * * ------------------------------------------------------------------ * Q U A D * ------------------------------------------------------------------ * * Evaluates the integral of F(r)G(r) with respect to r , where * F(r) and G(r) have the same asymptotic properties as P (r). The * i * composite Simpson's rule is used. The integrand is zero for r > * r . * M * DOUBLE PRECISION FUNCTION QUAD(I,M,F,G) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * DIMENSION F(NOD),G(NOD) * D = (D1 + D5*Z*R(1))/(H1*(2*L(I) + 3)) QUAD = RR(1)* F(1)*G(1)*( D -D5) QUAD2 = D0 DO 1 J = 2,M,2 QUAD = QUAD + RR(J-1)*F(J-1)*G(J-1) QUAD2 = QUAD2 + RR(J)*F(J)*G(J) 1 CONTINUE QUAD = H1*(QUAD + D2*QUAD2) RETURN END * *--------------------------------------------------------------------- * S E T O R T *--------------------------------------------------------------------- * * Determine if orbitals for electrons (el1, el2) should be * orthogonal. * LOGICAL FUNCTION SETORT(EL1,EL2) CHARACTER*3 EL1,EL2 CHARACTER*1 S1, S2 * IF (EL1(1:1) .EQ. ' ') THEN S1 = ' ' ELSE S1 = EL1(3:3) END IF IF (EL2(1:1) .EQ. ' ') THEN S2 = ' ' ELSE S2 = EL2(3:3) END IF * IF (S1 .EQ. ' ' .OR. S2 .EQ. ' ') THEN SETORT = .TRUE. ELSE IF (S1 .EQ. S2) THEN SETORT = .TRUE. ELSE SETORT = .FALSE. END IF RETURN END * *----------------------------------------------------------------------- * U P D A T E *----------------------------------------------------------------------- * * Evaluate all integrals where at least on orbital has changed. * SUBROUTINE UPDATE IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR PARAMETER (IDIM=550,NCDIM=5000) * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL CHANGE IBEGIN = 1 IEND = INTPTR(3) DO 1 I = IBEGIN,IEND IF (VARIED(IEL(I,1)) .OR. VARIED(IEL(I,2))) THEN IF (I .LE. INTPTR(1)) THEN VALUE(I) = FK(IEL(I,1),IEL(I,2),KVAL(I),REL) ELSE IF (I .LE. INTPTR(2)) THEN VALUE(I) = GK(IEL(I,1),IEL(I,2),KVAL(I),REL) ELSE VALUE(I) = QUADR(IEL(I,1),IEL(I,2),0)**KVAL(I) END IF END IF 1 CONTINUE * IBEGIN = IEND + 1 IEND = INTPTR(4) DO 30 I = IBEGIN,IEND CHANGE = .FALSE. DO 31 J = 1,4 CHANGE = CHANGE .OR. VARIED(IEL(I,J)) 31 CONTINUE IF (CHANGE) THEN K1 = KVAL(I)/64 K2 = KVAL(I) - 64*K1 VALUE(I) = QUADR(IEL(I,1),IEL(I,2),0)**K1 : *QUADR(IEL(I,3),IEL(I,4),0)**K2 END IF 30 CONTINUE IBEGIN = IEND + 1 IEND = INTPTR(5) DO 10 I = IBEGIN,IEND CHANGE = .FALSE. DO 11 J = 1,4 CHANGE = CHANGE .OR. VARIED(IEL(I,J)) 11 CONTINUE IF (CHANGE) VALUE(I) : = RK(IEL(I,1),IEL(I,2),IEL(I,3),IEL(I,4),KVAL(I),REL) 10 CONTINUE * IBEGIN = IEND + 1 IEND = INTPTR(6) DO 20 I = IBEGIN,IEND IF (VARIED(IEL(I,1)) .OR. VARIED(IEL(I,2))) : VALUE(I) = HLC(EL,IEL(I,1),IEL(I,2),REL) 20 CONTINUE * * ... Test if any of the core functions have changed * CHANGE = .FALSE. DO 35 I = 1,NCLOSD CHANGE = CHANGE .OR. VARIED(I) 35 CONTINUE IF (CHANGE .OR. EC.EQ.D0) CALL ECORE(EL,EC,REL) * DO 40 I = 1,NWF VARIED(I) = .FALSE. 40 CONTINUE END * * ------------------------------------------------------------------ * W A V E F N * ------------------------------------------------------------------ * * This routine initializes radial functions by the procedure * indicated by IND(I). * * Value of IND(I) Method * --------------- ------ * -1 Functions read from unit IU2 * 0 Screened hydrogenic functions with ZZ=Z-S(I) * 1 Functions in memory left unchanged * 0 * The set of functions are then orthogonalized, Y (i, i;r) and the * diagonal energy parameters computed, when necessary. * * SUBROUTINE WAVEFN IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON ZZ(NWD),IND(NWD),PN,Z2,FN,M,K,ZT, 1 ETI,EKI,AZI,PT(NOD),MT * CHARACTER EL1*3,AT*6,TT*6,ATM(NWD)*6,TRM(NWD)*6,TITLE*24 * * ***** GENERATE ARRAYS FOR R,R*R AND SQRT(R) WITH A CONSTANT MESH * ***** SIZE IN THE LOG(Z*R) VARIABLE * DO 1 I=1,NO R(I)= DEXP(RHO)/Z RR(I) = R(I)*R(I) R2(I) = DSQRT(R(I)) 1 RHO = RHO + H RHO = RHO - NO*H * * ***** READ THE WAVEFUNCTIONS * IF (IUF .EQ. 0) GO TO 5 2 READ(IUF,END=5) AT,TT,EL1,MM,ZT,ETI,EKI,AZI,(PT(J),J=1,MM) M = MIN0(NO,MM) CALL EPTR(EL,EL1,I,*2) IF ( I .GT. 0 .AND. IND(I) .EQ. -1) THEN ATM(I) = AT TRM(I) = TT MAX(I) = M ZZ(I) = ZT C = D1 IF ( Z .NE. ZT ) C = Z/ZT * * ***** SCALE RESULTS IF CARDS ARE FOR AN ATOM WITH A DIFFERENT Z * CALL EIJSET(I,I,C*C*ETI) AZ(I) = AZI*C**(L(I)+1)*DSQRT(C) DO 11 J = 1,M P(J,I) = C*PT(J) 11 CONTINUE * * ***** SET REMAINING VALUES IN THE RANGE = 0. * IF ( M .EQ. NO ) GO TO 12 M = M +1 DO 13 J=M,NO 13 P(J,I) = D0 12 IND(I) = -2 ENDIF GO TO 2 * * ***** SET PARAMTERS FOR ELECTRONS AND INITIALIZE FUNCTIONS * 5 DO 9 I = 1,NWF IF (IND(I)) 7,8,9 * * ***** WAVE FUNCTIONS NOT FOUND IN THE INPUT DATA, SET IND = 0 * 7 IF ( IND(I) .EQ. -2 ) GO TO 4 IF (METH(I) .EQ. 4) GO TO 9 IND(I) = 0 WRITE(OUT,27) EL(I) 27 FORMAT(8X,'WAVE FUNCTIONS NOT FOUND FOR ',A3) * * ***** DETERMINE ESTIMATES OF THE WAVE FUNCTIONS BY THE SCREENED * ***** HYDROGENIC APPROXIMATION * 8 PN = HNORM(N(I),L(I),Z-S(I)) DO 3 J=1,NO P(J,I) = PN*HWF(N(I),L(I),Z-S(I),R(J))/R2(J) write(78,'(2f15.7)') R(j), P(J,i) 3 CONTINUE M = NO 30 IF ( DABS(P(M,I)) .GT. 1.D-15 ) GO TO 31 P(M,I) = D0 M = M-1 GO TO 30 31 MAX(I) = M * * ***** SET THE AZ(I) VALUE * AZ(I) = PN*(D2*(Z - D5*S(I))/N(I))**(L(I) + 1) CALL EIJSET(I,I,D0) * * ***** ORTHOGONALIZE TO INNER FUNCTIONS * 4 IF (I .EQ. 1 ) GO TO 9 IM = I - 1 DO 6 II =1,IM IF (E(I,II) .EQ. D0) GO TO 6 PN = QUADR(I,II,0) IF ( DABS(PN) .GT. 1.D-8 ) THEN PNN = DSQRT(D1 - PN*PN) IF (P(50,I) - PN*P(50,II) .LT. D0) PNN = -PNN M = MAX0(MAX(I),MAX(II)) DO 25 J = 1,M 25 P(J,I) =(P(J,I) - PN*P(J,II))/PNN END IF 6 CONTINUE 9 CONTINUE WRITE(PRI,14) 14 FORMAT(/// 8X,18HINITIAL ESTIMATES //10X,2HNL, 1 4X,5HSIGMA,6X,5HE(NL),4X,6HAZ(NL),4X,9HFUNCTIONS//) * * ***** COMPUTE ONE-ELECTRON ENERGY PARAMETERS IF THEY WERE NOT * ***** SPECIFIED ON INPUT. * DO 15 I = 1,NWF * IF (E(I,I) .EQ. D0) E(I,I) = HL(EL,I,I,REL) - EKIN(I,I) K = IND(I) + 2 IF ( IND(I) .EQ. -2 ) THEN TITLE = ' SCALED '//ATM(I)//TRM(I) ELSE IF (IND(I) .EQ. 0) THEN TITLE = ' SCREENED HYDROGENIC' ELSE TITLE = ' UNCHANGED' END IF 17 WRITE(PRI,19) EL(I),S(I),E(I,I),AZ(I),TITLE 19 FORMAT(9X,A3,F9.2,F11.3,F10.3,3X,A24) 15 CONTINUE IF ( IUF .NE. 0) REWIND(UNIT=IUF) RETURN END * * ------------------------------------------------------------------ * FGCOUL * ------------------------------------------------------------------ * SUBROUTINE FGCOUL(I,M,cn,delta) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) DOUBLE PRECISION K * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) COMMON /CONTIN/FK(NOD),FH(260),XH(260),rh(260),r2h(260),ph(260), : CD,FL,ZL,ZF,V,NJ,MJ,MP,IX COMMON /COULFG/FKC(NOD),XC(NOD),PDC(NOD),FHC(260),PHC(260),NJM dimension xhc(260) data ED0,LL0 / 1.d0, -1 / PI = ACOS(-D1) PII = PI + PI ED = E(I,I) LL = L(I) K = SQRT(-ED) ifirst = 0 if( ed .eq. ed0 .and. ll .eq. ll0 ) ifirst = 1 if( ifirst .eq. 1 ) goto 10 it =1 azd = d1 do j=1,no pdc(j)= d0 xc(j)=0.d0 enddo ed0 = ed ll0 = ll * * ***** iv) Compute starting values from series expansion * CC = D2*FL + D3 ZLF= ZF/(FL+D1) A2 = ( ED/D2 + ZLF*ZF)/CC A3 = -(( ED/D2)*ZLF + ZF*A2)/(D3*(FL+D2)) DO 6 J = 1,2 6 PDC(J) = AZD*R(J)**LL*R2(J)* : (R(J)*(R(J)*(R(J)*A3 + A2) -ZLF) +D1) * * ***** Solve the differential equation. * MM = MIN0( NO-2, NJ+129) do j=1,260 xhc(j)=0.d0 enddo 2 CALL CNMRV(NJ,MM,1,AZD,FKC,XC,FHC,XHC,PHC,PDC) if( it .eq. 3 ) goto 10 * * * ***** iii) Add the deferred difference correction to the exchange * ***** for the outward integration region * it = it + 1 X1 = PDC(1)*FKC(1) X2 = PDC(2)*FKC(2) X3 = PDC(3)*FKC(3) X4 = PDC(4)*FKC(4) DO 7 J = 3,NJ X5 = PDC(J+2)*FKC(J+2) XC(J) = - (X5 -D4*(X2 + X4) + D6*X3 +X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 7 CONTINUE RL = LL + 2.5 XC(2) = R(2)**RL*(XC(5)/R(5)**RL - D3*(XC(4)/R(4)**RL - : XC(3)/R(3)**RL)) goto 2 * * ***** From the Coulomb functions we calculate the phase shift and * ***** the amplitude. * 10 H60 = 2.d0/(60.d0*H) MJ = MAX0(NJ+2,NJM) MJ = MAX0(MJ,MP) if( MJ .gt. M - 4 ) MJ = M - 4 95 MJ = MJ + 2 if( MJ .gt. M-2 ) then write(*,*) : ' Failed in Calculating Coulomb Functions, R(M) too small ' write(*,*) ' R(M) =', R(M) stop endif MJH = 2*(MJ-NJ)+1 cc DO 90 J = MJH-1,MJH xval = RH(j) yval = PHC(J)*R2h(J) c c y'(r) c dyval = ( PHC(J+3) - PHC(J-3) - 9.d0*( PHC(J+2)-PHC(J-2) ) : + 45.d0*( PHC(J+1) - PHC(J-1) ) )*h60 dyval = ( dyval + 0.5d0*PHC(J) )/R2h(J) CALL fgwkb(k,zf,ll,xval,yval,dyval,f2,df,g2,dg,ierr) if( ierr .ne. 0 ) goto 95 if( J .eq. MJH-1 ) then F1 = f2 G1 = G2 endif 90 CONTINUE DNUM = R2h(MJH)*PH(MJH)*F1 - R2H(MJH-1)*PH(MJH-1)*F2 DENO = R2h(MJH-1)*PH(MJH-1)*G2 - R2H(MJH)*PH(MJH)*G1 DELTA = ATAN( DNUM/DENO ) AMP = R2H(MJH)*PH(MJH)/(F2 + G2*(DNUM/DENO) ) CN = COS(DELTA) / AMP END * ------------------------------------------------------------------ * F G W K B * ------------------------------------------------------------------ * * This routine determines the energy normalized * Coulomb functions F , and G, * and their derivatives F' , G' , with respect to r * * Normalization obtained using the WKB method as proposed by * Liu, Xi, and Li, PRA48, 228(1993) * * Written my Jinhua Xi, December, 1994 * ------------------------------------------------------------------ * * F = sin( phi) * sqrt(2/pi k) * subroutine fgwkb(ek,z,l,r,yr,dyr,f,df,g,dg,ierr) Implicit double precision (a-h,o-z) data pi,pii/3.141592653589793d0,6.283185307179586d0/ ierr=0 call wkb(ek,z,l,r,zeta,dz,deltaz) if( dabs(deltaz) .gt. 1.d-4 ) ierr=1 if( dabs(deltaz) .gt. 1.d-1) then ierr=2 return endif * * determine the phase function phi(r) and the * normalization constant * dzz = 0.5d0*dz/zeta pn= dsqrt(2.d0/pi/zeta) * phi = atan( zeta/(dyr/yr + dzz) ) if( sin(phi)*yr .lt. 0.d0 ) phi =phi + pi if( phi .lt. 0.d0 ) phi=phi+pii if( phi .gt. pii ) phi = phi - pii c c for Coulomb potential , get the F, G, F',G' c f = dsin(phi)*pn g = dcos(phi)*pn df = zeta*g - dzz*f dg = - zeta*f - dzz*g return end * * ------------------------------------------------------------------ * W K B * ------------------------------------------------------------------ * * This routine performs the WKB iteration proposed by * Liu, Xi, and Li, PRA48, 228(1993) * * The exact formulas for the iterative procedure were * derived by C. F. Fischer, using the MAPLE Symbol * manipulation package. * * This routine is called by asympn and fgwkb. * asympn: determines phase and normalization, * as proposed by LXL paper * fgwkb: computes only f,g, f',g' * * Written by C. F. Fischer, July, 1994 * Modified by Jinhua Xi, December, 1994 * ------------------------------------------------------------------ subroutine wkb(ek,z,l,r,zeta,dz,deltaz) Implicit double precision (a-h,o-z) double precision w(0:8), u(0:8,0:4) cxi cxi it is ABSOLUTELY necessary to initiate the arrays cxi if you would like to have a correct result. cxi do 1 i=0,8 w(i)=0.d0 do 2 j=0,4 u(i,j)=0.d0 2 continue 1 continue cxi cxi ................................................... cxi a= 2*z/r b= -l*(l+1)/r/r ekk=ek*ek w(0) = ekk + a + b if( w(0) .lt. 0.3d0*ekk ) then write(*,*) ' in WKB: r-value too small, r=', r deltaz=99.d0 return endif u(0,0) = w(0) do 10 i = 1,8 a = -i*a/r b = -(i+1)*b/r w(i) = a+b u(i,0) = w(i)/w(0) 10 continue do 20 j = 0,3 u(0,j+1) = w(0) + (5*u(1,j)**2 -4*u(2,j))/16.d0 do 30 i = 1, 6-2*j if (i .eq. 1) then u(1,j+1) = 7*u(1,j)*u(2,j)-5*u(1,j)**3 -2*u(3,j) else if (i .eq. 2) then u(2,j+1) = 7*u(2,j)**2 -29*u(1,j)**2*u(2,j) + : 9*u(1,j)*u(3,j) +15*u(1,j)**4 -2*u(4,j) else if (i .eq. 3) then u(3,j+1) = 23*u(2,j)*u(3,j) -72*u(2,j)**2*u(1,j) + : 147*u(1,j)**3*u(2,j) - 47*u(1,j)**3*u(2,j) + : 11*u(1,j)*u(4,j) - 15*u(1,j)**5 -2*u(5,j) else if (i .eq. 4) then u(4,j+1) = 23*u(3,j)**2 -284*u(2,j)*u(3,j)*u(1,j) + : 34*u(2,j)*u(4,j) + 657*(u(2,j)*u(1,j))**2 - : 72*u(2,j)**3 - 888*u(1,j)**4*u(2,j) + : 288*u(1,j)**3*u(3,j) -69*u(1,j)**2*u(4,j) + : 13*u(1,j)*u(5,j) + 300*u(1,j)**6 - 2*u(6,j) else if (i .eq. 5) then cxi do iii=0,8 cxi write(*,'(5d15.5)') (u(iii,jjj), jjj=0,4) cxi enddo u(5,j+1) = -2*u(7,j) + 3030*u(2,j)*u(3,j)*u(1,j)**2 - : 490*u(2,j)*u(4,j)*u(1,j) - : 500*u(2,j)**2*u(3,j) +47*u(2,j)*u(5,j) - : 2040*u(1,j)**4*u(3,j) +495*u(1,3)**3*u(4,j) - : 95*u(1,j)**2*u(5,j) +15*u(1,j)*u(6,j) - : 1800*u(1,j)**7 +80*u(3,j)*u(4,j)- : 330*u(3,j)**2*u(1,j) - : 6180*u(2,j)**2*u(1,j)**3 + : 1530*u(2,j)**3*u(1,j) + 6240*u(1,j)**5*u(2,j) else if (i .eq. 6) then u(6,j+1) = -2*u(8,j) + 62100*u(2,j)**2*u(1,j)**4 - : 24660*u(2,j)**3*u(1,j)**2 + : 4020*u(3,j)**2*u(1,j)**2 - : 32640*u(2,j)*u(3,j)*u(1,j)**3 + : 5985*u(2,j)*u(4,j)*u(1,j)**2 + : 12150*u(2,j)**2*u(3,j)*u(1,j) - : 1310*u(3,j)*u(4,j)*u(1,j) - : 774*u(2,j)*u(5,j)*u(1,j) - : 990*u(2,j)**2*u(4,j) -1330*u(2,j)*u(3,j)**2 + : 16440*u(1,j)**5*u(3,j) +17*u(7,j)*u(1,j) + : 127*u(3,j)*u(5,j) +62*u(2,j)*u(6,j) - : 4020*u(1,j)**4*u(1,4) + 780*u(1,j)**3*u(5,j) - : 125*u(1,j)**2*u(6,j) -50040*u(1,j)**6*u(2,j) + : 12600*u(1,j)**8 +80*u(4,j)**2 + 1530*u(2,j)**4 end if u(i,j+1) = (w(i) + u(i,j+1)/8.d0)/u(0,j+1) 30 continue 20 continue if( u(0,3) .le. 0.d0 .or. u(0,4) .le. 0.d0 ) then write(*,*) ' in WKB: r-value too small, r=', r deltaz=99.d0 return endif zeta = sqrt(u(0,4)) dz = (w(1)+(7*u(1,3)*u(2,3)-5*u(1,3)**3-2*u(3,2))/8)/(2*zeta) deltaz = zeta - sqrt(u(0,3)) return end * * ------------------------------------------------------------------ * G E T E I J * ------------------------------------------------------------------ * * This routine adjusts the lagrange multiplier so as to * satisfy the orthogonality condition * subroutine geteij(n0,eij,ov) implicit real*8(a-h,o-z) common /saveeij/e1,e2,o1,o2,n EF(e1,e2,o1,o2) = (e1*o2-e2*o1)/(o2-o1) EFF(e1,e2,eij,k) = (k+1.)*(e1+e2) - (k+k+1.)*eij k0=3 if( n0 .ne. 0 ) goto 5 n0=1 if( n .eq. 2 ) then n=1 eij0 = eij if( eij .gt. e2 ) then eij = e1 else if( eij .lt. e1 ) then eij = e2 else ediff = e2-e1 eij = eij + ediff endif e1=eij0 o1=ov return else n = 0 endif 5 if( n .eq. 2 ) goto 10 n = n + 1 if( n .eq. 1 ) then e1=eij o1=ov eij = - 2.d0* dabs(eij) return else e2 = eij o2 = ov cxi let e1 < e2 cxi call order12(e1,e2,o1,o2) if( o1*o2 .lt. 0.d0 ) then eij = EF(e1,e2,o1,o2) else cxi cxi if e0 = e1: eij = e2 + k del, del = e2-e1 cxi if e0 = e2: eij = e1 - k del cxi ==>: eij = (k+1)(e1+e2) - (2k+1)e cxi eij =EFF(e1,e2,eij,k0) endif return endif cxi cxi already saved 2 eij values cxi the current one is the third one cxi cxi cxi if level 00000000000000000000000000000000000 cxi 10 if( o1*o2 .lt. 0.d0 ) then cxi cxi o1, o2 opposite sign cxi if( ov*o1 .lt. 0.d0 ) then e2 = eij o2 = ov else if( ov*o2 .lt. 0.d0 ) then e1 = eij o1 = ov else stop ' imposible case in geteij ' endif call order12(e1,e2,o1,o2) eij = EF(e1,e2,o1,o2) return cxi cxi o1, o2 same sign cxi cxi else level 00000000000000000000000000000000000 cxi else cxi.......................................... if( ov*o1 .lt. 0.d0 ) then cxi cxi case: e --- e1 --- e2 cxi if( eij .lt. e1 ) then e2 = e1 o2 = o1 e1 = eij o1 = ov else cxi cxi case: e1 --- e2 --- e cxi e1 = e2 o1 = o2 e2 = eij o2 = ov endif eij = EF(e1,e2,o1,o2) return else cxi cxi o,o1,o2 same sign cxi if( eij .lt. e1 ) then e1 = eij o1 = ov else e2 = eij o2 = ov endif eij = EFF(e1,e2,eij,k0) return endif cxi............................................ cxi cxi endif level 00000000000000000000000000000000000 cxi endif end subroutine order12(e1,e2,o1,o2) implicit real*8(a-h,o-z) if( e1 .gt. e2 ) then et = e1 ot = o1 e1 = e2 o1 = o2 e2 = et o2 = ot endif end * * ***** iv) Compute starting values from series expansion * CC = D2*FL + D3 ZLF= ZF/(FL+D1) A2 = ( ED/D2 + ZLF*ZF)/CC A3 = -(( ED/D2)*ZLF + ZF*A2)/(D3*(FL+D2)) DO 6 J = 1,2 6 PDC(J) = AZD*R(J)**LL*R2(J)* : (R(J)*(R(J)*(R(J)*A3 + A2) -ZLF) +D1) * * ***** Solve the differential equation. * MM = MIN0( NO-2, NJ+129) do j=1,260 xhc(j)=0.d0 enddo 2 CALL CNMRV(NJ,MM,1,AZD,FKC,XC,FHC,XHC,PHCatsp/src/BREIT.f010064400002010000036000004417250626675464500132550ustar00cffcsf00000400000020************************************************************************ * PROGRAM BREIT * * C O P Y R I G H T -- 1994 * * --- Adapted from CIV3 (R. Glass and A. Hibbert) by * A. Hibbert, Queen's Univeristy Belfast, and * C. Froese Fischer, Vanderbilt University * * August, 1982 * * Computer Physics Communications, Vol. 64, 455--472 (1991). * * CLSHBW corrected Jan, 1997 ************************************************************************ * * --- THIS PROGRAM EVALUATES THE BREIT-PAULI OPERATORS * * ONE-ELECTRON OPERATOR * ELECTROSTATIC INTERACTION * SPIN-ORBIT INTERACTION * SPIN-OTHER-ORBIT INTERACTION * SPIN-SPIN INTERACTION * IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * CHARACTER ANS*2, NAME(2)*24 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DIAGNL/IDIAG,JA,JB COMMON /FOUT/NOV(2),IOVLAP(10,2),NF,NG,NR,NL,NZ,NN,NV,NS,IFLAG,NIJ COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/KRON/IDEL(10,10) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/PHASES/SIGNFA(NCD2),ICSTAS COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) DIMENSION NFLG(20),IRFST(NCD2),NCOUNT(8) EQUIVALENCE (NCOUNT(1),NF) LOGICAL INCL * * 105 FORMAT (49H ISPORB=0 AND ISOORB=1 CAUSES THE PROGRAM TO FAIL, : 34H BECAUSE THE BLUME WATSON FORMULAE,/ : 50H CANNOT BE USED FOR CLOSED SUBSHELLS. TO OVERCOME, : 34H THIS, THE CODE HAS SET ISPORB = 1//) 11 FORMAT(////' THE TYPE OF CALCULATION IS DEFINED BY ', : 'THE FOLLOWING PARAMETERS - '/ : 5X,22H BREIT-PAULI OPERATORS,13X,8HIREL =,I2/ : 5X,27H PHASE CONVENTION PARAMETER,8X,8HICSTAS =,I2/) 13 FORMAT(40H RELATIVISTIC OPERATORS TO BE INCLUDED -/5X,13H SPIN-ORB :IT (,I1,22H), SPIN-OTHER-ORBIT (,I1,15H), SPIN-SPIN (,I1,1H)/) 24 FORMAT(36H0INITIAL DEBUG: IN 1-ELECTRON PART =,I2,2H ,,5X, : 20H IN 2-ELECTRON PART=,I2/16X,23HIN RECOUPLING PACKAGE =,I2/) 42 FORMAT(//' MATRIX ELEMENTS CONSTRUCTED USING ', : 'THE SPHERICAL HARMONIC PHASE CONVENTION OF'/) 43 FORMAT(16X,47HCONDON AND SHORTLEY, THEORY OF ATOMIC STRUCTURE/16X, :47H-----------------------------------------------///) 44 FORMAT(25X,42HFANO AND RACAH, IRREDUCIBLE TENSORIAL SETS/25X,42H-- :----------------------------------------///) 50 FORMAT(/20X,'======================='/ : 20X,' B R E I T - P A U L I '/ : 20X,'======================='/) 78 FORMAT(19H DEBUG PARAMETERS -/5X,16H NBUG6(TENSOR) =,I2/5X, : ' NBUG7(RELATIVISTIC OPERATORS - SO,SOO,SS) =',I2//) * * SET INPUT AND OUTPUT CHANNELS * IREAD=4 IWRITE=6 IOUT = 7 DO 2 I = 1,8 ISC(I) = 10 + I NCOUNT(I) = 0 OPEN(UNIT=ISC(I),STATUS='SCRATCH',FORM='UNFORMATTED') 2 CONTINUE NAME(1) = 'cfg.inp' NAME(2) = 'int.lst' CSUN i = iargc() CSUN if (i .ge. 1) then CSUN call getarg(1,NAME(1)) CSUN if (i .eq. 2) call getarg(2,NAME(2)) CSUN end if OPEN(UNIT=IOUT,FILE=NAME(2),STATUS='UNKNOWN') NIJ = 0 NHDEL=10 MXIHSH=(10) * * WRITE HEADING * 10 WRITE(IWRITE,50) * WRITE(0,'(A/A/A/A)') ' Indicate the type of calculation ', : ' 0 => non-relativistic Hamiltonian only;', : ' 1 => one or more relativistic operators only;', : ' 2 => non-relativistic operators and selected relativistic: ' READ(5,*) IREL WRITE(0,'(A)') ' Is full print-out requested? (Y/N) ' READ(5,'(A2)') ANS IFULL = 0 IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') IFULL = 1 * * Determine basic parameters (CS phases selected) * * WRITE(0,'(/A)') * : ' Phases:- Condon and Shortley or Fano and Racah ? (CS/FR) ' * READ(5,'(A2)') ANS * IF ( ANS .EQ. 'CS' .OR. ANS .EQ. 'cs') THEN ICSTAS = 1 * ELSE * ICSTAS = 0 * END IF ISPORB = 0 ISOORB = 0 ISPSPN = 0 * IF (IREL .NE. 0) THEN ISPORB = 1 ISOORB = 1 ISPSPN = 1 WRITE(0,'(A)') ' All relativistic operators ? (Y/N) ' READ(5,'(A2)') ANS IF ( ANS .EQ. 'N ' .OR. ANS .EQ. 'n ') THEN WRITE(0,'(A)') ' Spin-orbit ? (Y/N) ' READ(5,'(A2)') ANS IF ( ANS .EQ. 'N ' .OR. ANS .EQ. 'n ') ISPORB = 0 WRITE(0,'(A)') ' Spin-other-orbit ? (Y/N) ' READ(5,'(A2)') ANS IF ( ANS .EQ. 'N ' .OR. ANS .EQ. 'n ') ISOORB = 0 WRITE(0,'(A)') ' Spin-spin ? (Y/N) ' READ(5,'(A2)') ANS IF ( ANS .EQ. 'N ' .OR. ANS .EQ. 'n ') ISPSPN = 0 END IF * IF(ISPORB.EQ.0.AND.ISOORB.NE.0) THEN ISPORB = 1 WRITE (IWRITE,105) END IF END IF * * --: Determine debug parameters * IBUG1 = 0 IBUG2 = 0 IBUG3 = 0 NBUG6 = 0 NBUG7 = 0 * CDBG WRITE(0,'(A)') ' Debug parameters ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF ( ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ') THEN CDBG WRITE(0,'(A)') ' IBUG1 FOR 1-EL PART ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF (ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ' ) IBUG1 = 1 CDBG WRITE(0,'(A)') ' IBUG2 FOR 2-EL PART ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF (ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ' ) IBUG2 = 1 CDBG WRITE(0,'(A)') ' IBUG3 FOR RECOUPLING ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF (ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ' ) IBUG3 = 1 CDBG WRITE(0,'(A)') ' NBUG6 FOR TENSOR ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF (ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ' ) NBUG6 = 1 CDBG WRITE(0,'(A)') ' NBUG7 FOR SO, SOO, SS ? (Y/N) ' CDBG READ(5,'(A2)') ANS CDBG IF (ANS .EQ. 'Y ' .OR. ANS .EQ. 'y ' ) NBUG7 = 1 CDBG END IF CDBG WRITE(IWRITE,24) IBUG1,IBUG2,IBUG3 CDBG WRITE(IWRITE,78) NBUG6,NBUG7 * WRITE(IWRITE,11) IREL,ICSTAS * * SET FACTORIALS AND LOG OF FACTORIALS * 79 CALL INITA * * --- READ IN THE SET OF CONFIGURATIONS * 21 CALL ACNFIG(NAME(1)) * IDG = 0 NZERO = NCFG NEW = NCFG DO 554 I = 1,NZERO 554 IRFST(I) = 1 ISTART = 1 WRITE(0,'(A)') ' All Interactions? (Y/N): ' READ (5,'(A2)') ANS IF (ANS .NE. 'Y' .AND. ANS .NE. 'y') THEN WRITE(0,'(A,I3,A/A)') ' Of the ',NCFG, : ' configurations, how many at the end are new? ', : ' How many configurations define the zero-order set?' READ (5,*) NEW,NZERO IF (NEW .EQ. 0) NEW = NCFG ISTART = NCFG - NEW + 1 IF (NZERO .eq. 0) NZERO = NCFG IF (IREL .NE. 0 .AND. NZERO .NE. NCFG) THEN WRITE(0,'(A)') ' Rel interaction with all the zero block? ' READ (5,'(A2)') ANS IF (ANS .NE. 'Y' .AND. ANS .NE. 'y') THEN DO 553 I = 1,(20) 553 NFLG(I) = 0 WRITE(0,*) ' Define your reference set : FORM(20I3)' READ (5,'(20I3)') (NFLG(I),I=1,(20)) DO 551 I = 1,(ISTART-1) IRFST(I) = 0 DO 552 J = 1,(20) IF (NFLG(J) .EQ. I) THEN IRFST(I) = 1 GO TO 552 ENDIF 552 CONTINUE 551 CONTINUE ENDIF WRITE(0,*) ' Diagonal rel corrections ? (Y/N): ' READ (5,'(A2)') ANS IF (ANS.EQ.'Y'.OR.ANS.EQ.'y') IDG = 1 ENDIF ISTRICT = 1 WRITE(0,*) ' Restricted Two-body interactions? (Y/N); ' READ (5,'(A2)') ANS IF (ANS .NE. 'Y' .and. ANS .NE. 'y' ) ISTRICT = 0 END IF * * ... Start the calculation * 67 DO 6 JA = ISTART, NCFG IF (IFULL .EQ. 0) WRITE(0,'(A,I5)') ' JA =',JA DO 7 JB=1, JA INCL = .FALSE. IF (JB.LE.NZERO.AND.IRFST(JB).EQ.1) INCL = .TRUE. IFLAG = 0 IDIAG = 0 IF (JA .EQ. JB) THEN IDIAG = 1 IF (IDG .EQ. 1) INCL = .TRUE. ENDIF ICOUNT = 0 * * ... Set up defining quantum numbers for each matrix element. * CALL SETUP(JA,JB) IF(IBUG1.NE.0 .OR. IBUG2.NE.0) CALL VIJOUT(JA,JB) IF(IHSH.GT.MXIHSH) STOP * * ... TEST ON POSSIBLE RECOUPLING ORTHOGONALITY. * CALL ORTHOG(LET,INCL) IF (LET .EQ. 0) GO TO 7 IF (IFULL .NE. 0) WRITE(IWRITE,77) 77 FORMAT(///30X,'MULTIPLYING FACTOR',11X,'TYPE OF INTEGRAL') IF (IREL .NE. 1) THEN CALL H0WTS CALL CHOP END IF IF(ISPORB.NE.0.AND.INCL) : CALL SPNORB (ICOUNT,JA,JB) IF (ISTRICT.EQ.1 .AND. IZOUT.EQ.0) THEN ITSOO = ISOORB ITSPSP = ISPSPN ISOORB = 0 ISPSPN = 0 IF (IREL.NE.1) CALL RKWTS(ICOUNT,JA,JB,INCL) ISOORB = ITSOO ISPSPN = ITSPSP ELSE IF(ISOORB.NE.0 .OR. ISPSPN.NE.0 .OR. IREL.NE.1) : CALL RKWTS(ICOUNT,JA,JB,INCL) END IF IF (IFLAG .NE. 0) NIJ = NIJ + 1 7 CONTINUE 6 CONTINUE NTOTAL = ((2*NCFG - NEW +1)*NEW)/2 WRITE(0,*) NTOTAL, ' matrix elements' WRITE(0,*) NIJ, ' non-zero matrix elements' WRITE(0,*) 100*NIJ/REAL(NTOTAL),' % dense' WRITE(0,*) 'NF=',nf,' NG=',ng,' NR=',nr,' NL=',nl WRITE(0,*) 'NZ=',nz,' NN=',nn,' NV=',nv,' NS=',ns WRITE(0,*) 'Total number of terms =', NF+NG+NR+NL+NZ+NN+NV+NS CALL OUTLSJ WRITE(IWRITE,42) IF(ICSTAS.EQ.0) THEN WRITE(IWRITE,44) ELSE WRITE(IWRITE,43) END IF STOP END * * ------------------------------------------------------------------ * A C N F I G * ------------------------------------------------------------------ * SUBROUTINE ACNFIG(INPUT) * IMPLICIT REAL *8(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * CHARACTER INPUT*24 COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/PHASES/SIGNFA(NCD2),ICSTAS COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) 2 FORMAT(1H1////29X,21H---------------------/29X,21HTHE CONFIGURATIO :N SET/29X,21H---------------------///) * * READ IN (AND PRINT OUT) CONFIGURATIONS * WRITE(IWRITE,2) CALL CFGO1(NCFG,MAXORB,IAJCMP,LJCOMP,NJCOMP,NOCCSH, : NELCSH,NOCORB,J1QNRD,NCD2,INPUT) * * DETERMINE THE SIGN ASSOCIATED WITH ANGULAR MOMENTUM PHASE * CONVENTIONS * 22 ISTART=1 23 IEND=NCFG SIGNFA(ISTART)=ONE LBASE=0 N1=NOCCSH(ISTART) DO 7 I=1,N1 N2=NOCORB(I,ISTART) LBASE=LBASE+NELCSH(I,ISTART)*LJCOMP(N2) 7 CONTINUE ISP1=ISTART+1 DO 13 N=ISP1,IEND LPHASE=0 N1=NOCCSH(N) DO 4 I=1,N1 N2=NOCORB(I,N) LPHASE=LPHASE+NELCSH(I,N)*LJCOMP(N2) 4 CONTINUE LPHASE=(LPHASE-LBASE)/2 IF((LPHASE-LPHASE/2*2).EQ.0) GO TO 5 SIGNFA(N)=-ONE GO TO 13 5 SIGNFA(N)=ONE 13 CONTINUE 21 CONTINUE RETURN END * * ------------------------------------------------------------------ * A L L A D D * ------------------------------------------------------------------ * SUBROUTINE ALLADD(IHSH,M3,M4,M5,M6,M7,M8,M9,M10, : M11,M12,M13,M14,M15,M16,M17,M18) M3=IHSH-1 M4=IHSH+1 M5=IHSH+2 M6=2*IHSH-1 M7=M6+1 M8=M3+M6 M9=M8+1 M10=M8+2 M11=M8+3 M12=M8+4 M13=M8+5 M14=M8+6 M15=M8+7 M16=M8+8 M17=M8+9 M18=IHSH+3 RETURN END * * ------------------------------------------------------------------ * B L O C K D A T A * ------------------------------------------------------------------ * BLOCK DATA C IMPLICIT REAL *8(A-H,O-Z) C COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS C C SET GLOBAL REAL CONSTANTS C DATA ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS/ : 0.0D 00,0.1D 00,0.5D 00,1.0D 00,2.0D 00,3.0D 00,4.0D 00, : 7.0D 00,1.1D 01,1.0D-08/ C END * * ------------------------------------------------------------------ * B L M W A T * ------------------------------------------------------------------ * SUBROUTINE BLMWAT(IRHO,ISIG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/BLUME/COEFN2(4),COEFNK(4),COEFVK(4) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DIAGNL/ IDIAG,JA,JB COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/DENKVK/D00N2(12),D00NK(12),D00VK(12),D11N2(12),D11NK(12), : D11VK(12),E01N2(12),E01NK(12),E01VK(12),E10N2(12),E10NK(12), : E10VK(12) COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/SPORB/ACMULT(NWD) * * ... THIS ROUTINE EVALUATES SPIN-OTHER-ORBIT INTERACTIONS BETWEEN * A CLOSED AND AN OPEN SUBSHELL. * IF(IRHO.NE.ISIG) GO TO 100 WRITE (IWRITE,200) JA,JB,IRHO 200 FORMAT (42H WRONG LCALL OF BLMWAT IN MATRIX ELEMENT (,I3, : 11H), SUBSHELL,I2/) STOP 100 N1 = NOSH1(IRHO) LRHO = LJ(IRHO) IFLAG = 0 IF(N1.EQ.(4*LRHO + 2)) GO TO 1 * * ... ENSURE THAT FOR THE REST OF THIS ROUTINE, RHO IS THE CLOSED * SUBSHELL. * ISTO = IRHO IRHO = ISIG ISIG = ISTO LSIG = LRHO LRHO = LJ(IRHO) IFLAG = 1 GO TO 2 1 LSIG = LJ(ISIG) 2 I1 = IJFUL(ISIG) IF (LRHO .EQ. 0 .AND. LSIG .EQ. 0) GO TO 4 * * ... AC2 IS THE COEFFICIENT OF THE SPIN-ORBIT INTEGRAL OF * SUBSHELL SIG. * AC2 = ACMULT(I1) KD1 = 1 KD2 = 1 KE1 = IABS(LSIG - LRHO) + 1 IF(LRHO.EQ.LSIG) KE1 = 3 KE2 = LRHO + LSIG + 1 D00N2(1) = ZERO D00VK(1) = ZERO D11N2(1) = ZERO D11VK(1) = ZERO * * D0:NK(1) AND D11NK(1) WERE INTERCHANGED BY MRG DECEMBER 18, 1981 * D11NK(1) = -2*(LRHO + LRHO + 1)*AC2 D00NK(1) = ZERO CALL BWINT(LRHO,LSIG) L = 0 DO 3 J=KE1, KE2, 2 L = L + 1 E10N2(L) = ZERO E01N2(L) = COEFN2(L)*AC2 E01VK(L) = -COEFVK(L)*AC2 E10VK(L) = -E01VK(L) E10NK(L) = COEFNK(L)*AC2 E01NK(L) = ZERO 3 CONTINUE MULDSO = 1 M1 = ISIG - IRHO M2 = M1 M19 = 0 M20 = 0 MULESO = 1 MULDSS = 0 MULDSP = 0 MULESS = 0 MULESP = 0 CALL RADWTS(IRHO,ISIG,IRHO,ISIG,ICOUNT) 4 IF (IFLAG .EQ. 0) RETURN ISTO = IRHO IRHO = ISIG ISIG = ISTO RETURN END * * ------------------------------------------------------------------ * C H O P * ------------------------------------------------------------------ * SUBROUTINE CHOP IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/DIAGNL/IDIAG,JA,JB * * NO AVERAGE ENERGY TERMS FOR OFF-DIAGONAL MATRIX ELEMENTS * IF(IDIAG.EQ.0) RETURN JSTO=0 ICOUNT=0 DO 3 J=1,IHSH NFULL=4*LJ(J)+2 I2=NOSH1(J) * * IS THE SHELL FULL OR EMPTY * IF(I2.EQ.NFULL.OR.I2.EQ.0) GO TO 4 * * IF NOT, DOES IT CONTAIN ONLY ONE ELECTRON, OR ONLY ONE =HOLE= * IF(I2.EQ.1.OR.I2.EQ.(NFULL-1)) JSTO=J GO TO 3 4 ICOUNT=ICOUNT+1 3 CONTINUE * * IF ALL BUT ONE SHELL IS CLOSED, AND THIS CONTAINS ONE ELECTRON OR * =HOLE= , THEN IT CAN BE TREATED PURELY BY AVERAGE ENERGY * RETURN END * * ------------------------------------------------------------------ * C L S H B W * ------------------------------------------------------------------ * SUBROUTINE CLSHBW(ISIG,ISIGP,IRHO) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * * Uses the formulae of Blume and Watson for the spin-other-orbit * interaction when one of the interacting subshells is full. The * coefficients of the two-electron integrals are related to the * coefficient of the spin-orbit interaction by Blume and Watson's * formulae. * COMMON/BLUME/ COEFN2(4),COEFNK(4),COEFVK(4) COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DIAGNL/IDIAG,JA,JB COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/PHASES/SIGNFA(NCD2),ICSTAS COMMON/SPORB/ ACMULT(NWD) COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) * 3 FORMAT(35X,F14.8,11X,1HN,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 4 FORMAT(35X,F14.8,11X,1HV,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 303 FORMAT(F14.8,1HN,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 304 FORMAT(F14.8,1HV,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 340 FORMAT(9H (CONFIG ,I3,12H/SDD/CONFIG ,I3,1H)) IF (IRHO.EQ.0 .AND. IFULL.EQ.0) RETURN ICOUNT=1 IF(ICSTAS.NE.0)THEN SIGNCH=SIGNFA(JA)*SIGNFA(JB) ELSE SIGNCH=ONE ENDIF M=1 7 IF(ISIG.EQ.0)THEN JM=IJFUL(M) AC2=ACMULT(JM) LB=LJ(M) ELSE AC2=ACMULT(1) JSIG=IJFUL(ISIG) JSIGP=IJFUL(ISIGP) LB=LJ(ISIG) ENDIF IF(ABS(AC2).LT.EPS)GO TO 5 IF(ICOUNT.EQ.1)THEN IF (IFULL .NE. 0) WRITE(IWRITE,340)JA,JB ICOUNT=2 ENDIF AC2=AC2*SIGNCH I=1 6 IF(IRHO.EQ.0)THEN LA=LJCLSD(I) ELSE LA=LJ(IRHO) JRHO=IJFUL(IRHO) ENDIF CALL BWINT(LA,LB) D11NK=-(4*LA+2)*AC2 K=0 IF(IRHO.EQ.0 .AND. IFULL.NE.0)THEN IF(ISIG.EQ.0) THEN WRITE(IWRITE,3)D11NK,K,IAJCMP(M),IAJCLD(I), : IAJCMP(M),IAJCLD(I) ELSE WRITE(IWRITE,3)D11NK,K,IAJCMP(JSIG),IAJCLD(I), : IAJCMP(JSIGP),IAJCLD(1) ENDIF ELSE IF (IFULL.NE.0) : WRITE(IWRITE,3)D11NK,K,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JSIGP),IAJCMP(JRHO) * WRITE(JSC1,303) D11NK,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHO),JB CALL SAVE(6,D11NK,K,JSIG,JRHO,JSIGP,JRHO,JA,JB,0) ENDIF IF(LA.EQ.LB)THEN KE1=3 ELSE KE1=IABS(LA-LB)+1 ENDIF KE2=LA+LB+1 L=0 DO 1 J=KE1,KE2,2 L=L+1 K=J-1 K1=K-1 K2=K-2 E01N2=COEFN2(L)*AC2 E10VK=COEFVK(L)*AC2 E01VK=-E10VK E01NK=COEFNK(L)*AC2 IF(IRHO.EQ.0 .AND. IFULL.NE.0)THEN IF(ISIG.EQ.0)THEN WRITE(IWRITE,3)E01N2,K2,IAJCMP(M),IAJCLD(I), : IAJCLD(I),IAJCMP(M) WRITE(IWRITE,3)E01NK,K, IAJCLD(I),IAJCMP(M), : IAJCMP(M),IAJCLD(I) WRITE(IWRITE,4)E01VK,K1,IAJCLD(I),IAJCMP(M), : IAJCMP(M),IAJCLD(I) WRITE(IWRITE,4)E10VK,K1,IAJCMP(M),IAJCLD(I), : IAJCLD(I),IAJCMP(M) ELSE WRITE(IWRITE,3)E01N2,K2,IAJCMP(JSIG),IAJCLD(I), : IAJCLD(I),IAJCMP(JSIGP) WRITE(IWRITE,3)E01NK,K, IAJCLD(I),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCLD(I) WRITE(IWRITE,4)E01VK,K1,IAJCLD(I),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCLD(I) WRITE(IWRITE,4)E10VK,K1,IAJCMP(JSIG),IAJCLD(I), : IAJCLD(I),IAJCMP(JSIGP) ENDIF ELSE IF (IFULL.NE.0) THEN WRITE(IWRITE,3)E01N2,K2,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHO),IAJCMP(JSIGP) WRITE(IWRITE,3)E01NK,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHO) WRITE(IWRITE,4)E01VK,K1,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHO) WRITE(IWRITE,4)E10VK,K1,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHO),IAJCMP(JSIGP) END IF * WRITE(JSC1,303)E01N2,K2,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHO),IAJCMP(JSIGP),JB * WRITE(JSC1,303)E01NK,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHO),JB * WRITE(JSC2,304)E01VK,K1,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHO),JB * WRITE(JSC2,304)E10VK,K1,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHO),IAJCMP(JSIGP),JB CALL SAVE(6,E01N2,K2,JSIG,JRHO,JRHO,JSIGP,JA,JB,0) CALL SAVE(6,E01NK,K,JRHO,JSIG,JSIGP,JRHO,JA,JB,0) CALL SAVE(7,E01VK,K1,JRHO,JSIG,JSIGP,JRHO,JA,JB,0) CALL SAVE(7,E10VK,K1,JSIG,JRHO,JRHO,JSIGP,JA,JB,0) ENDIF 1 CONTINUE IF(IRHO.EQ.0)THEN I=I+1 IF(I.LE.NCLOSD)GO TO 6 ENDIF 5 IF(ISIG.EQ.0)THEN M=M+1 IF(M.LE.IHSH)GO TO 7 ENDIF RETURN END * * ------------------------------------------------------------------ * C L S H E L * ------------------------------------------------------------------ * SUBROUTINE CLSHEL (ISIG, ISIGP, IRHO ) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK COMMON/ENAV/NINTS,KVALUE(15),COEFCT(15) COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DIAGNL/IDIAG,JA,JB COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/PHASES/SIGNFA(NCD2),ICSTAS * 101 FORMAT(35X,F14.8,11X,1HF,I2,1H(,A3,1H,,A3,1H)) 102 FORMAT(35X,F14.8,11X,1HG,I2,1H(,A3,1H,,A3,1H)) 103 FORMAT(35X,F14.8,11X,1HR,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 104 FORMAT(' (CONFIG ',I3,'/Rij/CONFIG ',I3,')') 203 FORMAT(F14.8,1HR,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) * IF (IRHO.EQ.0 .AND. IFULL.EQ.0) RETURN IF (IFULL .NE. 0) WRITE(IWRITE,104) JA,JB ZERO = 0.D0 IZERO = 0 * SIGNCH = 1. IF (ICSTAS .NE. 0) SIGNCH = SIGNFA(JA)*SIGNFA(JB) * IF (IRHO .NE. 0) GO TO 20 IF (ISIG .NE. 0) GO TO 1 * * --- DIAGONAL CASE - ADD CLOSED SHELL CONTRIBUTIONS * DO 2 J = 1,NCLOSD LA = LJCLSD(J) NA = 4*LA + 2 * * --- CLOSED-CLOSED INTERACTIONS * DO 3 K = 1,J LB = LJCLSD(K) NB = 4*LB + 2 IF (J .EQ. K) GO TO 4 IEQUIV = 2 AC2 = DFLOAT(NA*NB) GO TO 5 4 IEQUIV = 1 AC2 = DFLOAT((NA*(NA-1))/2) 5 CALL INTACT(LA,LB,IEQUIV) WRITE(IWRITE,101) AC2,IZERO,IAJCLD(J),IAJCLD(K) IF(NINTS .EQ. 0) GO TO 3 DO 7 N = 1,NINTS ZA = AC2*COEFCT(N) K1 = KVALUE(N) IF (IEQUIV .EQ. 1) GO TO 8 WRITE (IWRITE, 102) ZA,K1,IAJCLD(J),IAJCLD(K) GO TO 7 8 WRITE(IWRITE,101)ZA,K1,IAJCLD(J),IAJCLD(K) 7 CONTINUE 3 CONTINUE * * --- CLOSED - OPEN INTERACTIONS * DO 9 K = 1, IHSH LB = LJ(K) NB = NOSH1(K) JFULL = IJFUL(K) IEQUIV = 2 AC2 = DFLOAT(NA*NB) CALL INTACT(LA,LB,IEQUIV) WRITE (IWRITE, 101) AC2,IZERO,IAJCLD(J),IAJCMP(JFULL) IF (NINTS .EQ. 0) GO TO 9 DO 10 N = 1,NINTS ZA = AC2*COEFCT(N) K1 = KVALUE(N) WRITE (IWRITE, 102) ZA,K1,IAJCLD(J),IAJCMP(JFULL) 10 CONTINUE 9 CONTINUE 2 CONTINUE RETURN * * --- OFF-DIAGONAL, ONE-ELECTRON DIFFERENT, ADD COMMON * CLOSED-SHELL CONTRIBUTIONS * 1 IF (DABS(B1ELC(1)) .LT. 1.D-10) RETURN LB = LJ(ISIG) JSIG = IJFUL(ISIG) JSIGP = IJFUL(ISIGP) IEQUIV = 2 DO 11 J = 1,NCLOSD KRHO = J + MAXORB LA = LJCLSD(J) NA = 4*LA + 2 AC2 = B1ELC(1)*NA*SIGNCH CALL INTACT(LA,LB,IEQUIV) WRITE(IWRITE,103)AC2,IZERO,IAJCLD(J), : IAJCMP(JSIG),IAJCLD(J),IAJCMP(JSIGP) 15 IF (NINTS .EQ. 0) GO TO 11 DO 12 N=1,NINTS ZA = AC2*COEFCT(N) K = KVALUE(N) WRITE (IWRITE,103) ZA,K,IAJCLD(J),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCLD(J) 12 CONTINUE 11 CONTINUE RETURN * * --- OFF-DIAGONAL, ONE-ELECTRON DIFFERENT, TREAT BY AVERAGE * ENERGY FORMULAE * 20 IF (DABS(B1ELC(1)) .LT. 1.D-10) RETURN LB = LJ(ISIG) LA = LJ(IRHO) JSIG = IJFUL(ISIG) JSIGP = IJFUL(ISIGP) JRHO = IJFUL(IRHO) IEQUIV = 2 CALL INTACT(LA,LB,IEQUIV) NA = 4*LA + 2 AC2 = B1ELC(1)*NA*SIGNCH IF (IFULL .NE. 0) : WRITE(IWRITE,103) AC2,IZERO,IAJCMP(JRHO), : IAJCMP(JSIG),IAJCMP(JRHO),IAJCMP(JSIGP) * WRITE(ISC2,203) AC2,IZERO,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHO),IAJCMP(JSIGP),JB CALL SAVE(3,AC2,IZERO,JRHO,JSIG,JRHO,JSIGP,JA,JB,0) 22 IF (NINTS .EQ. 0) RETURN DO 21 N=1,NINTS ZA = AC2*COEFCT(N) K = KVALUE(N) IF (IFULL .NE. 0) : WRITE (IWRITE,103) ZA,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHO) * WRITE(ISC2,203) ZA,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHO),JB CALL SAVE(3,ZA,K,JRHO,JSIG,JSIGP,JRHO,JA,JB,0) 21 CONTINUE RETURN END * * ------------------------------------------------------------------ * F A N O * ------------------------------------------------------------------ * SUBROUTINE FANO(IRHO,ISIG,IRHOP,ISIGP,JA,JB,INCL) * IMPLICIT REAL *8(A-H,O-Z) * PARAMETER(KFL1=60,KFL2=12, : KFL6=120,KFL7=150,KFL8=120,KFL9=40,KFLW=20, : KFLS=12,KFLN=10,KFLV=40) * DIMENSION NBAR(10) LOGICAL FAILSD,FAILSE,FAILAD,FAILAE,FREE C LOGICAL SMVRSD,SMVRSE,SMVRAD,SMVRAE DIMENSION K6SD(KFL6),K7SD(KFL7),K8SD(KFL8),K9SD(KFL9),KWSD(6,KFLW) + ,LDELSD(KFLW,2),SMVRSD(KFL1) DIMENSION K6SE(KFL6),K7SE(KFL7),K8SE(KFL8),K9SE(KFL9),KWSE(6,KFLW) + ,LDELSE(KFLW,2),SMVRSE(KFL1) DIMENSION K6AD(KFL6),K7AD(KFL7),K8AD(KFL8),K9AD(KFL9),KWAD(6,KFLW) + ,LDELAD(KFLW,2),SMVRAD(KFL1) DIMENSION K6AE(KFL6),K7AE(KFL7),K8AE(KFL8),K9AE(KFL9),KWAE(6,KFLW) + ,LDELAE(KFLW,2),SMVRAE(KFL1) C DIMENSION J6PSD(KFLV),J7PSD(KFLV),J8PSD(KFLV),J9PSD(KFLV), + JWRDSD(6,KFLW), + NBJSD(KFLN),NB6JSD(KFLN),K6CPSD(KFLN),K7CPSD(KFLN),K8CPSD(KFLN), + K9CPSD(KFLN),JSM6SD(KFLS),JSM4SD(KFLS,KFLW),JSM5SD(KFLS,KFLW), + IN6JSD(KFLW) DIMENSION J6PSE(KFLV),J7PSE(KFLV),J8PSE(KFLV),J9PSE(KFLV), + JWRDSE(6,KFLW), + NBJSE(KFLN),NB6JSE(KFLN),K6CPSE(KFLN),K7CPSE(KFLN),K8CPSE(KFLN), + K9CPSE(KFLN),JSM6SE(KFLS),JSM4SE(KFLS,KFLW),JSM5SE(KFLS,KFLW), + IN6JSE(KFLW) DIMENSION J6PAD(KFLV),J7PAD(KFLV),J8PAD(KFLV),J9PAD(KFLV), + JWRDAD(6,KFLW), + NBJAD(KFLN),NB6JAD(KFLN),K6CPAD(KFLN),K7CPAD(KFLN),K8CPAD(KFLN), + K9CPAD(KFLN),JSM6AD(KFLS),JSM4AD(KFLS,KFLW),JSM5AD(KFLS,KFLW), + IN6JAD(KFLW) DIMENSION J6PAE(KFLV),J7PAE(KFLV),J8PAE(KFLV),J9PAE(KFLV), + JWRDAE(6,KFLW), + NBJAE(KFLN),NB6JAE(KFLN),K6CPAE(KFLN),K7CPAE(KFLN),K8CPAE(KFLN), + K9CPAE(KFLN),JSM6AE(KFLS),JSM4AE(KFLS,KFLW),JSM5AE(KFLS,KFLW), + IN6JAE(KFLW) C COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/KRON/IDEL(10,10) COMMON/TERMS/NROWS,ITAB(24),JTAB(24),NTAB(333) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/INTERM/J1BAR1(10,3),J1BAR2(10,3),J1TLD1(3),J1TLD2(3) COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/RMEPRD/RMEDIR(15),RMEEX(15) LOGICAL INCL * * *****:****************************************************************** * * * --- THE ROUTINE FANO TOGETHER WITH THOSE CALLED BY IT, HAS BEEN * MODIFIED TO EVALUATE THE FOLLOWONG MATRIX ELEMENTS FOR GIVEN * RHO, SIG, RHOP, SIGP * * IREL.EQ.0 POTENTIAL MATRIX ELEMENT OF THE NON-RELATIVISTIC * HAMILTONIAN * * IREL.EQ.1 THE RELATIVISTIC OPERATORS OF THE BREIT-PAULI * HAMILTONIAN * * IREL.GE.2 ALL OF THE ABOVE OPERATORS * * *****:****************************************************************** * * 301 FORMAT(21H NO POSSIBLE K-VALUES) 302 FORMAT(66H SPECTATOR QUANTUM NUMBERS NOT DIAGONAL FOR NON-INTERACT :ING SHELLS) 305 FORMAT(23H DIRECT SPIN INTEGRAL =,F10.6) 306 FORMAT(25H EXCHANGE SPIN INTEGRAL =,F10.6) 307 FORMAT(6H NJ,LJ,4(I8,I4)) 308 FORMAT(6H KD1 =,I4,6H KD2 =,I4,6H KE1 =,I4,6H KE2 =,I4) 309 FORMAT(56H ROWS OF TERM TABLE CONTAINING PARENTS ARE, RESPECTIVELY :,2(I6,I3)) 310 FORMAT(26H DIRECT ANGULAR INTEGRAL =,F10.6) 311 FORMAT(3H J1,I6,36I3) 312 FORMAT(28H EXCHANGE ANGULAR INTEGRAL =,F10.6) * * --- SET USEFUL CONSTANTS * M1=ISIG-IRHO M2=ISIGP-IRHOP M19=IRHO-IRHOP M20=ISIG-ISIGP I2HSH=IHSH+IHSH-1 MULTD=0 MULTE=0 * * JSNDIR,JANGDI=0 IMPLIES APPROPRIATE J2,J3 ARRAYS FOR CALL OF * NJSYM HAVE NOT BEEN SET * JSNDIR=0 JANGDI=0 ISPIND=0 ISPINE=0 IANGD =0 IANGE =0 ICALL =0 * * --- Set the FAIL parameters .FALSE. initially so that NJGRAF can * be called * FAILSD = .FALSE. FAILSE = .FALSE. FAILAD = .FALSE. FAILAE = .FALSE. * * --- SET N,L VALUES OF INTERACTING SHELLS * NRHO=NJ(IRHO) LRHO=LJ(IRHO) NSIG=NJ(ISIG) LSIG=LJ(ISIG) NRHOP=NJ(IRHOP) LRHOP=LJ(IRHOP) NSIGP=NJ(ISIGP) LSIGP=LJ(ISIGP) IF(IBUG2.GT.0) : WRITE(IWRITE,307) NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP * * --- EVALUATE MULTIPLICATIVE FACTORS * 160 IL=IDEL(IRHO,ISIG) IR=IDEL(IRHOP,ISIGP) Q=NOSH1(IRHO)*(NOSH1(ISIG)-IL)*NOSH2(IRHOP)*(NOSH2(ISIGP)-IR) XMULT=DSQRT(Q)*HALF FACTOR=DFLOAT((LSIG+LSIG+1)*(LRHOP+LRHOP+1)) FACTO1=DFLOAT((LRHO+LRHO+1)*(LSIG+LSIG+1)) ADIRCT=(1+(1-IL)*(1-IR))/DSQRT(FACTOR) IEXCHG=2-IL-IR FACTOR=DFLOAT((LSIG+LSIG+1)*(LSIGP+LSIGP+1)) AEXCHG=IEXCHG/DSQRT(FACTOR) IF(IREL.EQ.0) GO TO 1 XMULT1=DSQRT(Q/FACTO1)*HALF MULDSO=0 MULESO=0 MULDSS=0 MULDSP=0 MULESS=0 MULESP=0 1 DO 13 J=1,IHSH NBAR(J)=NOSH1(J)-IDEL(J,IRHO)-IDEL(J,ISIG) 13 CONTINUE IDELP=0 IF(M1) 14,15,14 14 K1=IRHO+1 DO 16 J=K1,ISIG IDELP=IDELP+NBAR(J) 16 CONTINUE 15 IF(M2) 17,18,17 17 K1=IRHOP+1 DO 19 J=K1,ISIGP IDELP=IDELP+NBAR(J) 19 CONTINUE 18 XMULT=XMULT*(-ONE)**IDELP IF(IREL.EQ.0) GO TO 500 ACTOR1=DFLOAT(J1QN1(I2HSH,2)*J1QN1(I2HSH,3)) XMULT1=XMULT1*(-ONE)**IDELP*DSQRT(ACTOR1) * * --- DETERMINES RANGES OF K FOR DIRECT AND EXCHANGE INTEGRALS * TRIANGULAR RELATIONS LIMIT (K+1) VALUES TO LIE BETWEEN KD1 AND KD2 * FOR =DIRECT= INTEGRALS, KE1 AND KE2 FOR =EXCHANGE= INTEGRALS * 500 CONTINUE K1=IABS(LSIG-LSIGP) K2=LSIG+LSIGP K3=IABS(LRHO-LRHOP) K4=LRHO+LRHOP KD1=MAX0(K1,K3)+1 KD2=MIN0(K2,K4)+1 K1=IABS(LRHOP-LSIG) K2=LRHOP+LSIG K3=IABS(LRHO-LSIGP) K4=LRHO+LSIGP KE1=MAX0(K1,K3)+1 KE2=MIN0(K2,K4)+1 IF(ISPSPN.EQ.1.AND.INCL) CALL SKLIM(LET) IF(IBUG2.GT.0) : WRITE(IWRITE,308) KD1,KD2,KE1,KE2 612 IF(KD1-KD2) 213,213,211 211 IF(KE1-KE2) 213,213,212 212 IF(IBUG2.GT.0) : WRITE(IWRITE,301) 400 IF(ISPSPN.EQ.0) RETURN IF(LET.EQ.0) RETURN * * --- ZEROIZE MULTIPLYING FACTORS FOR ALLOWED K-VALUES. THE LOWEST * VALUES KD1 AND KD2 ARE ALWAYS ALLOWED (UNLESS THEY ARE * GREATER THAN KD2 AND KE2 RESPECTIVELY). ALLOWED K-VALUES THEN * STEP BY 2 TO SATISFY THE EVEN CONDITION OF THE REDUCED MATRIX * ELEMENTS, WHICH ARE THEN CALCULATED AND STORED * 213 IF(KD1-KD2) 231,231,232 231 DO 230 JK1=KD1,KD2,2 K=JK1-1 AMULT(JK1)=ZERO RMEDIR(JK1)=RME(LRHO,LRHOP,K)*RME(LSIG,LSIGP,K) 230 CONTINUE 232 IF(KE1-KE2) 233,233,241 233 DO 234 JK1=KE1,KE2,2 K=JK1-1 BMULT(JK1)=ZERO RMEEX(JK1)=RME(LRHO,LSIGP,K)*RME(LSIG,LRHOP,K) 234 CONTINUE 241 IF(ISOORB.EQ.1.AND.INCL) CALL SOORED IF(ISPSPN.EQ.1.AND.INCL) CALL SSRED * * --- SET SENIORITY, S AND L VALUES OF SPECTATOR SHELLS * DO 26 J=1,IHSH IF(IRHO-J) 27,29,27 27 IF(ISIG-J) 28,29,28 28 DO 128 K=1,3 J1BAR1(J,K)=J1QN1(J,K) 128 CONTINUE 29 IF(IRHOP-J) 30,26,30 30 IF(ISIGP-J) 31,26,31 31 DO 181 K=1,3 J1BAR2(J,K)=J1QN2(J,K) 181 CONTINUE IF(IRHO-J) 32,26,32 32 IF(ISIG-J) 33,26,33 * * CHECK THAT SPECTATOR SHELLS HAVE SAME RESPECTIVE QUANTUM NUMBERS * 33 DO 183 K=1,3 IF(J1BAR1(J,K)-J1BAR2(J,K)) 402,183,402 183 CONTINUE 26 CONTINUE GO TO 405 402 IF(IBUG2.GT.0) : WRITE(IWRITE,302) 404 RETURN * * --- FROM WHICH ROWS OF NTAB DO WE FIND THE QUANTUM NUMBERS WITH BARS * OR TILDES * 405 NELCTS=NOSH1(ISIG) K2=NTAB1(NELCTS,LSIG+1) IF(M1) 20,21,20 21 NELCTS=NOSH1(ISIG)-1 GO TO 22 20 NELCTS=NOSH1(IRHO) 22 K1=NTAB1(NELCTS,LRHO+1) NELCTS=NOSH2(ISIGP) K4=NTAB1(NELCTS,LSIGP+1) IF(M2) 23,24,23 24 NELCTS=NOSH2(ISIGP)-1 GO TO 25 23 NELCTS=NOSH2(IRHOP) 25 K3=NTAB1(NELCTS,LRHOP+1) IF(IBUG2.GT.0) : WRITE(IWRITE,309) K1,K2,K3,K4 59 KK1=ITAB(K1) KK2=ITAB(K2) KK3=ITAB(K3) KK4=ITAB(K4) * * === SUM OVER QUANTUM NUMBERS WITH BARS OR TILDES * DO 151 JJ2=1,KK2 * * --- TEST TO SEE WHICH PARENT TERMS ARE ALLOWABLE. ONLY TEST THIS ON * L AND S VALUES AT THIS STAGE, BY MEANS OF TRIANGULAR CONDITIONS * FOR TWICE THE QUANTUM NUMBERS, IN ORDER TO USE ONLY INTEGER * QUANTITIES * IN3=2*LSIG IJK2=3*(JJ2-1)+JTAB(K2) DO 131 K=2,3 IN1=NTAB(IJK2+K)-1 IN2=J1QN1(ISIG,K)-1 IF(IN1-IN2-IN3) 130,130,151 130 IF(IN1-IABS(IN2-IN3)) 151,140,140 140 IN3=1 131 CONTINUE DO 152 JJ1=1,KK1 IN3=2*LRHO IJK1=3*(JJ1-1)+JTAB(K1) 162 DO 132 K=2,3 IN1=NTAB(IJK1+K)-1 IF(M1) 141,142,141 141 IN2=J1QN1(IRHO,K)-1 GO TO 143 142 IN2=NTAB(IJK2+K)-1 143 IF(IN1-IN2-IN3) 144,144,152 144 IF(IN1-IABS(IN2-IN3)) 152,145,145 145 IN3=1 132 CONTINUE DO 153 JJ4=1,KK4 IN3=2*LSIGP IJK4=3*(JJ4-1)+JTAB(K4) DO 133 K=2,3 IN1=NTAB(IJK4+K)-1 IN2=J1QN2(ISIGP,K)-1 IF(IN1-IN2-IN3) 146,146,153 146 IF(IN1-IABS(IN2-IN3)) 153,147,147 147 IN3=1 133 CONTINUE DO 154 JJ3=1,KK3 c PRINT*,' JJ2 = ',JJ2,' JJ1 = ',JJ1,' JJ4 = ',JJ4,' JJ3 = ',JJ3 IN3=2*LRHOP IJK3=3*(JJ3-1)+JTAB(K3) 137 DO 134 K=2,3 IN1=NTAB(IJK3+K)-1 IF(M2) 138,139,138 138 IN2=J1QN2(IRHOP,K)-1 GO TO 148 139 IN2=NTAB(IJK4+K)-1 148 IF(IN1-IN2-IN3) 149,149,154 149 IF(IN1-IABS(IN2-IN3)) 154,150,150 150 IN3=1 134 CONTINUE * * SUMMATIONS NOW PERFORMED OVER ALLOWED QUANTUM NUMBERS * THE TILDES CORRESPOND TO IRHO=ISIG AND/OR IRHOP=ISIGP * * --- SET THE REMAINING QUANTUM NUMBERS WITH BARS OR TILDES * DO 35 K=1,3 J1BAR1(IRHO,K)=NTAB(IJK1+K) J1BAR2(IRHOP,K)=NTAB(IJK3+K) IF(M1) 36,37,36 36 J1BAR1(ISIG,K)=NTAB(IJK2+K) GO TO 38 37 J1TLD1(K)=NTAB(IJK2+K) 38 IF( M2) 39,40,39 39 J1BAR2(ISIGP,K)=NTAB(IJK4+K) GO TO 35 40 J1TLD2(K)=NTAB(IJK4+K) 35 CONTINUE * * --- IS POTENTIAL DIAG. IN BARRED QU. NOS. FOR INTERACTING SHELLS * I5=0 I=ISIG GO TO 50 42 I=IRHO IF( M1) 43,44,43 43 GO TO 50 44 I5=I5+1 45 I=ISIGP GO TO 50 46 I=IRHOP IF(M2) 47,48,47 47 GO TO 50 50 I5=I5+1 DO 51 K=1,3 IF(J1BAR1(I,K)-J1BAR2(I,K)) 154,51,154 51 CONTINUE GO TO (42,45,46,48),I5 48 PICFP=ONE * * --- EVALUATE FRACTIONAL PARENTAGE COEFFICIENTS * I=1 CALL MUMDAD (I,ISIG,IRHO,M1,CFPLHS) PICFP=PICFP*CFPLHS IF(DABS(PICFP).LT.EPS) GO TO 154 53 I=2 CALL MUMDAD(I,ISIGP,IRHOP,M2,CFPRHS) PICFP=PICFP*CFPRHS IF(DABS(PICFP).LT.EPS) GO TO 154 * * === SET UP J1,J2,J3 AND EVALUATE RECOUPLING COEFFICIENTS * * --- FIRST OF ALL, THE SPIN COEFFICIENTS * 55 I=3 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,ISPIND,ISPINE,KK1,KK2,KK3,KK4) IF (ISPIND.EQ.0) THEN CALL J23SPN(IRHO,ISIG,IRHOP,ISIGP,JSNDIR) ISPIND=1 END IF IF(IREL.EQ.1.OR.IELST.EQ.0) GO TO 155 * * --- DIRECT SPIN INTEGRAL * 570 IF(KD1-KD2) 89,89,90 90 SPINDT=ZERO GO TO 78 89 CONTINUE IF (.NOT.FAILSD) THEN IF (ISPIND.NE.2) THEN CALL NJGRAF(SPINDT,FAILSD) ISPIND=2 IF(FAILSD) GO TO 78 CALL KNJ(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD) ELSE CALL GENSUM(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD,SPINDT) C ENDIF ELSE SPINDT=ZERO ENDIF 78 IF(IBUG2.GT.0) : WRITE(IWRITE,305) SPINDT * * IEXCHG IS ZERO WHENEVER M1=0=M2 , IN WHICH CASE THE EXCHANGE * INTEGRAL HAS ZERO COEFFICIENT. THERE IS THEN NO POINT IN * CALCULATING THIS INTEGRAL, AND SPINEX IS SET ZERO (AT STATEMENT * 93) AS A MARKER OF THIS SITUATION * 91 IF(IEXCHG.EQ.0) GO TO 93 * * --- MODIFY J2 AND J3 TO CALCULATE THE EXCHANGE SPIN INTEGRAL * IF (ISPINE.NE.0) GOTO 273 I=1 CALL MODJ23(I) ISPINE=1 273 CONTINUE * * --- EXCHANGE SPIN INTEGRAL * IF(KE1-KE2) 92,92,93 93 SPINEX=ZERO GO TO 94 92 CONTINUE IF (.NOT.FAILSE) THEN IF (ISPINE.NE.2) THEN CALL NJGRAF(SPINEX,FAILSE) ISPINE=2 IF (FAILSE) GO TO 94 CALL KNJ(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE) ELSE CALL GENSUM(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE,SPINEX) ENDIF ELSE SPINEX=ZERO ENDIF 94 IF(IBUG2.GT.0) : WRITE(IWRITE,306) SPINEX * * --- MULTIPLY SPIN INTEGRALS BY PRODUCT OF FRACTIONAL PARENTAGE COEFFS * 171 BDIRCT=SPINDT*PICFP BEXCHG=SPINEX*PICFP * * --- THE ANGULAR RECOUPLING COEFFICIENTS * SET J1,J2,J3 (COMPARE SPIN INTEGRALS) * * IF BOTH SPIN INTEGRALS ARE ZERO, THERE IS NO PURPOSE IN * CALCULATING THE ANGULAR INTEGRALS * IF(DABS(SPINDT).LT.EPS.AND.DABS(SPINEX).LT.EPS) GO TO 155 * 87 I=2 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,IANGD,IANGE,KK1,KK2,KK3,KK4) IF (IANGD.EQ.0) CALL J23ANG(IRHO,ISIG,IRHOP,ISIGP,JANGDI) * * IF THE DIRECT SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * IF(DABS(SPINDT).LT.EPS) GO TO 121 IF (IANGD.EQ.0) IANGD=1 * * --- DIRECT ANGULAR INTEGRAL * * CONSIDER ALL ALLOWED K-VALUES * IF (.NOT.FAILAD) THEN DO 114 JK1=KD1,KD2,2 c PRINT *,' IN DO 114..., JK1 = ',JK1 J1(NJ1S)=2*JK1-1 IF (IANGD.NE.2) THEN IF(KD2.NE.KD1) THEN FREE(NJ1S)=.TRUE. ELSE FREE(NJ1S)=.FALSE. ENDIF CALL NJGRAF(ANGDIR,FAILAD) IANGD=2 IF (FAILAD) GO TO 121 CALL KNJ(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD) ELSE CALL GENSUM(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD,ANGDIR) ENDIF * * ADD INTO THE COEFFICIENT OF THE SLATER INTEGRAL * AMULT(JK1)=AMULT(JK1)+ANGDIR*BDIRCT c PRINT *,' JK1 = ',JK1,' ANGDIR = ',ANGDIR,' BDIRCT = ',BDIRCT c PRINT *,' AMULT(JK1) = ',AMULT(JK1) * * MULTD=1 WHEN A DIRECT INTEGRAL COEFFICIENT HAS BEEN CALCULATED - * FOR USE, SEE PRNTWT * MULTD=1 IF(IBUG2.GT.0) : WRITE(IWRITE,310) ANGDIR 114 CONTINUE END IF * * IF THE EXCHANGE SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * 121 IF(DABS(SPINEX).LT.EPS) GO TO 155 * * --- EXCHANGE ANGULAR INTEGRAL * * CONSIDER ALL ALLOWED K-VALUES * IF (IANGE.NE.0) GOTO 279 I=2 CALL MODJ23(I) IANGE=1 279 CONTINUE IF (.NOT.FAILAE) THEN DO 115 JK1=KE1,KE2,2 J1(NJ1S) = 2*JK1-1 IF (IANGE.NE.2) THEN IF(KE2.NE.KE1) THEN FREE(NJ1S)=.TRUE. ELSE FREE(NJ1S)=.FALSE. ENDIF CALL NJGRAF(ANGEX,FAILAE) IANGE=2 IF (FAILAE) GO TO 155 CALL KNJ(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE) ELSE CALL GENSUM(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE,ANGEX) ENDIF BMULT(JK1)=BMULT(JK1)-ANGEX*BEXCHG * * MULTE=1 WHEN AN EXCHANGE INTEGRAL COEFFICIENT HAS BEEN CALCULATED * MULTE=1 IF(IBUG2.GT.0) : WRITE(IWRITE,312) ANGEX 115 CONTINUE END IF 501 CONTINUE 155 IF (.NOT.INCL) GO TO 154 IF(ISOORB.EQ.1.OR.ISPSPN.EQ.1) CALL RELREC(IRHO,ISIG,IRHOP,ISIGP, : PICFP,ICALL,KK1,KK2,KK3,KK4) 154 CONTINUE 153 CONTINUE 152 CONTINUE 151 CONTINUE * * === INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THIS * FOUR-FOLD SUMMATION * IF(IREL.EQ.1) GO TO 527 IF(MULTD) 524,525,524 524 DO 518 JK1=KD1,KD2,2 AMULT(JK1)=AMULT(JK1)*XMULT*RMEDIR(JK1)*ADIRCT c PRINT *,' IN DO 518..., JK1 = ',JK1,' XMULT = ',XMULT c PRINT *,' RMEDIR(JK1) = ',RMEDIR(JK1),' ADIRCT = ',ADIRCT c PRINT *,' AMULT(JK1) = ',AMULT(JK1) 518 CONTINUE 525 IF(MULTE) 526,527,526 526 DO 519 JK1=KE1,KE2,2 BMULT(JK1)=BMULT(JK1)*XMULT*RMEEX(JK1)*AEXCHG 519 CONTINUE * * --- PRINT OUT THE VALUES OF THE COEFFICIENTS OF THE SLATER INTEGRALS * * THE SUBROUTINE PRNTWT IS CALLED FROM RKWTS * 527 IF (.NOT.INCL) RETURN IF (IREL.EQ.0) RETURN IF(ISOORB.EQ.1) CALL SOOPAR(XMULT1) IF(ISPSPN.EQ.1) CALL SSPAR(XMULT1) * * *** DEFINITION OF DIMENSION LIST * * RMEDIR(K),K=KD1,KD2,2 - DIRECT REDUCED MATRIX ELEMENT PRODUCT * RMEEX(K),K=KE1,KE2,2 - EXCHANGE REDUCED MATRIX ELEMENT PRODUCT * KD1,KE1 ARE ALWAYS .GE. 1 * KD2,KE2 ARE .LE. 1+2*MAX(L-VALUE) * NBAR(I), I=1,IHSH - NUMBER OF SPECTATOR ELECTRONS IN EACH SHELL * THE K6,K7,K8,KW ARRAYS ARE DEFINED IN NJSYM * * RETURN END * * ------------------------------------------------------------------ * H 0 W T S * ------------------------------------------------------------------ * SUBROUTINE H0WTS IMPLICIT REAL *8(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * PARAMETER(KFL1=60,KFL2=12) LOGICAL FAIL,FREE * COMMON/DIAGNL/IDIAG,JA,JB COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/HOLD/J2STO(33),J3STO(33),J2ANG(36),J3ANG(36) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) * 300 FORMAT(' (CONFIG ',I3,'/H0 /CONFIG ',I3,')') 303 FORMAT(7H ISIG =,I3,8H ISIGP =,I3) 306 FORMAT(5H J1 =,I8,36I3) 307 FORMAT(3H J2,18X,2HJ3) 308 FORMAT(3I5,I10,2I5) 309 FORMAT(4H Y =,F10.6,8H RECUP =,F10.6) 310 FORMAT(4H Y =,F10.6,8H IDELP =,I3) 311 FORMAT(35X,F14.8,11X,'I (', A3,',', A3,')') 312 FORMAT(F14.8,2HL(,A3,I3,1H,,A3,I3,1H)) 10 FORMAT(8H COEFP =,F15.9) B1ELC(1) = 0.D0 IF (IFULL.NE.0) WRITE(IWRITE,300) JA, JB IF(IDIAG .NE.1) GO TO 1 * --- DIAGONAL HAMILTONIAN MATRIX ELEMENT DO 302 J=1,IHSH ISIG=IJFUL(J) ISIGP=ISIG X=NOSH1(J) IF (IFULL.NE.0) WRITE(IWRITE,311) X,IAJCMP(ISIG),IAJCMP(ISIGP) IF (DABS(X) .GT. 1.D-10) * : WRITE(ISC3,312) -X/2., IAJCMP(ISIG),JA,IAJCMP(ISIGP),JB : CALL SAVE(4,-X/2.,0,0,ISIG,0,ISIGP,JA,JB,0) 302 CONTINUE IF (NCLOSD .EQ. 0 .OR. IFULL.EQ.0 ) GO TO 7 DO 301 J = 1,NCLOSD L = LJCLSD(J) A = 4*L + 2 WRITE(IWRITE,311) A, IAJCLD(J), IAJCLD(J) 301 CONTINUE 7 RETURN * * --- OFF-DIAGONAL HAMILTONIAN MATRIX ELEMENT * 1 CALL ALLADD(IHSH,M3,M4,M5,M6,M7,M8,M9,M10, :M11,M12,M13,M14,M15,M16,M17,M18) ICOUNT=0 * * TEST THAT FINAL ANGULAR MOMENTA ARE EQUAL * DO 8 K=2,3 IF(J1QN1(M6,K).NE.J1QN2(M6,K)) GO TO 7 8 CONTINUE * * --- DETERMINE INTERACTING SHELLS, ISIG ON L.H.S., ISIGP ON R.H.S., * FOR NON-ZERO 1-ELECTRON MATRIX ELEMENT, N-1 ELECTRONS MUST BE * COMMON TO BOTH SIDES. THUS THE SUM OF N(I) = NOSH1(I)-NOSH2(I), * I=1,IHSH MUST BE EQUAL TO 0 OR 2 . THUS AT NO STAGE CAN * N(I) BE GREATER THAN 1 . IF THIS SUM IS ZERO, THE TWO * CONFIGURATIONS ARE MADE UP FROM THE SAME ELECTRONS, WITH TWO * DIFFERENT COUPLING SCHEMES. SINCE THE SPHERICAL HARMONICS ARE * EIGENFUNCTIONS OF DEL**2 , THE ORTHOGONALITY OF THE TWO COUPLING * SCHEMES WILL BE MAINTAINED AND ORTHOGONALITY GIVES A ZERO RESULT. * DO 9 I=1,IHSH N=NOSH1(I)-NOSH2(I) IF(IABS(N).GT.1) GO TO 7 IF(N) 11,9,12 11 ISIGP=I GO TO 13 12 ISIG=I 13 ICOUNT=ICOUNT+1 9 CONTINUE IF(ICOUNT.NE.2) GO TO 7 IF(IBUG1.GT.0)WRITE(IWRITE,303) ISIG,ISIGP LSIG=LJ(ISIG) LSIGP=LJ(ISIGP) * * THE ANGULAR MOMENTUM OF THE INTERACTING ELECTRONS MUST BE EQUAL * IF(LSIG-LSIGP) 7,93,7 * * THE SPECTATOR SHELLS MUST HAVE MATCHING QUANTUM NUMBERS * 93 DO 16 J=1,IHSH IF(J.EQ.ISIG.OR.J.EQ.ISIGP) GO TO 16 DO 19 K=1,3 IF(J1QN1(J,K).NE.J1QN2(J,K)) GO TO 7 19 CONTINUE 16 CONTINUE * * --- TEST ON TRIANGULAR CONDITIONS * IN3=2*LSIG DO 20 K=2,3 IN1=J1QN1(ISIG,K) IN2=J1QN2(ISIG,K) IN4=J1QN1(ISIGP,K) IN5=J1QN2(ISIGP,K) IF(IN1.GT.(IN2+IN3).OR.IN1.LT.IABS(IN2-IN3)) GO TO 7 IF(IN4.GT.(IN5+IN3).OR.IN4.LT.IABS(IN5-IN3)) GO TO 7 IN3=1 20 CONTINUE * * --- CALCULATE FRACTIONAL PARENTAGE COEFFICIENTS * Y=1.D0 IF(LSIG.EQ.0) GO TO 26 N=NOSH1(ISIG) IVI=J1QN1(ISIG,1) ILI=(J1QN1(ISIG,2)-1)/2 ISI=J1QN1(ISIG,3) IVJ=J1QN2(ISIG,1) ILJ=(J1QN2(ISIG,2)-1)/2 ISJ=J1QN2(ISIG,3) CALL CFP(LSIG,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IF(IBUG1.GT.0) WRITE(IWRITE,10) COEFP Y=Y*COEFP N=NOSH2(ISIGP) IVI=J1QN2(ISIGP,1) ILI=(J1QN2(ISIGP,2)-1)/2 ISI=J1QN2(ISIGP,3) IVJ=J1QN1(ISIGP,1) ILJ=(J1QN1(ISIGP,2)-1)/2 ISJ=J1QN1(ISIGP,3) CALL CFP(LSIG,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IF(IBUG1.GT.0) WRITE(IWRITE,10) COEFP Y=Y*COEFP * * --- SET UP J2 AND J3 ARRAYS * 26 M1=IHSH-2 M2=M6-2 J2(1,1)=ISIG J2(1,2)=M11 J2(1,3)=M9 J3(1,1)=ISIGP J3(1,2)=M11 J3(1,3)=M10 IF(ISIG.EQ.1) GO TO 29 J2(2,1)=1 GO TO 30 29 J2(2,1)=M9 30 IF(ISIG.EQ.2) GO TO 32 J2(2,2)=2 GO TO 33 32 J2(2,2)=M9 33 J2(2,3)=M4 IF(ISIGP.EQ.1) GO TO 35 J3(2,1)=1 GO TO 36 35 J3(2,1)=M10 36 IF(ISIGP.EQ.2) GO TO 38 J3(2,2)=2 GO TO 39 38 J3(2,2)=M10 39 J3(2,3)=M7 IF(IHSH.LT.3) GO TO 40 DO 42 J=3,IHSH J2(J,1)=M1+J J2(J,3)=M1+J+1 J3(J,1)=M2+J IF(J.EQ.IHSH) GO TO 44 J3(J,3)=M2+J+1 GO TO 45 44 J3(J,3)=M1+J+1 45 IF(J.EQ.ISIG) GO TO 47 J2(J,2)=J GO TO 48 47 J2(J,2)=M9 48 IF(J.EQ.ISIGP) GO TO 50 J3(J,2)=J GO TO 42 50 J3(J,2)=M10 42 CONTINUE * * --- STORE J2 AND J3 ARRAYS FOR USE IN SPIN RECOUPLING COEFFICIENT * 40 I1=0 DO 51 J=1,IHSH DO 52 K=1,3 I1=I1+1 J2STO(I1)=J2(J,K) J3STO(I1)=J3(J,K) 52 CONTINUE 51 CONTINUE * * --- ORBITAL RECOUPLING COEFFICIENT * J1(M11)=LSIG+LSIG+1 K=2 * * --- SET J1 ARRAY * 64 DO 53 J=1,IHSH IF(ISIG.EQ.J) GO TO 55 J1(J)=J1QN1(J,K) GO TO 53 55 J1(J)=J1QN2(ISIG,K) 53 CONTINUE DO 56 J=M4,M6 J1(J)=J1QN1(J,K) 56 CONTINUE DO 57 J=M7,M8 J1(J)=J1QN2(J-M3,K) 57 CONTINUE J1(M9)=J1QN1(ISIG,K) J1(M10)=J1QN2(ISIGP,K) NJ1S=M11 NJ23S=M4 DO 100 J = 1,M11 FREE(J) = .FALSE. 100 CONTINUE IF(IBUG1.LT.1.OR.IBUG3.EQ.1) GO TO 77 WRITE(IWRITE,306) (J1(J),J=1,M11) WRITE(IWRITE,307) DO 80 J=1,IHSH WRITE(IWRITE,308) (J2(J,KL),KL=1,3),(J3(J,KL),KL=1,3) 80 CONTINUE * * --- CALCULATE RECOUPLING COEFFICIENT * 77 CALL NJGRAF(RECUP,FAIL) Y=Y*RECUP IF(IBUG1.GT.0)WRITE(IWRITE,309) Y,RECUP * * --- SPIN RECOUPLING COEFFICIENT * IF(K.EQ.3) GO TO 60 J1(M11 )=2 K=3 I1=0 DO 62 J=1,IHSH DO 63 KK=1,3 I1=I1+1 J2(J,KK)=J2STO(I1) J3(J,KK)=J3STO(I1) 63 CONTINUE 62 CONTINUE GO TO 64 * * --- INCLUDE MULTIPLICATIVE FACTORS * 60 IDELP=0 IF(ISIG-ISIGP) 65,70,66 65 JSIG=ISIG+1 DO 67 J=JSIG,ISIGP IDELP=IDELP+NOSH1(J) 67 CONTINUE GO TO 70 66 JSIGP=ISIGP+1 DO 68 J=JSIGP,ISIG IDELP=IDELP+NOSH2(J) 68 CONTINUE 70 Y=Y*(-1.D0)**IDELP*DSQRT(DFLOAT(NOSH1(ISIG)*NOSH2(ISIGP))) IF(IBUG1.GT.0)WRITE(IWRITE,310) Y,IDELP A=X+Y JSIG=IJFUL(ISIG) JSIGP=IJFUL(ISIGP) IF(DABS(Y).GE.1.D-10 .AND. IFULL.NE.0) WRITE(IWRITE,311) : Y,IAJCMP(JSIG),IAJCMP(JSIGP) B1ELC(1) = Y IF(DABS(Y).LT.1.D-10) GO TO 400 Y=-Y/2. * WRITE(ISC3,312) Y,IAJCMP(JSIG),JA,IAJCMP(JSIGP),JB CALL SAVE(4,Y,0,0,JSIG,0,JSIGP,JA,JB,0) 400 CONTINUE RETURN END * * ------------------------------------------------------------------ * J 2 3 A N G * ------------------------------------------------------------------ * SUBROUTINE J23ANG(IRHO,ISIG,IRHOP,ISIGP,JANGDI) PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36) * * === SETS UP J2 AND J3 ARRAYS FOR DIRECT ANGULAR INTEGRAL CALL OF NJSYM * 303 FORMAT(3H J2,18X,2HJ3) 304 FORMAT(3I5,I10,2I5) * * HAVE THE J2 AND J3 ARRAYS ALREADY BEEN SET. IF NOT, THEN GO TO 2 * IF(JANGDI) 2,2,1 * * --- ROWS 3 TO M4 OF SPIN J2 AND J3 ARE SAME AS ROWS 4 TO (M4+1) OF * ANGULAR J2 AND J3 * 2 I1=6 DO 103 J=3,M4 JP1=J+1 DO 104 K=1,3 I1=I1+1 J2(JP1,K)=J2SPIN(I1) J3(JP1,K)=J3SPIN(I1) 104 CONTINUE 103 CONTINUE * * --- SET ROWS 1, 2 AND 3 * IF(M1) 105,106,105 105 J2(3,1)=ISIG GO TO 107 106 J2(3,1)=M9 107 IF(M2) 109,110,109 109 J3(3,1)=ISIGP GO TO 111 110 J3(3,1)=M11 111 J2(2,3)=M9 J2(2,1)=IRHO J2(2,2)=M13 J2(1,3)=M14 J2(3,2)=M14 J2(3,3)=M10 J2(1,1)=M16 J2(1,2)=M17 J3(3,2)=M16 J3(3,3)=M12 J3(1,2)=M13 J3(1,1)=M17 J3(1,3)=M15 J3(2,3)= M11 J3(2,1)=IRHOP J3(2,2)=M15 * * --- STORE J2 AND J3 FOR USE IN CALCULATING THE EXCHANGE TERM * I1=0 DO 535 J=1,M5 DO 536 K=1,3 I1=I1+1 J2ANG(I1)=J2(J,K) J3ANG(I1)=J3(J,K) 536 CONTINUE 535 CONTINUE JANGDI=1 3 IF(IBUG2-1) 209,209,206 * * PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1 * 206 IF(IBUG3-1) 209,207,207 207 WRITE(IWRITE,303) DO 208 J=1,M5 WRITE(IWRITE,304) (J2(J,K),K=1,3),(J3(J,K),K=1,3) 208 CONTINUE 209 RETURN * * --- SET J2 AND J3 ARRAYS FROM STORE OF PREVIOUS CALCULATIONS * 1 I1=0 DO 4 J=1,M5 DO 5 K=1,3 I1=I1+1 J2(J,K)=J2ANG(I1) J3(J,K)=J3ANG(I1) 5 CONTINUE 4 CONTINUE GO TO 3 END * * ------------------------------------------------------------------ * J 2 3 S P 1 * ------------------------------------------------------------------ * SUBROUTINE J23SP1(J23REL) * PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36) COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/J23R /J2REL(39),J3REL(39) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 * 303 FORMAT(3H J2,18X,2HJ3) 304 FORMAT(3I5,I10,2I5) * * --- MODIFY THE J2 AND J3 ARRAYS FOR THE DIRECT SPIN INTEGRAL * (SPIN-OTHER-ORBIT AND/OR SPIN-SPIN INTERACTION(S)) CALL OF NJSYM * * * --- ROWS 1 TO M4 OF SPIN J3(J23SPN) ARE THE SAME AS ROWS 1 TO M4 OF * SPIN J3(J23SP1) * IF(J23REL.EQ.1) GO TO 10 I1=0 DO 1 J=1,M4 DO 2 K=1,3 I1=I1+1 J3(J,K)=J3SPIN(I1) 2 CONTINUE 1 CONTINUE * * ROWS 1 TO M4 OF SPIN J2(J23SPN) ARE THE SAME AS ROWS 3 TO M4+2 OF * SPIN J2(J23SP1) * I1=0 DO 3 J=1,M4 JP1=J+2 DO 4 K=1,3 I1=I1+1 J2(JP1,K)=J2SPIN(I1) 4 CONTINUE 3 CONTINUE * * --- SET FIRST TWO ROWS OF J2, CORRESPONDING TO THE COUPLING OF * INTERACTING ELECTRONS WITHIN THEIR SHELLS * J2(1,1)=M15 J2(1,2)=M17 J2(1,3)=M13 J2(2,1)=M16 J2(2,2)=M17+1 J2(2,3)=M14 * * --- RESET THE FOLLOWING ELEMENTS IN THE J3 ARRAY * J3(1,2)=M15 J3(2,2)=M16 J3(M4,3)=M8 * * --- SET ROWS M5 AND M5+1 OF J3 * J3(M5,1)=M17 J3(M5,2)=M17+1 J3(M5,3)=NJ1S J3(M18,1)=M8 J3(M18,2)=NJ1S J3(M18,3)=M6 * * --- Special Case: IHSH = 1 * IF (IHSH .EQ. 1) THEN J3(2,3) = M12 J3(4,1) = M12 J3(4,3) = M10 END IF * * --- STORE THE ARRAYS J2 AND J3 FOR FUTURE RESETTING OF J2 AND J3 * I1=0 DO 21 J=1,M18 DO 22 K=1,3 I1=I1+1 J2REL(I1)=J2(J,K) J3REL(I1)=J3(J,K) 22 CONTINUE 21 CONTINUE J23REL=1 26 IF(IBUG2.LT.2.OR.IBUG3.EQ.1) RETURN WRITE(IWRITE,303) DO 23 J=1,M18 WRITE(IWRITE,304) (J2(J,K),K=1,3),(J3(J,K),K=1,3) 23 CONTINUE RETURN * * --- RESET THE ARRAYS J2 AND J3 FROM STORE * 10 I1=0 DO 24 J=1,M18 DO 25 K=1,3 I1=I1+1 J2(J,K)=J2REL(I1) J3(J,K)=J3REL(I1) 25 CONTINUE 24 CONTINUE GO TO 26 END * * ------------------------------------------------------------------ * J 2 3 S P N * ------------------------------------------------------------------ * SUBROUTINE J23SPN(IRHO,ISIG,IRHOP,ISIGP,JSNDIR) PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36) * * === SET UP THE J2 AND J3 ARRAYS FOR THE DIRECT SPIN INTEGRAL CALL * OF NJSYM * 303 FORMAT(3H J2,18X,2HJ3) 304 FORMAT(3I5,I10,2I5) * * HAVE THE J2 AND J3 ARRAYS ALREADY BEEN SET. IF NOT, THEN GO TO 2 * IF(JSNDIR) 2,2,1 * * --- SET THIRD ROW OF J2 AND J3 * 2 IF(IRHO-1) 271,272,271 271 J2(3,1)=1 GO TO 273 272 IF(M1) 274,275,274 275 J2(3,1)=M10 GO TO 276 274 J2(3,1)=M9 GO TO 276 273 IF(IRHO-2) 277,278,277 277 J2(3,2)=2 GO TO 284 278 IF(M1) 280,281,280 280 J2(3,2)=M9 GO TO 284 281 J2(3,2)=M10 GO TO 284 276 IF(ISIG-2) 277,281,277 284 J2(3,3)=M4 IF(IRHOP-1) 285,286,285 285 J3(3,1)=1 GO TO 287 286 IF(M2) 288,289,288 288 J3(3,1)=M11 GO TO 290 289 J3(3,1)=M12 GO TO 290 287 IF(IRHOP-2) 291,292,291 291 J3(3,2)=2 GO TO 293 292 IF(M2) 294,295,294 295 J3(3,2)=M12 GO TO 293 294 J3(3,2)=M11 GO TO 293 290 IF(ISIGP-2) 291,295,291 293 J3(3,3)=M7 * * --- SET ROWS 4,5,.. ETC. * IF(M4-4) 203,202,202 202 DO 470 J=4,M4 J2(J,1)=M4 +J-4 J2(J,3)=M4+J-3 IF(ISIG+1-J) 471,472,471 471 IF(M1) 473,474,473 473 IF(IRHO+1-J) 474,475,474 474 J2(J,2)=J-1 GO TO 476 472 J2(J,2)=M10 GO TO 476 475 J2(J,2)=M9 476 J3(J,1)=M7+J-4 IF(J-M4 ) 482,483,482 483 J3(J,3)=J2(J,3) GO TO 484 482 J3(J,3)=M7+J-3 484 IF(ISIGP+1-J) 477,478,477 477 IF(M2) 479,480,479 479 IF(IRHOP+1-J) 480,481,480 480 J3(J,2)=J-1 GO TO 470 478 J3(J,2)=M12 GO TO 470 481 J3(J,2)=M11 470 CONTINUE * * --- SET FIRST TWO ROWS, CORRESPONDING TO COUPLING OF INTERACTING * ELECTRONS WITHIN THEIR SHELLS * 203 J2(2,3)=M10 J2(1,2) = M13 J2(2,2) = M14 J2(1,3) = M9 IF(M1) 82,83,82 82 J2(1,1) = IRHO J2(2,1) = ISIG GO TO 84 83 J2(1,1) = ISIG J2(2,1) = M9 84 J3(2,3) = M12 J3(1,2) = M13 J3(2,2) = M14 J3(1,3) = M11 IF(M2) 85,86,85 85 J3(1,1) = IRHOP J3(2,1) = ISIGP GO TO 187 86 J3(1,1) = ISIGP J3(2,1) = M11 * * --- STORE J2,J3 ARRAYS FOR USE IN CALCULATING EXCHANGE INTEGRAL * 187 I1=0 DO 451 J=1,M4 DO 452 K=1,3 I1=I1+1 J2SPIN(I1)=J2(J,K) J3SPIN(I1)=J3(J,K) 452 CONTINUE 451 CONTINUE JSNDIR=1 3 IF(IBUG2-1) 570,570,6 * * PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1 * 6 IF(IBUG3-1) 200,570,200 200 WRITE(IWRITE,303) DO 201 J=1,M4 WRITE(IWRITE,304) (J2(J,K),K=1,3),(J3(J,K),K=1,3) 201 CONTINUE 570 RETURN * * --- SET J2 AND J3 ARRAYS FROM STORE OF PREVIOUS CALCULATIONS * 1 I1=0 DO 4 J=1,M4 DO 5 K=1,3 I1=I1+1 J2(J,K)=J2SPIN(I1) J3(J,K)=J3SPIN(I1) 5 CONTINUE 4 CONTINUE GO TO 3 END * * ------------------------------------------------------------------ * K L I M * ------------------------------------------------------------------ * SUBROUTINE KLIM(L1,L2,L3,L4,L,KA,KB) * * --- DETERMINATION OF THE TRIANGULAR CONDITIONS * K1=IABS(L1-L2)-L K2=L1+L2-L K3=IABS(L3-L4) K4=L3+L4 KA=MAX0(K1,K3) KB=MIN0(K2,K4) RETURN END * * ------------------------------------------------------------------ * M A G I N T * ------------------------------------------------------------------ * SUBROUTINE MAGINT(LET1,LET2,LET3,JVAL) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL * 22 FORMAT(/1X,104H TRIANGULAR RELATION (S,SS,KA) IS NOT SATISFIED FOR : THE SPIN-ORBIT AND THE SPIN-OTHER-ORBIT INTERACTIONS) 23 FORMAT(/1X,104H TRIANGULAR RELATION (L,LL,KA) IS NOT SATISFIED FOR : THE SPIN-ORBIT AND THE SPIN-OTHER-ORBIT INTERACTIONS) 26 FORMAT(/1X,77H TRIANGULAR RELATION (S,SS,KA) IS NOT SATISFIED FOR :THE SPIN-SPIN INTERACTION) 27 FORMAT(/1X,77H TRIANGULAR RELATION (L,LL,KA) IS NOT SATISFIED FOR :THE SPIN-SPIN INTERACTION) 31 FORMAT(/1X,83H TRIANGULAR RELATION BETWEEN J VALUE AND THE TOTAL A :NGULAR MOMENTA IS NOT SATISFIED) * * * --- EVALUATION OF THE RELATIVISTIC OPERATORS OF THE BREIT-PAULI * HAMILTONIAN. TEST ON THE TRIANGULAR CONDITIONS. * * LET1=1 LET2=1 LET3=1 * * --- TEST FOR TRIANGULAR RELATION BETWEEN J, L AND S * I2HSH=IHSH+IHSH-1 L=J1QN1(I2HSH,2)-1 LS=J1QN1(I2HSH,3)-1 JV=JVAL-1 VJTST=TRITST(JV,LS,L) IF(DABS(VJTST).LT.EPS) GO TO 8 32 LET1=0 LET2=0 LET3=0 GO TO 9 * * --- TEST FOR TRIANGULAR RELATION BETWEEN J, LL AND SS * 8 LL=J1QN2(I2HSH,2)-1 LSS=J1QN2(I2HSH,3)-1 VJJTST=TRITST(JV,LSS,LL) IF(DABS(VJJTST).LT.EPS) GO TO 10 GO TO 32 * * --- TEST FOR TRIANGULAR CONDITIONS FOR THE SPIN-ORBIT AND/OR THE * SPIN-OTHER-ORBIT INTERACTION(S) * 10 IF(ISPORB+ISOORB) 12,12,29 29 KA=2 25 K=3 19 IL=J1QN1(I2HSH,K)-1 IR=J1QN2(I2HSH,K)-1 BTST=TRITST(IL,IR,KA) IF(DABS(BTST).GT.EPS) GO TO 14 13 IF(K-2) 15,15,16 15 IF(KA-2) 12,12,28 16 K=2 GO TO 19 14 IF(KA-2) 20,20,21 20 IF(K.EQ.3.AND.NBUG7.GE.1) WRITE(IWRITE,22) IF(K.EQ.2.AND.NBUG7.GE.1) WRITE(IWRITE,23) LET1=0 LET2=0 GO TO 12 21 IF(K.EQ.3.AND.NBUG7.EQ.1) WRITE(IWRITE,26) IF(K.EQ.2.AND.NBUG7.EQ.1) WRITE(IWRITE,27) LET3=0 GO TO 28 * * --- TEST FOR TRIANGULAR CONDITIONS FOR THE SPIN-SPIN INTERACTION * 12 IF(ISPSPN.NE.1) GO TO 28 KA=4 GO TO 25 9 IF(NBUG7.EQ.1) WRITE(IWRITE,31) 28 RETURN END * * ------------------------------------------------------------------ * M E K E E P * ------------------------------------------------------------------ * SUBROUTINE MEKEEP(IRHO,ISIG,IRHOP,ISIGP) COMMON/MEDEFN/J(165) COMMON/STORE/I(165),I1,I2,I3,I4 * * STORES THE COMMON BLOCK MEDEFN , AND IRHO,ISIG,IRHOP,ISIGP * DO 1 K=1,165 I(K)=J(K) 1 CONTINUE I1=IRHO I2=ISIG I3=IRHOP I4=ISIGP RETURN END * * ------------------------------------------------------------------ * M E R E S T * ------------------------------------------------------------------ * SUBROUTINE MEREST(IRHO,ISIG,IRHOP,ISIGP) COMMON/MEDEFN/J(165) COMMON/STORE/I(165),I1,I2,I3,I4 * * RESTORES THE COMMON BLOCK MEDEFN, AND IRHO,ISIG,IRHOP,ISIGP * DO 1 K=1,165 J(K)=I(K) 1 CONTINUE IRHO=I1 ISIG=I2 IRHOP=I3 ISIGP=I4 RETURN END * * ------------------------------------------------------------------ * M O D J 2 3 * ------------------------------------------------------------------ * SUBROUTINE MODJ23(K) PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/HOLD/J2SPIN(33),J3SPIN(33),J2ANG(36),J3ANG(36) * * === MODIFIES THE DIRECT J2 AND J3 ARRAYS FOR EXCHANGE CALL OF NJSYM * 7 FORMAT(3H J2,18X,2HJ3) 8 FORMAT(3I5,I10,2I5) GO TO (1,2),K * * --- K=1 - SPIN INTEGRALS * 1 MK=M4 I1=0 DO 11 J=1,MK DO 12 K=1,3 I1=I1+1 J2(J,K)=J2SPIN(I1) J3(J,K)=J3SPIN(I1) 12 CONTINUE 11 CONTINUE J3(1,2)=M14 J3(2,2)=M13 GO TO 3 * * --- K=2 - ANGULAR INTEGRALS * 2 MK=M5 I1=0 DO 21 J=1,MK DO 22 K=1,3 I1=I1+1 J2(J,K)=J2ANG(I1) J3(J,K)=J3ANG(I1) 22 CONTINUE 21 CONTINUE J2(1,1)=M15 J3(1,3)=M16 3 IF(IBUG2-1) 4,4,9 * * PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1 * 9 IF(IBUG3-1 ) 5,4,5 5 WRITE(IWRITE,7) DO 6 J=1,MK WRITE(IWRITE,8) (J2(J,K),K=1,3),(J3(J,K),K=1,3) 6 CONTINUE 4 RETURN END * * ------------------------------------------------------------------ * M O D R E L * ------------------------------------------------------------------ * SUBROUTINE MODREL * * * --- MODIFIES THE DIRECT J2 ARRAY FOR EXCHANGE CALL OF NJSYM * FOR THE (SPIN-OTHER-ORBIT INTERACTION AND/OR SPIN-SPIN * INTERACTION(S)) * * PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 * 7 FORMAT(3H J2,18X,2HJ3) 8 FORMAT(3I5,I10,2I5) * J2(1,1)=M16 J2(2,1)=M15 IF(IBUG2.LE.1.OR.IBUG3.EQ.1) RETURN WRITE(IWRITE,7) DO 6 J=1,M18 WRITE(IWRITE,8) (J2(J,K),K=1,3),(J3(J,K),K=1,3) 6 CONTINUE RETURN END * * ------------------------------------------------------------------ * O R T H O G * ------------------------------------------------------------------ * SUBROUTINE ORTHOG(LET,INCL) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) LOGICAL INCL * * THIS SUBROUTINE CHECKS FOR POSSIBLE ORTHOGONALITY DUE TO * COUPLING DIFFERENCES OR UNEVEN PARITY * 101 FORMAT(37H DIFFERING RESULTANT ANGULAR MOMENTUM) 102 FORMAT(52H ORTHOGONALITY IN COUPLING SCHEMES OF CONFIGURATIONS) 103 FORMAT(59H THE TWO CONFIGURATIONS HAVE DIFFERING NUMBERS OF ELECTR :ONS) 104 FORMAT(51H THE TWO CONFIGURATIONS HAVE DIFFERING TOTAL PARITY) * * --- DO PSI AND PSIP CONTAIN THE SAME NUMBERS OF ELECTRONS * DO PSI AND PSIP HAVE THE SAME TOTAL PARITY * N5=0 N6=0 N7=0 IELST=1 DO 20 I=1,IHSH L1=LJ(I) L2=NOSH1(I) L3=NOSH2(I) N5=N5+L2 N6=N6+L3 N7=N7+L1*(L2-L3) 20 CONTINUE * * CHECK ON NUMBER OF ELECTRONS * IF (N5-N6) 21,22,21 21 IF(IBUG2-1) 11,28,28 28 WRITE(IWRITE,103) GO TO 11 * * CHECK ON PARITY * 22 IF(N7-N7/2*2) 23,24,23 23 IF(IBUG2-1) 11,25,25 25 WRITE(IWRITE,104) GO TO 11 24 N1=2*IHSH-1 N2=IHSH+1 N3=IHSH-1 N4=IHSH-2 * * --- IS THE FINAL STATE THE SAME FOR PSI AND PSIP * DO 1 K=2,3 IF(J1QN1(N1,K)-J1QN2(N1,K))2,1,2 1 CONTINUE GO TO 3 2 IF(IBUG2.EQ.0) GO TO 13 26 WRITE(IWRITE,101) 13 IELST=0 IF(IREL.NE.0) GO TO 12 * * --- THE TWO CONFIGURATIONS WILL HAVE ZERO HAMILTONIAN MATRIX ELEMENT * 11 LET=0 RETURN 3 CONTINUE * * --- NO OBVIOUS ANGULAR MOMENTUM ORTHOGONALITY * 12 LET=1 IF (IELST.EQ.0.AND. .NOT.INCL) LET = 0 RETURN END * ------------------------------------------------------------------ * O U T L S J * ------------------------------------------------------------------ * SUBROUTINE OUTLSJ IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON /FOUT/NOV(2),IOVLAP(10,2),NF,NG,NR,NL,NZ,NN,NV,NS,IFLAG,NIJ COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(4),JSC(3),IALL COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) PARAMETER (NCDIM4=12000,LSTACK=20) DIMENSION C(NCDIM4),IPACK(NCDIM4),JA(NCDIM4),JB(NCDIM4), : IPTR(NCDIM4),IPT(NCDIM4) INTEGER NCOUNT(8),ISTACK(LSTACK),II(4),IEL(4) EQUIVALENCE (NCOUNT(1),NF),(II(1),I1),(II(2),I2),(II(3),I3), : (II(4),I4) CHARACTER*1 INT(8) DATA INT/'F','G','R','L','Z','N','V','S'/ * * Formats for Integrals * 10 FORMAT(1X,A1,I2,'(',A3,',',A3,')',I5) 11 FORMAT(1X,A1,I2,'(',2A3,',',2A3,')',I5) 12 FORMAT(1X,A1,2X,'(',A3,',',A3,')',I5) * * Format for Coefficients * 20 FORMAT(F14.8,A1,3I3) * * Format for Coefficient terminator * 30 FORMAT(14X,'*',16X,' ') 31 FORMAT(1X,'*') * * --- TERMINATE INTEGERAL LISTS and Rewind * DO 1 J = 1,8 ENDFILE(UNIT=ISC(J)) REWIND(UNIT=ISC(J)) 1 CONTINUE * * Test if current dimensions are big enough * N = MAX(NF,NG,NR,NL,NZ,NN,NV,NS) IF (N .GT. NCDIM4) THEN WRITE(0,'(A/A,I10)') ' NCDIM4 dimension in OUTLSJ too small', : ' Must be increased to at least',N STOP 1 END IF * *=== Begin processing data * NINT = 0 DO 100 ICASE = 1,8 N = NCOUNT(ICASE) IF (ICASE .NE. 3 .AND. ICASE .NE. 4) THEN DO 102 J = 1,N READ(ISC(ICASE)) C(J),IPACK(J),JA(J),JB(J) 102 CONTINUE ELSE DO 104 J = 1,N READ(ISC(ICASE)) C(J),IPACK(J),JA(J),JB(J),IPTR(J) 104 CONTINUE END IF CALL QSORT(N,IPACK,IPT,ISTACK,LSTACK,IERR) IF (IERR .EQ. 1) THEN WRITE(0,*) ' Stack dimension not large enough for sort' STOP 1 END IF * * Output the list of integrals with pointers to the data * LAST = 0 110 J = LAST +1 LAST = J IF (J .LE. N) THEN * * Unpack electron data * K = IPACK(IPT(J)) I4 = MOD(K,64) K = K/64 IF (ICASE.LE.2 .OR. ICASE.EQ.4 .OR. ICASE.EQ.5) THEN I2 = MOD(K,64) K = K/64 ELSE I3 = MOD(K,64) K = K/64 I2 = MOD(K,64) K = K/64 I1 = MOD(K,64) K = K/64 IF (ICASE .GT. 5) K = K - 1 END IF * * Find last item in the list with this integral * 120 LAST = LAST + 1 IF (LAST .LE. N) THEN IF (IPACK(IPT(J)) .EQ. IPACK(IPT(LAST))) GO TO 120 END IF LAST = LAST -1 NINT = NINT + 1 IF (ICASE .LE. 2) THEN WRITE(IOUT,10) INT(ICASE),K,IAJCMP(I2),IAJCMP(I4),LAST ELSE IF (ICASE .EQ. 4 .OR. ICASE .EQ. 5) THEN WRITE(IOUT,12) INT(ICASE),IAJCMP(I2),IAJCMP(I4),LAST ELSE DO 140 J = 1,4 IF (II(J) .LT. 32) THEN IEL(J) = IAJCMP(II(J)) ELSE IEL(J) = IAJCLD(64-II(J)) END IF 140 CONTINUE WRITE(IOUT,11) INT(ICASE),K,(IEL(J),J=1,4),LAST END IF GO TO 110 END IF WRITE(IOUT,31) * * Write out the data for the integrals * DO 150 J = 1,N K = IPT(J) WRITE(IOUT,20) C(K),INT(ICASE),JA(K),JB(K) 150 CONTINUE WRITE(IOUT,30) IF (ICASE .EQ. 2) THEN WRITE(IOUT,31) WRITE(IOUT,31) END IF 100 CONTINUE WRITE(0,*) 'The total number of integrals =',NINT RETURN END * MCHF_BREIT (Part 2 of 2) * ------------------------------------------------------------------ * P R N T W T * ------------------------------------------------------------------ * SUBROUTINE PRNTWT(IRHO,ISIG,IRHOP,ISIGP) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DIAGNL/IDIAG,JA,JB COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/ENAV/NINTS,KVALUE(15),COEFCT(15) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN(19,3,2) :,IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/PHASES/SIGNFA(NCD2),ICSTAS COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * * --- PRINTS OUT THE COEFFICIENTS OF SLATER INTEGRALS * 1 FORMAT(//23H INTERACTING SHELLS ARE,6X,6H RHO =,A3,6X,6H SIG =,A3, :6X,7H RHOP =,A3,6X,7H SIGP =,A3//) 2 FORMAT(35X,F14.8,11X,1HF,I2,1H(,A3,1H,,A3,1H)) 3 FORMAT(35X,F14.8,11X,1HG,I2,1H(,A3,1H,,A3,1H)) 4 FORMAT(35X,F14.8,11X,1HR,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 100 FORMAT(F14.8,1HF,I2,1H(,A3,I3,1H,,A3,I3,1H)) 101 FORMAT(F14.8,1HG,I2,1H(,A3,I3,1H,,A3,I3,1H)) 102 FORMAT(F14.8,1HR,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 103 FORMAT(' (CONFIG ',I3,'/Rij/CONFIG ',I3,')') JRHO=IJFUL(IRHO) JSIG=IJFUL(ISIG) JRHOP=IJFUL(IRHOP) JSIGP=IJFUL(ISIGP) * SIGNCH = 1. IF (ICSTAS .NE. 0) SIGNCH = SIGNFA(JA)*SIGNFA(JB) * * --- DETERMINE THE AVERAGE ENERGY CONTRIBUTIONS IF IDIAG IS NON-ZERO * IF(KD1.GT.KD2.AND.KE1.GT.KE2) GO TO 41 IF(IDIAG.EQ.0) GO TO 50 LA=LJ(IRHO) LB=LJ(ISIG) IF(M1.EQ.0) GO TO 51 IEQUIV=2 NMULT=NOSH1(IRHO)*NOSH1(ISIG) GO TO 52 51 IEQUIV=1 NA=NOSH1(IRHO) NMULT=NA*(NA-1)/2 * * CALCULATE THE INTERACTION ENERGY * 52 CALL INTACT(LA,LB,IEQUIV) INTS=1 50 IF(IBUG2-1) 6,7,7 7 WRITE(IWRITE,1) IAJCMP(JRHO),IAJCMP(JSIG),IAJCMP(JRHOP), : IAJCMP(JSIGP) 6 CONTINUE * --- DIRECT INTEGRALS * 8 IF(KD1.GT.KD2) GO TO 20 IF (IFULL .NE. 0) WRITE(IWRITE,103) JA,JB DO 11 JK1=KD1,KD2,2 K=JK1-1 A=AMULT(JK1)*SIGNCH IF(IDIAG.NE.0) GO TO 53 * * NON-DIAGONAL MATRIX ELEMENT * IF(M19.EQ.0.AND.M20.EQ.0) GO TO 15 * IF((M1+M2).EQ.0) GO TO 16 GO TO 13 * * DIAGONAL MATRIX ELEMENT. F0 TERM IS THE ONLY ONE WITH K=0 * 53 IF(K.NE.0) GO TO 57 GO TO 15 * * OTHER FK INTEGRALS, ONLY OCCUR IF RHO=SIG * 57 IF(IEQUIV.EQ.1.AND.INTS.LE.NINTS) GO TO 58 GO TO 15 58 IF(K.NE.KVALUE(INTS)) GO TO 15 INTS=INTS+1 15 IF(DABS(A).GE.1.D-10 .AND. IFULL.NE.0) : WRITE(IWRITE,2) A,K,IAJCMP(JRHO),IAJCMP(JSIG) IF(DABS(A).LT.1.D-10) GO TO 11 * WRITE(IOUT,100) A,K,IAJCMP(JRHO),JA,IAJCMP(JSIG),JB CALL SAVE(1,A,K,0,JRHO,0,JSIG,JA,JB,0) GO TO 11 16 IF(DABS(A).GE.1.D-10 .AND. IFULL.NE.0) : WRITE(IWRITE,3) A,K,IAJCMP(JRHO),IAJCMP(JRHOP) IF(DABS(A).LT.1.D-10) GO TO 11 * WRITE(ISC1,101) A,K,IAJCMP(JRHO),JA,IAJCMP(JRHOP),JB CALL SAVE(2,A,K,0,JRHO,0,JRHOP,JA,JB,0) GO TO 11 13 IF(DABS(A).GE.1.D-10 .AND. IFULL.NE.0) WRITE(IWRITE,4) A,K, : IAJCMP(JRHO),IAJCMP(JSIG),IAJCMP(JRHOP),IAJCMP(JSIGP) IF(DABS(A).LT.1.D-10) GO TO 11 * WRITE(ISC2,102) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(3,A,K,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) 11 CONTINUE * * --- EXCHANGE INTEGRALS * 20 IF(KE1.GT.KE2) GO TO 41 IF (KD1.GT.KD2 .AND. IFULL.NE.0) WRITE(IWRITE,103) JA,JB DO 21 JK1=KE1,KE2,2 K=JK1-1 B=BMULT(JK1)*SIGNCH * * --- DIVIDE THE WEIGHTS INTO AVERAGE ENERGY AND NON-AVERAGE ENERGY * PARTS * IF(IDIAG.NE.0) GO TO 60 * * NON-DIAGONAL MATRIX ELEMENT * IF(M19.EQ.0.AND.M20.EQ.0) GO TO 25 IF(M1 .EQ.0.AND.M2 .EQ.0) GO TO 31 GO TO 23 * * DIAGONAL MATRIX ELEMENT * 60 IF(INTS.LE.NINTS) GO TO 61 GO TO 25 61 IF(K.NE.KVALUE(INTS)) GO TO 25 INTS=INTS+1 25 IF (DABS(B).GE.1.D-10 .AND. IFULL.NE.0) : WRITE(IWRITE,3) B,K,IAJCMP(JRHO),IAJCMP(JSIG) IF(DABS(B).LT.1.D-10) GO TO 21 * WRITE(ISC1,101) B,K,IAJCMP(JRHO),JA,IAJCMP(JSIG),JB CALL SAVE(2,B,K,0,JRHO,0,JSIG,JA,JB,0) GO TO 21 31 IF (DABS(B).GE.1.D-10 .AND. IFULL.NE.0) : WRITE(IWRITE,3) B,K,IAJCMP(JRHO),IAJCMP(JSIGP) IF(DABS(B).LT.1.D-10) GO TO 21 * WRITE(ISC1,101) B,K,IAJCMP(JRHO),JA,IAJCMP(JSIGP),JB CALL SAVE(2,B,K,0,JRHO,0,JSIGP,JA,JB,0) GO TO 21 23 IF(DABS(B).GE.1.D-10 .AND. IFULL.NE.0) WRITE(IWRITE,4) B,K, : IAJCMP(JRHO),IAJCMP(JSIG),IAJCMP(JSIGP),IAJCMP(JRHOP) IF(DABS(B).LT.1.D-10) GO TO 21 * WRITE(ISC2,102) B,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(3,B,K,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) 21 CONTINUE 41 RETURN END * * ------------------------------------------------------------------ * R A D W T S * ------------------------------------------------------------------ * SUBROUTINE RADWTS(IRHO,ISIG,IRHOP,ISIGP,ICOUNT) * IMPLICIT REAL *8(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/PHASES/SIGNFA(NCD2),ICSTAS COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/DENKVK/D00N2(12),D00NK(12),D00VK(12),D11N2(12),D11NK(12), : D11VK(12),E01N2(12),E01NK(12),E01VK(12),E10N2(12),E10NK(12), : E10VK(12) COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/DIAGNL/IDIAG,JA,JB COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * 3 FORMAT(35X,F14.8,11X,1HN,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 4 FORMAT(35X,F14.8,11X,1HV,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 303 FORMAT(F14.8,1HN,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 304 FORMAT(F14.8,1HV,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 305 FORMAT(F14.8,1HS,I2,1H(,2A3,I3,1H,,2A3,I3,1H)) 320 FORMAT(9H (CONFIG ,I3,12H/SS /CONFIG ,I3,1H)) 330 FORMAT(9H (CONFIG ,I3,12H/SS /CONFIG ,I3,1H), : /35X,F14.8,11X,1HN,I2,1H(,A3,1H,,A3,1H/,A3,1H,,A3,1H)) 340 FORMAT(9H (CONFIG ,I3,12H/SOO/CONFIG ,I3,1H)) * * * --- THIS SUBROUTINE CATEGORIZES THE COEFFICIENTS (SPIN-OTHER-ORBIT * AND/OR SPIN-SPIN INTERACTION(S)) ASSOCIATED WITH THE INTERACTING * SUBSHELLS RHO, SIG, RHOP, SIGP INTO TYPES NK AND VK, AND, IF * REQUIRED, PRINTS OUT THEIR VALUES, TOGETHER WITH THE ALPHANUMERIC * FORM OF EACH INTEGRAL * * ICHANG=0 MAXBAS=MAXORB+1 * * --- CHANGE THE SIGN IF CONDON AND SHORTLEY CONVENTION ... * SIGNCH = 1.0 IF (ICSTAS .NE. 0) SIGNCH = SIGNFA(JA)*SIGNFA(JB) * * --- SPECIFY THE POSITION OF THE INTERACTING SUBSHELLS IN ORIGINAL * LIST OF ORBITALS * 53 JRHO=IJFUL(IRHO) JSIG=IJFUL(ISIG) JRHOP=IJFUL(IRHOP) JSIGP=IJFUL(ISIGP) * * --- EVALUATE THE RADIAL INTEGRALS ASSOCIATED WITH THE SPIN-OTHER-ORBIT * IMTERACTION * IF (ICOUNT .GT. 1) ICOUNT = 1 IF(ISOORB.EQ.0) GO TO 100 IF ((MULDSO+MULESO).NE.0 .AND. IFULL .NE. 0) : WRITE(IWRITE,340) JA,JB IF((MULDSO+MULESO).NE.0) ICOUNT=2 * * --- DIRECT INTEGRALS * * * --- IF MULDSO=0 MEANS NO =DIRECT= COEFFICIENTS * IF(MULDSO.EQ.0) GO TO 2 L=0 DO 5 J=KD1,KD2,2 L=L+1 K=J-1 K1=K-1 K2=K-2 IF(K) 5,6,7 7 A=D00N2(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 102 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K2,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC1,303) A,K2,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(6,A,K2,JSIG,JRHO,JSIGP,JRHOP,JA,JB,0) 102 A=D00VK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 104 IF (IFULL.NE.0) WRITE(IWRITE,4) A,K1,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC2,304) A,K1,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(7,A,K1,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) 104 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 6 A=D11N2(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 106 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K2,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC1,303) A,K2,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(6,A,K2,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) 106 A=D11VK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 6 IF (IFULL.NE.0) WRITE(IWRITE,4) A,K1,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC2,304) A,K1,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(7,A,K1,JSIG,JRHO,JSIGP,JRHOP,JA,JB,0) 6 A=D00NK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 110 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC1,303) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(6,A,K,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) 110 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 5 A=D11NK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 5 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC1,303) A, K, IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(6,A,K,JSIG,JRHO,JSIGP,JRHOP,JA,JB,0) 5 CONTINUE * * --- EXCHANGE INTEGRALS * * * --- IF MULESO=0 MEANS NO =EXCHANGE= COEFFICIENTS * 2 IF(MULESO.EQ.0) GO TO 100 L=0 DO 13 J=KE1,KE2,2 L=L+1 K=J-1 K1=K-1 K2=K-2 IF(K) 13,16,17 17 A=E01N2(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 114 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K2,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC1,303) A,K2,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(6,A,K2,JSIG,JRHO,JRHOP,JSIGP,JA,JB,0) 114 A=E01VK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 116 IF (IFULL.NE.0) WRITE(IWRITE,4) A,K1,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC2,304) A,K1,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(7,A,K1,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) 116 A=E10N2(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 118 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K2,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC1,303) A,K2,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(6,A,K2,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) 118 A=E10VK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 16 IF (IFULL.NE.0) WRITE(IWRITE,4) A,K1,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC2,304) A,K1,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(7,A,K1,JSIG,JRHO,JRHOP,JSIGP,JA,JB,0) 16 A=E01NK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 122 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC1,303) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(6,A,K,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) 122 A=E10NK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 13 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC1,303) A,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(6,A,K,JSIG,JRHO,JRHOP,JSIGP,JA,JB,0) 13 CONTINUE * * --- EVALUATE THE RADIAL INTEGRALS ASSOCIATED WITH THE SPIN-SPIN * INTERACTION * 100 IF(ISPSPN.EQ.0) GO TO 200 MDE=MULDSS+MULDSP+MULESS+MULESP IF(ICOUNT.NE.0) GO TO 401 400 IF(MDE.NE.0 .AND. IFULL.NE.0) WRITE(IWRITE,320) JA,JB IF(MDE.NE.0) ICOUNT=3 * * --- DIRECT INTEGRALS * * * --- IF MULDSS AND MULDSP = 0 MEANS NO =DIRECT= COEFFICIENTS * 401 IF(MULDSS.EQ.0) GO TO 22 L=0 DO 23 J=KDS1,KDS2,2 L=L+1 K=J-1 A=D00SNK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 23 IF(ICOUNT-2) 404,404,403 404 IF (IFULL.NE.0) WRITE(IWRITE,330) JA,JB,A,K,IAJCMP(JRHO), : IAJCMP(JSIG),IAJCMP(JRHOP),IAJCMP(JSIGP) ICOUNT=3 * WRITE(JSC3,305) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(8,A,K,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) GO TO 23 403 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC3,305) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(8,A,K,JRHO,JSIG,JRHOP,JSIGP,JA,JB,0) 23 CONTINUE 22 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 32 IF(MULDSP.EQ.0) GO TO 32 L=0 DO 33 J=KDS3,KDS4,2 L=L+1 K=J-1 A=D11SNK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 33 IF(ICOUNT-2) 408,408,407 408 IF (IFULL.NE.0) WRITE(IWRITE,330) JA,JB,A,K,IAJCMP(JSIG), : IAJCMP(JRHO),IAJCMP(JSIGP),IAJCMP(JRHOP) ICOUNT=3 * WRITE(JSC3,305) A,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(8,A,K,JSIG,JRHO,JSIGP,JRHOP,JA,JB,0) GO TO 33 407 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC3,305) A,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(8,A,K,JSIG,JRHO,JSIGP,JRHOP,JA,JB,0) 33 CONTINUE * * --- EXCHANGE INTEGRALS * 32 IF(M1.EQ.0.AND.M2.EQ.0) GO TO 200 * * --- IF MULESS AND MULESP = 0 MEANS NO =EXCHANGE= COEFFICIENTS * IF(MULESS.EQ.0) GO TO 42 L=0 DO 43 J=KES1,KES2,2 L=L+1 K=J-1 A=E01SNK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 43 IF(ICOUNT-2) 412,412,411 412 IF (IFULL.NE.0) WRITE(IWRITE,330) JA,JB,A,K,IAJCMP(JRHO), : IAJCMP(JSIG),IAJCMP(JSIGP),IAJCMP(JRHOP) ICOUNT=3 * WRITE(JSC3,305) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(8,A,K,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) GO TO 43 411 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JSIGP),IAJCMP(JRHOP) * WRITE(JSC3,305) A,K,IAJCMP(JRHO),IAJCMP(JSIG),JA, * : IAJCMP(JSIGP),IAJCMP(JRHOP),JB CALL SAVE(8,A,K,JRHO,JSIG,JSIGP,JRHOP,JA,JB,0) 43 CONTINUE 42 IF(MULESP.EQ.0) GO TO 200 L=0 DO 54 J=KES3,KES4,2 L=L+1 K=J-1 A=E10SNK(L)*SIGNCH IF(DABS(A).LT.EPS) GO TO 54 IF(ICOUNT-2) 416,416,415 416 IF (IFULL.NE.0) WRITE(IWRITE,330) JA,JB,A,K,IAJCMP(JSIG), : IAJCMP(JRHO),IAJCMP(JRHOP),IAJCMP(JSIGP) ICOUNT=3 * WRITE(JSC3,305) A,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(8,A,K,JSIG,JRHO,JRHOP,JSIGP,JA,JB,0) GO TO 54 415 IF (IFULL.NE.0) WRITE(IWRITE,3) A,K,IAJCMP(JSIG),IAJCMP(JRHO), : IAJCMP(JRHOP),IAJCMP(JSIGP) * WRITE(JSC3,305) A,K,IAJCMP(JSIG),IAJCMP(JRHO),JA, * : IAJCMP(JRHOP),IAJCMP(JSIGP),JB CALL SAVE(8,A,K,JSIG,JRHO,JRHOP,JSIGP,JA,JB,0) 54 CONTINUE 200 RETURN END * * ------------------------------------------------------------------ * R E D U C E * ------------------------------------------------------------------ * SUBROUTINE REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) DIMENSION LEAVE(10) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) * * THIS SUBROUTINE REMOVES SPECTATOR SINGLET S SHELLS WHICH HAVE * NO EFFECT IN ANGULAR OR SPIN INTEGRALS * * LMIN INITIALLY SET LARGE * LMIN=99 ICOUNT=0 DO 1 I=1,IHSH * * NO INTERACTING SHELL MAY BE REMOVED * IF(I.EQ.IRHO.OR.I.EQ.ISIG.OR.I.EQ.IRHOP.OR.I.EQ.ISIGP) GO TO 2 * * IF A SPECTATOR SHELL HAS SINGLET S COUPLING ON BOTH SIDES OF * THE MATRIX ELEMENT, IT MAY, IN GENERAL, BE REMOVED, AS IT HAS NO * EFFECT IN FANO * IF(J1QN1(I,1).EQ.0.AND.J1QN2(I,1).EQ.0) GO TO 7 2 ICOUNT=ICOUNT+1 LEAVE(ICOUNT)=I GO TO 1 7 IF(LJ(I).GE.LMIN) GO TO 1 LMIN=LJ(I) ILMIN=I 1 CONTINUE IF(ICOUNT.EQ.IHSH) GO TO 8 * * IF A CHANGE IN THE COMMON BLOCK MEDEFN IS TO BE MADE, * ITS PRESENT SITUATION MUST BE PRESERVED BY A CALL OF MEKEEP * CALL MEKEEP(IRHO,ISIG,IRHOP,ISIGP) * * IF ONLY ONE SHELL WOULD BE LEFT IN THIS WAY, THE ONE, DESTINED * FOR REMOVAL, WITH THE LOWEST L-VALUE MUST BE RETAINED TO DEFINE A * COUPLING * IF(ICOUNT.EQ.1) GO TO 10 * * --- MODIFY THE COMMON BLOCK MEDEFN * 13 CONTINUE DO 3 I=1,ICOUNT J=LEAVE(I) IF(J.EQ.IRHO) IRHO=I IF(J.EQ.ISIG) ISIG=I IF(J.EQ.IRHOP) IRHOP=I IF(J.EQ.ISIGP) ISIGP=I NJ(I)=NJ(J) LJ(I)=LJ(J) NOSH1(I)=NOSH1(J) NOSH2(I)=NOSH2(J) DO 4 K=1,3 J1QN1(I,K)=J1QN1(J,K) J1QN2(I,K)=J1QN2(J,K) 4 CONTINUE 3 CONTINUE ISUBH=IHSH-1 DO 5 I=2,ICOUNT J=LEAVE(I) II=ICOUNT+I-1 IJ=ISUBH+J DO 6 K=1,3 J1QN1(II,K)=J1QN1(IJ,K) J1QN2(II,K)=J1QN2(IJ,K) 6 CONTINUE 5 CONTINUE IHSH=ICOUNT GO TO 20 * * THIS SITUATION ONLY OCCURS IF IRHO=ISIG=IRHOP=ISIGP * 10 J=LEAVE(1) II=MIN0(J,ILMIN) LEAVE(1)=II LEAVE(2)=J+ILMIN-II ICOUNT=2 GO TO 13 20 IF(IBUG2.LE.1) GO TO 9 I2HSH=IHSH+IHSH-1 WRITE(IWRITE,35) WRITE(IWRITE,40) ((J1QN1(J,K),K=1,3),J=1,I2HSH) WRITE(IWRITE,36) WRITE(IWRITE,40) ((J1QN2(J,K),K=1,3),J=1,I2HSH) 35 FORMAT(/35H NEW DEFINITION OF COUPLING SCHEMES/38H FOR THIS SET OF : RHO, SIG, RHOP, SIGP//10X,48H L.H.S. OF HAMILTONIAN MATRIX ELEME :NT DEFINED BY) 36 FORMAT(10X,48H R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY) 40 FORMAT(10X,6H J1QN ,9(I5,2I3)) * * LESSEN = 0 IF NO CHANGE IN MEDEFN * = 1 OTHERWISE * 9 LESSEN=1 RETURN 8 LESSEN=0 RETURN END * * ------------------------------------------------------------------ * R E L R E C * ------------------------------------------------------------------ * SUBROUTINE RELREC(IRHO,ISIG,IRHOP,ISIGP,PICFP,ICALL,KK1,KK2, : KK3,KK4) * IMPLICIT REAL *8(A-H,O-Z) * * PARAMETER(KFL1=60,KFL2=12, : KFL6=120,KFL7=150,KFL8=120,KFL9=40,KFLW=20, : KFLS=12,KFLN=10,KFLV=40) LOGICAL FREE,FAILSD,FAILSE,FAILAD,FAILAE C C LOGICAL SMVRSD,SMVRSE,SMVRAD,SMVRAE DIMENSION K6SD(KFL6),K7SD(KFL7),K8SD(KFL8),K9SD(KFL9),KWSD(6,KFLW) + ,LDELSD(KFLW,2),SMVRSD(KFL1) DIMENSION K6SE(KFL6),K7SE(KFL7),K8SE(KFL8),K9SE(KFL9),KWSE(6,KFLW) + ,LDELSE(KFLW,2),SMVRSE(KFL1) DIMENSION K6AD(KFL6),K7AD(KFL7),K8AD(KFL8),K9AD(KFL9),KWAD(6,KFLW) + ,LDELAD(KFLW,2),SMVRAD(KFL1) DIMENSION K6AE(KFL6),K7AE(KFL7),K8AE(KFL8),K9AE(KFL9),KWAE(6,KFLW) + ,LDELAE(KFLW,2),SMVRAE(KFL1) C DIMENSION J6PSD(KFLV),J7PSD(KFLV),J8PSD(KFLV),J9PSD(KFLV), + JWRDSD(6,KFLW), + NBJSD(KFLN),NB6JSD(KFLN),K6CPSD(KFLN),K7CPSD(KFLN),K8CPSD(KFLN), + K9CPSD(KFLN),JSM6SD(KFLS),JSM4SD(KFLS,KFLW),JSM5SD(KFLS,KFLW), + IN6JSD(KFLW) DIMENSION J6PSE(KFLV),J7PSE(KFLV),J8PSE(KFLV),J9PSE(KFLV), + JWRDSE(6,KFLW), + NBJSE(KFLN),NB6JSE(KFLN),K6CPSE(KFLN),K7CPSE(KFLN),K8CPSE(KFLN), + K9CPSE(KFLN),JSM6SE(KFLS),JSM4SE(KFLS,KFLW),JSM5SE(KFLS,KFLW), + IN6JSE(KFLW) DIMENSION J6PAD(KFLV),J7PAD(KFLV),J8PAD(KFLV),J9PAD(KFLV), + JWRDAD(6,KFLW), + NBJAD(KFLN),NB6JAD(KFLN),K6CPAD(KFLN),K7CPAD(KFLN),K8CPAD(KFLN), + K9CPAD(KFLN),JSM6AD(KFLS),JSM4AD(KFLS,KFLW),JSM5AD(KFLS,KFLW), + IN6JAD(KFLW) DIMENSION J6PAE(KFLV),J7PAE(KFLV),J8PAE(KFLV),J9PAE(KFLV), + JWRDAE(6,KFLW), + NBJAE(KFLN),NB6JAE(KFLN),K6CPAE(KFLN),K7CPAE(KFLN),K8CPAE(KFLN), + K9CPAE(KFLN),JSM6AE(KFLS),JSM4AE(KFLS,KFLW),JSM5AE(KFLS,KFLW), + IN6JAE(KFLW) C * COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 COMMON/SSMULT/DMULS0(12),DMULS1(12),EMULS0(12),EMULS1(12) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * 301 FORMAT(24H DIRECT SPIN INTEGRALS =,2F12.6) 302 FORMAT(26H EXCHANGE SPIN INTEGRALS =,2F12.6) 303 FORMAT(3H J1,I6,36I3) 304 FORMAT(26H DIRECT ANGULAR INTEGRAL =,F12.6) 305 FORMAT(28H EXCHANGE ANGULAR INTEGRAL =,F12.6) 306 FORMAT(5X,8H PICFP =,F12.6) 307 FORMAT(5X,9H SPIND0 =,F12.6,5X,9H SPIND1 =,F12.6) 308 FORMAT(5X,9H SPINE0 =,F12.6,5X,9H SPINE1 =,F12.6) 309 FORMAT(5X,9H DMULTN =,6F12.6) 310 FORMAT(5X,9H EMULTN =,6F12.6) * * * --- THIS SUBROUTINE EVALUATES THE DIRECT AND EXCHANGE SPIN AND * ORBITAL RECOUPLING COEFFICIENTS FOR THE SPIN-OTHER-ORBIT * AND/OR SPIN-SPIN INTERACTION(S) * * M21=M17+1 * * --- SET UP J1, J2, AND J3 ARRAYS * * FIRST OF ALL, THE RECOUPLING COEFFICIENT * * * IF (ICALL.EQ.0) THEN I = 2 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP, : 0,0,KK1,KK2,KK3,KK4) MLIMIT=M16 NJ1S=M8+11 NJ23S=M18+1 IF(IBUG2-1) 113,113,116 116 IF(IBUG3.NE.1) WRITE(IWRITE,303) (J1(J),J=1,MLIMIT) 113 CONTINUE FAILAD = .FALSE. FAILAE = .FALSE. C FREE(M17) = .TRUE. FREE(M21) = .TRUE. FREE(NJ1S) = .TRUE. J1(M17) = 1 J1(M21) = 1 J1(NJ1S) = 1 J23REL=0 CALL J23SP1(J23REL) cdbg print*,(j1(ik),ik=1,nj1s) cdbg print*,' free in relrec = ',(free(ik),ik=1,nj1s) CALL NJGRAF(ANG,FAILAD) cdbg print*,' ang = ',ang,' failad = ',failad C ICI KNJAD CALL KNJ(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD) CALL J23SP1(J23REL) CALL MODREL CALL NJGRAF(ANG,FAILAE) cdbg print*,' ang = ',ang,' failae = ',failae C ICI KNJAE CALL KNJ(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE) ENDIF * I=3 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,0,0,KK1,KK2, : KK3,KK4) J1(M15)=2 J1(M16)=2 MLIMIT=M16 NJ1S = M8+11 NJ23S = M18+1 * IF(IBUG2-1) 13,13,16 16 IF(IBUG3.NE.1) WRITE(IWRITE,303) (J1(J),J=1,MLIMIT) 13 CONTINUE IF (ICALL.EQ.0) THEN ICALL=1 FAILSD = .FALSE. FAILSE = .FALSE. FREE(M17) = .TRUE. FREE(M21) = .TRUE. FREE(NJ1S) = .TRUE. J1(M17) = 1 J1(M21) = 1 J1(NJ1S) = 1 J23REL=0 CALL J23SP1(J23REL) cdbg print*,(j1(ik),ik=1,nj1s) cdbg print*,' free in relrec = ',(free(ik),ik=1,nj1s) cdbg print*,((j2(ik,jk),jk=1,3),ik=1,nj23s-1) cdbg print*,((j3(ik,jk),jk=1,3),ik=1,nj23s-1) cdbg print*,' I will probably be looping...' CALL NJGRAF(SPNDT1,FAILSD) cdbg print*,' I am not looping here...' cdbg print*,' spndt1 = ',spndt1,' failsd = ',failsd C ICI KNJSD CALL KNJ(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD) CALL J23SP1(J23REL) CALL MODREL CALL NJGRAF(SPNDT1,FAILSE) cdbg print*,' spndt1 = ',spndt1,' failse = ',failse C ICI KNJSE CALL KNJ(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE) ENDIF * * --- SPIN-OTHER-ORBIT INTERACTION * IF(ISOORB.EQ.0) GO TO 100 * * --- EVALUATION OF THE DIRECT SPIN RECOUPLING COEFFICIENTS * IF(KD1-KD2) 1,1,2 2 SPNDT1=ZERO SPNDT2=ZERO GO TO 3 1 IF (.NOT.FAILSD) THEN J1(M17)=3 J1(M21)=1 J1(NJ1S)=3 C ICI GENSUMSD CALL GENSUM(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD,SPNDT1) J1(M17)=1 J1(M21)=3 C ICI GENSUMSD CALL GENSUM(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD,SPNDT2) ELSE SPNDT1 = ZERO SPNDT2 = ZERO END IF 3 IF(IBUG2.GT.0) WRITE(IWRITE,301) SPNDT1,SPNDT2 * * --- MULTIPLY SPIN RECOUPLING COEFFICIENTS BY PRODUCT OF * FRACTIONAL PARENTAGE COEFFICIENTS * SPIND0=(SPNDT1+SPNDT2+SPNDT2)*PICFP SPIND1=(SPNDT1+SPNDT1+SPNDT2)*PICFP * * --- EVALUATION OF THE EXCHANGE SPIN RECOUPLING COEFFICIENTS * * * --- IF M1=0=M2 THE EXCHANGE SPIN RECOUPLING COEFFICIENT HAS ZERO * COEFFICIENT. THERE IS THEN NO POINT IN CALCULATING THIS * COEFFICIENT AND SPNEX1 AND SPNEX2 ARE SET ZERO * IF(M1.NE.0.OR.M2.NE.0) GO TO 4 7 SPNEX1=ZERO SPNEX2=ZERO GO TO 5 4 IF(KE1-KE2) 6,6,7 6 CONTINUE * * --- MODIFY J2 AND J3 ARRAYS TO CALCULATE THE EXCHANGE SPIN * RECOUPLING COEFFICIENT * IF (.NOT.FAILSE) THEN J1(M17)=3 J1(M21)=1 J1(NJ1S)=3 C ICI GENSUMSE CALL GENSUM(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE,SPNEX1) J1(M17)=1 J1(M21)=3 C ICI GENSUMSE CALL GENSUM(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE,SPNEX2) ELSE SPNEX1 = ZERO SPNEX2 = ZERO END IF 5 IF(IBUG2.GT.0) WRITE(IWRITE,302) SPNEX1,SPNEX2 * * --- MULTIPLY SPIN RECOUPLING COEFFICIENTS BY PRODUCT OF * FRACTIONAL PARENTAGE COEFFICIENTS * SPINE0=(SPNEX1+SPNEX2+SPNEX2)*PICFP SPINE1=(SPNEX2+SPNEX1+SPNEX1)*PICFP * * --- IF THE DIRECT AND EXCHANGE SPIN RECOUPLING COEFFICIENTS ARE * ZERO, WE NEED NOT CALCULATE THE CORRESPONDING ORBITAL RECOUPLING * COEFFICIENTS * IF(DABS(SPIND0).LT.EPS.AND.DABS(SPIND1).LT.EPS.AND.DABS(SPINE0).LT : .EPS.AND.DABS(SPINE1).LT.EPS) GO TO 100 I=2 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,2,2,KK1,KK2,KK3,KK4) NJ1S=M8+11 NJ23S=M18+1 IF(IBUG2-1) 17,17,18 18 IF(IBUG3.NE.1) WRITE(IWRITE,303) (J1(J),J=1,MLIMIT) * * --- EVALUATION OF THE DIRECT ORBITAL RECOUPLING COEFFICIENTS * * * --- IF THE DIRECT SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * 17 IF(DABS(SPIND0).LT.EPS.AND.DABS(SPIND1).LT.EPS) GO TO 19 IF (FAILAD) GO TO 19 L=0 DO 20 J=KD1,KD2,2 * * --- CONSIDER ALL ALLOWED K-VALUES * N=0 L=L+1 K=J-1 JI=J+2 DO 21 JJ=J,JI N=N+1 I=JJ-2 ICS=I+K+1 IF(I.LE.0.AND.K.EQ.0) GO TO 21 J1(M17)=I+I+1 J1(M21)=K+K+1 cdbg print*,' in do 20,before 1 call gensum , j1 = ' cdbg print*,(j1(ik),ik=1,nj1s) C ICI GENSUMAD CALL GENSUM(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD,ANGDIR) IF(IBUG2.GT.0) WRITE(IWRITE,304) ANGDIR DMULT0(L,N)=DMULT0(L,N)+ANGDIR*SPIND0*(-ONE)**ICS IF(I.NE.K) GO TO 22 DMULT1(L,N)=DMULT1(L,N)+ANGDIR*SPIND1 GO TO 121 22 CONTINUE J1(M17)=K+K+1 J1(M21)=I+I+1 cdbg print*,' in do 20,before 2 call gensum , j1 = ' cdbg print*,(j1(ik),ik=1,nj1s) C ICI GENSUMAD CALL GENSUM(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD,ANGDIR) IF(IBUG2.GT.0) WRITE(IWRITE,304) ANGDIR DMULT1(L,N)=DMULT1(L,N)+ANGDIR*SPIND1 * * --- MULDSO=1 WHEN A DIRECT INTEGRAL COEFFICIENT HAS BEEN CALCULATED * FOR USE, SEE RADWTS * 121 MULDSO=1 21 CONTINUE 20 CONTINUE * * --- EVALUATION OF THE EXCHANGE ORBITAL RECOUPLING COEFFICIENTS * * * --- IF THE EXCHANGE SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * 19 IF(DABS(SPINE0).LT.EPS.AND.DABS(SPINE1).LT.EPS) GO TO 99 IF(M1.EQ.0.AND.M2.EQ.0) GO TO 99 * * --- CONSIDER ALL ALLLOWED K-VALUES * IF(KE1.GT.KE2 .OR. FAILAE) GO TO 99 L=0 DO 30 J=KE1,KE2,2 N=0 L=L+1 K=J-1 JI=J+2 DO 31 JJ=J,JI N=N+1 I=JJ-2 ICS=I+K+1 IF(I.LE.0.AND.K.EQ.0) GO TO 31 * * --- MODIFY J2 AND J3 ARRAYS TO CALCULATE THE EXCHANGE ORBITAL * RECOUPLING COEFFICIENT * J1(M17)=I+I+1 J1(M21)=K+K+1 C ICI GENSUMAE CALL GENSUM(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE,ANGEX) IF(IBUG2.GT.0) WRITE(IWRITE,305) ANGEX EMULT0(L,N)=EMULT0(L,N)-ANGEX*SPINE0*(-ONE)**ICS IF(I.NE.K) GO TO 32 EMULT1(L,N)=EMULT1(L,N)-ANGEX*SPINE1 GO TO 131 32 CONTINUE J1(M17)=K+K+1 J1(M21)=I+I+1 C ICI GENSUMAE CALL GENSUM(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE,ANGEX) IF(IBUG2.GT.0) WRITE(IWRITE,305) ANGEX EMULT1(L,N)=EMULT1(L,N)-ANGEX*SPINE1 * * --- MULESO=1 WHEN AN EXCHANGE INTEGRAL COEFFICIENT HAS BEEN CALCULATED * FOR USE, SEE RADWTS * 131 MULESO=1 31 CONTINUE 30 CONTINUE * * --- SPIN-SPIN INTERACTION * 99 IF(ISPSPN.EQ.0) RETURN I=3 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,2,2,KK1,KK2,KK3,KK4) J1(M15)=2 J1(M16)=2 NJ1S=M8+11 NJ23S=M18+1 IF(IBUG2-1) 100,100,33 33 IF(IBUG3.NE.1) WRITE(IWRITE,303)(J1(J),J=1,MLIMIT) * * --- EVALUATION OF THE DIRECT SPIN RECOUPLING COEFFICIENT * 100 IF(ISPSPN.EQ.0) RETURN IF(KDS1.LE.KDS2.OR.KDS3.LE.KDS4) GO TO 101 SPINDT=ZERO GO TO 102 101 IF (.NOT.FAILSD) THEN J1(M17)=3 J1(M21)=3 J1(NJ1S)=5 C ICI GENSUMSD CALL GENSUM(J6CSD,J7CSD,J8CSD,J9CSD,JWCSD,K6SD,K7SD,K8SD,K9SD, + KWSD,JDELSD,LDELSD,SMVRSD,MPSD, + J6PSD,J7PSD,J8PSD,J9PSD,JWRDSD,NLSMSD,NBJSD,NB6JSD, + K6CPSD,K7CPSD,K8CPSD,K9CPSD,JSM4SD,JSM5SD,JSM6SD, + IN6JSD,SPINDT) ELSE SPINDT = ZERO END IF 102 IF(IBUG2.GT.0) WRITE(IWRITE,301) SPINDT * * --- MULTIPLY SPIN RECOUPLING COEFFICIENT BY PRODUCT OF FRACTIONAL * PARENTAGE COEFFICIENTS * SPINDT=SPINDT*PICFP * * --- EVALUATION OF THE EXCHANGE SPIN RECOUPLING COEFFICIENT * * * --- IF M1=0=M2 THE EXCHANGE SPIN RECOUPLING COEFFICIENT HAS ZERO * COEFFICIENT. THERE IS THEN NO POINT IN CALCULATING THIS * COEFFICIENT AND SPINEX IS SET ZERO * IF(M1.NE.0.OR.M2.NE.0) GO TO 103 106 SPINEX=ZERO GO TO 104 103 IF(KES1.LE.KES2.OR.KES3.LE.KES4) GO TO 105 GO TO 106 105 CONTINUE * * --- MODIFY J2 AND J3 ARRAYS TO CALCULATE THE EXCHANGE SPIN RECOUPLING * COEFFICIENT * IF (.NOT.FAILSE) THEN J1(M17)=3 J1(M21)=3 J1(NJ1S)=5 C ICI GENSUMSE CALL GENSUM(J6CSE,J7CSE,J8CSE,J9CSE,JWCSE,K6SE,K7SE,K8SE,K9SE, + KWSE,JDELSE,LDELSE,SMVRSE,MPSE, + J6PSE,J7PSE,J8PSE,J9PSE,JWRDSE,NLSMSE,NBJSE,NB6JSE, + K6CPSE,K7CPSE,K8CPSE,K9CPSE,JSM4SE,JSM5SE,JSM6SE, + IN6JSE,SPINEX) ELSE SPINEX = ZERO END IF 104 IF(IBUG2.GT.0) WRITE(IWRITE,302) SPINEX * * --- MULTIPLY SPIN RECOUPLING COEFFICIENT BY PRODUCTS OF FRACTIONAL * PARENTAGE COEFFICIENTS * SPINEX=SPINEX*PICFP * * --- IF THE DIRCET AND EXCHANGE SPIN RECOUPLING COEFFICIENTS ARE * ZERO, WE NEED NOT CALCULATE THE CORRESPONDING ORBITAL RECOUPLING * COEFFICIENTS * IF(DABS(SPINDT).LT.EPS.AND.DABS(SPINEX).LT.EPS) RETURN I=2 CALL SETJ1(I,IRHO,ISIG,IRHOP,ISIGP,2,2,KK1,KK2,KK3,KK4) NJ1S=M8+11 NJ23S=M18+1 IF(IBUG2-1) 34,34,35 35 IF(IBUG3.NE.1) WRITE(IWRITE,303) (J1(J),J=1,MLIMIT) * * --- EVALUATION OF THE DIRECT RECOUPLING COEFFICIENTS * * * --- IF THE DIRECT SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * 34 IF(DABS(SPINDT).LT.EPS) GO TO 50 IF(KDS1.GT.KDS2 .OR. FAILAD) GO TO 40 L=0 * * --- CONSIDER ALL ALLOWED K-VALUES * DO 36 J=KDS1,KDS2,2 K=J-1 L=L+1 J1(M17)=K+K+5 J1(M21)=K+K+1 C ICI GENSUMAD CALL GENSUM(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD,ANGDIR) IF(IBUG2.GT.0) WRITE(IWRITE,304) ANGDIR DMULS0(L)=DMULS0(L)+ANGDIR*SPINDT * * --- MULDSS=1 WHEN A DIRECT RECOUPLING COEFFICIENT HAS BEEN CALCULATED * FOR USE, SEE RADWTS * MULDSS=1 36 CONTINUE 40 IF(KDS3.GT.KDS4) GO TO 50 IF(M1.EQ.0.OR.M2.EQ.0 .OR. FAILAD) GO TO 50 L=0 * * --- CONSIDER ALL ALLOWED K-VALUES * DO 37 J=KDS3,KDS4,2 K=J-1 L=L+1 J1(M17)=K+K+1 J1(M21)=K+K+5 C ICI GENSUMAD CALL GENSUM(J6CAD,J7CAD,J8CAD,J9CAD,JWCAD,K6AD,K7AD,K8AD,K9AD, + KWAD,JDELAD,LDELAD,SMVRAD,MPAD, + J6PAD,J7PAD,J8PAD,J9PAD,JWRDAD,NLSMAD,NBJAD,NB6JAD, + K6CPAD,K7CPAD,K8CPAD,K9CPAD,JSM4AD,JSM5AD,JSM6AD, + IN6JAD,ANGDIR) IF(IBUG2.GT.0) WRITE(IWRITE,304) ANGDIR DMULS1(L)=DMULS1(L)+ANGDIR*SPINDT * * --- MULDSP=1 WHEN A DIRECT RECOUPLING COEFFICIENT HAS BEEN CALCULATED * MULDSP=1 37 CONTINUE * * --- EVALUATION OF THE EXCHANGE ORBITAL RECOUPLING COEFFICIENTS * * * --- IF THE EXCHANGE SPIN RECOUPLING COEFFICIENT IS ZERO, WE NEED NOT * CALCULATE THE CORRESPONDING ORBITAL RECOUPLING COEFFICIENT * 50 IF(DABS(SPINEX).LT.EPS) RETURN IF(KES1.GT.KES2.OR.M2.EQ.0 .OR. FAILAE) GO TO 60 L=0 * * --- CONSIDER ALL ALLOWED K-VALUES * DO 51 J=KES1,KES2,2 K=J-1 L=L+1 * * --- MODIFY J2 AND J3 ARRAYS TO CALCULATE THE EXCHANGE ORBITAL * RECOUPLING COEFFICIENT * J1(M17)=K+K+5 J1(M21)=K+K+1 C ICI GENSUMAE CALL GENSUM(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE,ANGEX) IF(IBUG2.GT.0) WRITE(IWRITE,305) ANGEX EMULS0(L)=EMULS0(L)-ANGEX*SPINEX * * --- MULESS=1 WHEN AN EXCHANGE RECOUPLING COEFFICIENT HAS BEEN * CALCULATED FOR USE, SEE RADWTS * MULESS=1 51 CONTINUE 60 IF(KES3.GT.KES4.OR.M1.EQ.0 .OR. FAILAE) RETURN L=0 * * --- CONSIDER ALL ALLOWED K-VALUES * DO 61 J=KES3,KES4,2 K=J-1 L=L+1 * * --- MODIFY J2 AND J3 ARRAYS TO CALCULATE THE EXCHANGE ORBITAL * RECOUPLING COEFFICIENT * J1(M17)=K+K+1 J1(M21)=K+K+5 C ICI GENSUMAE CALL GENSUM(J6CAE,J7CAE,J8CAE,J9CAE,JWCAE,K6AE,K7AE,K8AE,K9AE, + KWAE,JDELAE,LDELAE,SMVRAE,MPAE, + J6PAE,J7PAE,J8PAE,J9PAE,JWRDAE,NLSMAE,NBJAE,NB6JAE, + K6CPAE,K7CPAE,K8CPAE,K9CPAE,JSM4AE,JSM5AE,JSM6AE, + IN6JAE,ANGEX) IF(IBUG2.GT.0) WRITE(IWRITE,305) ANGEX EMULS1(L)=EMULS1(L)-ANGEX*SPINEX * * --- MULESP=1 WHEN AN EXCHANGE RECOUPLING COEFFICIENT HAS BEEN * CALCULATED FOR USE, SEE RADWTS * MULESP=1 61 CONTINUE RETURN END * * ------------------------------------------------------------------ * R K W T S * ------------------------------------------------------------------ * SUBROUTINE RKWTS(ICOUNT,JA,JB,INCL) * IMPLICIT REAL *8(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 LOGICAL INCL * * *****:****************************************************************** * * * --- THE ROUTINE RKWTS, TOGETHER WITH THOSE CALL BY IT, HAS BEEN * MODIFIED TO EVALUATE THE FOLLOWING INTERACTIONS * * IREL.EQ.0 THE NON-RELATIVISTIC HAMILTONIAN * * IREL.NE.0 THE RELATIVISTIC OPERATORS OF THE BREIT-PAULI * HAMILTONIAN * * *****:****************************************************************** * * * THE MATRIX ELEMENT OF THE TWO-ELECTRON POTENTIAL BETWEEN TWO * STATES (LABELLED 1 AND 2) MAY BE EXPRESSED AS A SUM OF WEIGHTED * RK (SLATER) INTEGRALS. THIS SUBROUTINE, TOGETHER WITH THOSE * CALLED BY IT, DETERMINES THESE WEIGHTS, WHICH ARISE FROM AN * INTEGRATION OVER THE ANGULAR AND SPIN CO-ORDINATES * FOR DETAILS, SEE U. FANO, PHYS. REV.,140,A67,(1965) * * THE =INTERACTING= SHELLS ARE DESIGNATED IRHO,ISIG,IRHOP,ISIGP. * THE FIRST TWO REFER TO THE L.H.S. OF (PSI/V/PSIP) , WHILE * THE SECOND TWO REFER TO THE R.H.S. FOR DIAGONAL AND CERTAIN OFF- * DIAGONAL MATRIX ELEMENTS, THESE MAY NOT BE UNIQUE, AND EACH * POSSIBILITY MUST BE CONSIDERED IN TURN * THE CONDITION =IRHO .LE. ISIG , IRHOP .LE. ISIGP= IS TO BE * SATISFIED * 61 FORMAT(//10X,7H IRHO =,I3,4X,7H ISIG =,I3,4X,8H IRHOP =,I3,3X,8H I :SIGP =,I3) * * === DETERMINE THE INTERACTING SHELLS AS FAR AS POSSIBLE BY * CONSIDERING THE DIFFERENCES BETWEEN PSI AND PSIP * IZERO = 0 IX=0 IRHO=0 ISIG=0 IRHOP=0 ISIGP=0 DO 4 J=1,IHSH N=NOSH1(J)-NOSH2(J) IF(IABS(N)-2) 5,5,1 5 IF(N) 7,4,6 6 IF(N-1) 4,8,9 * * --- TO SATISFY =IRHO.LE.ISIG= IRHO IS SET FIRST, ETC. * 8 IF(IRHO) 10,10,11 10 IRHO = J GO TO 12 11 ISIG=J 12 IX =IX+1 GO TO 4 9 IRHO=J IX=IX+2 GO TO 4 7 IF(N+1) 13,14,4 14 IF(IRHOP) 15,15,16 15 IRHOP = J GO TO 17 16 ISIGP=J 17 IX=IX+1 GO TO 4 13 IRHOP=J IX=IX+2 4 CONTINUE * * IX MEASURES THE TOTAL NUMBER OF ELECTRONS IN EITHER CONFIGURATION * WHICH DO NOT OCCUR IN THE OTHER. THEN IF IX IS GREATER THAN 4, * ORTHOGONALITY OF THE ORBITALS PREVENTS A NON-ZERO MATRIX ELEMENT. * IF IX IS LESS THAN 4, THEN WE DIVIDE IX BY 2 AND NOW IX MEASURES * THE NUMBER OF ELECTRONS WHICH HAVE BEEN CHANGED IN GOING FROM PSI * TO PSIP. IF NOW IX=0, WE HAVE A DIAGONAL MATRIX ELEMENT. RHO AND * SIG MAY TAKE ON ANY VALUES LESS THAN IHSH. IF IX=1, ONE INTER- * ACTING SHELL ON EACH SIDE IS FIXED, WHILE THE OTHER MAY VARY. IF * IX=2, ALL INTERACTING SHELLS ARE DETERMINED * IF(IX-4) 18,18,1 18 IX=IX/2 IF(IX-1) 19,20,21 * * === UNIQUE SPECIFICATION OF INTERACTING SHELLS * 21 IF(ISIG) 22,23,22 23 ISIG=IRHO 22 IF(ISIGP) 24,25,24 25 ISIGP = IRHOP 24 IF(IBUG2.GT.0) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP * * --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS * AND/OR THE COEFFICIENTS OF THE RADIAL INTEGRALS FOR THE * RELATIVISTIC OPERATORS * 70 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM 75 CALL FANO(IRHO,ISIG,IRHOP,ISIGP,JA,JB,INCL) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.1) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.0.AND.INCL) CALL RADWTS(IRHO,ISIG,IRHOP,ISIGP,ICOUNT) RETURN * * === ONE INTERACTING SHELL SPECIFIED ON EACH SIDE. SUMMATION OVER OTHER * 20 IRSTO=IRHO IRPSTO=IRHOP DO 125 K1=1,IHSH IF(NOSH1(K1)) 26,125,26 26 ISIG=K1 IF(NOSH2(K1)) 29,125,29 29 ISIGP = K1 IRHO=IRSTO IRHOP=IRPSTO * * ORTHOGONALITY OF THE ORBITALS REQUIRES THAT THE VARYING INTER- * ACTING SHELL BE THE SAME ON BOTH SIDES OF THE MATRIX ELEMENT * * --- IRHO.LE.ISIG, IRHOP.LE.ISIGP * IF(IRHO-ISIG) 27,127,227 227 ISTO=IRHO IRHO=ISIG ISIG = ISTO GO TO 27 127 IF(NOSH1(ISIG)-1) 125,125,27 27 IF(IRHOP-ISIGP) 30,130,31 31 ISTO=IRHOP IRHOP = ISIGP ISIGP = ISTO GO TO 30 130 IF(NOSH2(ISIGP)-1) 125,125,30 30 IF(IBUG2.GT.0) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP LC = 4*LJ(K1)+2 IF (NOSH1(K1) .NE. LC) GO TO 71 IF (IREL .NE. 1 .AND. IELST .NE. 0) CALL CLSHEL(IRSTO,IRPSTO,K1) IF (IREL.NE.0.AND.INCL) CALL CLSHBW(IRSTO,IRPSTO,K1) GO TO 125 * * --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS * AND/OR THE COEFFICIENTS OF THE RADIAL INTEGRALS FOR THE * RELATIVISTIC OPERATORS * 71 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM 76 CALL FANO(IRHO,ISIG,IRHOP,ISIGP,JA,JB,INCL) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.1) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.0.AND.INCL) CALL RADWTS(IRHO,ISIG,IRHOP,ISIGP,ICOUNT) 125 CONTINUE IF (NCLOSD.NE.0 .AND. IFULL.NE.0) THEN IF (IREL.NE.1 .AND. IELST.NE.0) CALL CLSHEL(IRSTO,IRPSTO,IZERO) IF(IREL.NE.0.AND.INCL) CALL CLSHBW(IRSTO,IRPSTO,IZERO) END IF RETURN * * === NO INTERACTING SHELLS SPECIFIED * SUMMATION OVER ALL POSSIBLE COMBINATIONS * IN THIS CASE, ORTHOGONALITY OF ORBITALS PRECLUDES ALL CASES * EXCEPT IRHO=IRHOP AND ISIG=ISIGP * 19 DO 32 K1=1,IHSH IF(NOSH1(K1)) 36,32,36 36 ISIG=K1 DO 33 K2=1,K1 IF(NOSH1(K2)) 37,33,37 37 IRHO=K2 IF(IRHO-ISIG) 50,51,50 51 IF(NOSH1(ISIG)-1) 33,33,50 50 IRHOP=IRHO ISIGP=ISIG IF(IBUG2.GT.0) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP * * --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS * AND/OR/THE COEFFICIENTS OF THE RADIAL INTEGRALS FOR THE * RELATIVISTIC OPERATORS * 2 N1 = NOSH1(IRHO) N2 = NOSH1(ISIG) L1 = 4*LJ(IRHO) + 2 L2 = 4*LJ(ISIG) + 2 IF(JA.NE.JB) GO TO 78 IF(N1.NE.L1.AND.N2.NE.L2) GO TO 78 IF (IREL.NE.0 .AND. (N1.NE.L1.OR.N2.NE.L2) .AND. : INCL) CALL BLMWAT(IRHO,ISIG) IF (IREL.NE.1) CALL USEEAV(IRHO,ISIG) GO TO 33 78 CONTINUE CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM 77 CALL FANO(IRHO,ISIG,IRHOP,ISIGP,JA,JB,INCL) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.1) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) IF(IREL.NE.0.AND.INCL) CALL RADWTS(IRHO,ISIG,IRHOP,ISIGP,ICOUNT) 33 CONTINUE 32 CONTINUE IF (NCLOSD .NE. 0 .AND. IFULL .NE. 0) THEN IF (IREL.NE.1 .AND. IELST.NE.0) CALL CLSHEL(IZERO,IZERO,IZERO) IF (IREL.NE.0.AND.INCL) CALL CLSHBW(IZERO,IZERO,IZERO) END IF 1 RETURN END * * ------------------------------------------------------------------ * R M E C L L * ------------------------------------------------------------------ * SUBROUTINE RMECLL(L,LP,K,K1,RMECL) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS * * EVALUATES THE REDUCED MATRIX ELEMENT (L//(C(K1)*L)(K)//LP) * RMECL=ZERO IF(LP.EQ.0) RETURN ALP=DFLOAT(LP) RMEL=DSQRT(ALP*(ALP+ONE)*(ALP+ALP+ONE)) L2=L+L LP2=LP+LP K12=K1+K1 IL2=2 K2=K+K AK12=K12+ONE ISIGN=LP-L+K CALL GRACAH(LP2,LP2,K12,K2,IL2,L2,RACAH) RMECL=RACAH*RMEL*DSQRT(AK12)*(-ONE)**ISIGN RETURN END * * ------------------------------------------------------------------ * S E T J 1 * ------------------------------------------------------------------ * SUBROUTINE SETJ1(K,IRHO,ISIG,IRHOP,ISIGP,ITST1,ITST2,K1,K2,K3,K4) PARAMETER(KFL1=60,KFL2=12) LOGICAL FREE COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/INTERM/J1BAR1(10,3),J1BAR2(10,3),J1TLD1(3),J1TLD2(3) COMMON/COUPLE/NJ1S,NJ23S,J1(KFL1),J2(KFL2,3),J3(KFL2,3),FREE(KFL1) * * === SETS J1 ARRAYS FOR DIRECT INTEGRAL CALLS OF NJSYM * 14 FORMAT(' J1: ',36I3) 15 FORMAT('FREE: ',36I3) DO 1 J=1,IHSH J1(J)=J1BAR1(J,K) 1 CONTINUE DO 2 J=M4,M6 J1(J)=J1QN1(J,K) 2 CONTINUE DO 3 J=M7,M8 J1(J)=J1QN2(J-M3,K) 3 CONTINUE J1(M10)=J1QN1(ISIG,K) J1(M12)=J1QN2(ISIGP,K) IF(M1) 4,5,4 4 J1(M9)=J1QN1(IRHO,K) GO TO 6 5 J1(M9)=J1TLD1(K) 6 IF(M2) 7,8,7 7 J1(M11)=J1QN2(IRHOP,K) GO TO 9 8 J1(M11)=J1TLD2(K) * * K=2 IMPLIES ANGULAR TERMS , K=3 IMPLIES SPIN TERMS * 9 IF(K-2) 11,11,10 10 J1(M13)=2 J1(M14)=2 MLIMIT=M14 NJ1S=M14 NJ23S=M5 GO TO 12 11 J1(M13)=2*LRHO+1 J1(M14)=2*LSIG+1 J1(M15)=2*LRHOP+1 J1(M16)=2*LSIGP+1 MLIMIT=M16 NJ1S=M17 NJ23S=M18 12 IF(IBUG2-1) 13,13,16 * * PRINT-OUT OF VALUES IN NJSYM IF IBUG3=1 * 16 IF(IBUG3.NE.1) WRITE(IWRITE,14)(J1(J),J=1,MLIMIT) C C IF ITST1.NE.2 OR ITST2.NE.2 THEN NJGRAF IS BEING CALLED, SO SET C THE ELEMENTS OF THE FREE ARRAY. C C 13 IF ((ITST1.NE.2).OR.(ITST2.NE.2)) THEN C DO 21 J=1,MLIMIT FREE(J)=.FALSE. 21 CONTINUE IF(K1.NE.1) FREE(IRHO)=.TRUE. IF(M1.EQ.0) THEN IF(K2.NE.1) FREE(M9)=.TRUE. ELSE IF(K2.NE.1) FREE(ISIG)=.TRUE. ENDIF IF(M2.EQ.0.AND.K4.NE.1) FREE(M11)=.TRUE. C C PRINT-OUT OF VALUES IN NJGRAF IF IBUG3=1 C IF(IBUG1.GT.1) THEN IF(IBUG3.NE.1) WRITE(IWRITE,15)(FREE(J),J=1,MLIMIT) ENDIF C ENDIF C RETURN END * * ------------------------------------------------------------------ * S E T M * ------------------------------------------------------------------ * SUBROUTINE SETM COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 * * --- SET CONSTANTS USEFUL IN INNER SUBROUTINES * M3=IHSH-1 M4=IHSH+1 M5=IHSH+2 M6=2*IHSH-1 M7=M6+1 M8=M3+M6 M9=M8+1 M10=M8+2 M11=M8+3 M12=M8+4 M13=M8+5 M14=M8+6 M15=M8+7 M16=M8+8 M17=M8+9 M18=IHSH+3 RETURN END * * ------------------------------------------------------------------ * S E T U P * ------------------------------------------------------------------ * SUBROUTINE SETUP(JA,JB) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH(10,2),J1QN(19,3,2),IJFUL(10) * * NOTICE THE DIFFERENT NAMES IN THE COMMON BLOCK MEDEFN - WE * STORE NOSH1(I=1,10) AS NOSH((I=1,10),1) AND NOSH2(I=1,10) AS * NOSH((I=1,10),2) AND USE THE FACT THAT NOSH1 AND NOSH2 WILL THEN * BE EQUIVALENT TO THE SINGLE 2-DIMENSIONAL ARRAY NOSH. SIMILARLY * FOR J1QN * * === GENERATES THE ARRAYS NJ,LJ - DEFINING THE QUANTUM NUMBERS OF THE * SHELLS, NOSH - DEFINING THE OCCUPATION OF THE SHELLS, J1QN - * DEFINING THE COUPLING OF THE SHELLS, FOR EACH OF THE TWO * CONFIGURATIONS CONSIDERED. ONLY THOSE SHELLS OCCURRING IN AT * LEAST ONE CONFIGURATION ARE INCLUDED. * AT LEAST TWO SHELLS MUST BE CONSIDERED OCCUPIED. * THUS (1S)**2 HELIUM MUST BE TREATED AS ,E.G., (1S)**2(2S)**0 * THE SIZE OF THE ARRAYS HERE CALCULATED IS ARRANGED TO BE NO * GREATER THAN IS NECESSARY TO INCLUDE ALL ORBITALS WHICH ARE * DEEMED TO BE OCCUPIED IN EITHER OR BOTH OF THE CONFIGURATIONS * JA,JB * * --- INITIALIZE BASIC QUANTITIES - (I1+1) RUNS OVER 1,MAXORB, IHSH IS * THE CURRENT VALUE OF THE HIGHEST OCCUPIED SHELL YET CONSIDERED, * WHILE I2HSH=2*IHSH-1 * * * INITIALIZE J1 AND J2 * J1=0 J2=0 I1=0 IHSH=0 I2HSH=-1 IA=NOCCSH(JA) IB=NOCCSH(JB) * * --- TEST ON WHETHER LIMIT OF I1 HAS BEEN REACHED * 1 IF(I1-MAXORB) 101,100,100 * * --- INCREASE BASIC QUANTITIES * 101 I1=I1+1 I3=IHSH+1 I5=I2HSH+I3 * * --- IS THE SHELL I1 OCCUPIED IN JA * DO 2 J=1,IA IF(I1-NOCORB(J,JA)) 2,3,2 2 CONTINUE NA=1 GO TO 4 3 NA=2 J1=J * * --- IS THE SHELL I1 OCCUPIED IN JB * 4 DO 5 J=1,IB IF(I1-NOCORB(J,JB)) 5,6,5 5 CONTINUE NB=1 GO TO 7 6 NB=2 J2=J * * IF THE SHELL I1 IS NOT OCCUPIED IN EITHER JA OR JB, IGNORE THE * SHELL, DO NOT INCREASE IHSH, AND CONSIDER NEXT SHELL BY INCREASING * I1 * 7 IF(NA-1) 8,8,9 8 IF(NB-1) 1,1,9 * * --- IF THE SHELL I1 IS OCCUPIED IN EITHER JA OR JB - * (1) IF IHSH.GT.1, THEN ALREADY AT LEAST TWO SHELLS AND THE * RESULTING COUPLINGS HAVE BEEN STORED. WE MUST THUS MAKE ROOM FOR * THE QUANTUM NUMBERS OF THIS NEW SHELL BETWEEN THE QUANTUM NUMBERS * OF THE PREVIOUS SHELLS AND THE QUANTUM NUMBERS OF THE INTERMEDIATE * COUPLINGS OF THE CONFIGURATIONS. THUS THE LATTER SET ARE =MOVED * ALONG= TO MAKE ROOM FOR THE NEW SHELL * (2) IF IHSH.LE.1, THERE ARE NO INTERMEDIATE COUPLING QUANTUM * NUMBERS, AND SO THERE IS NOTHING TO MOVE * 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 * * --- FIRST CONSIDER THE L.H.S. (I=1) OF THE MATRIX ELEMENT. NC=1 MEANS * UNOCCUPIED, REPRESENTED BY A DUMMY SINGLET S SHELL, AND THE * ADDITIONAL SET OF COUPLING QUANTUM NUMBERS WILL BE THE SAME AS THE * LAST SET OF COUPLING QUANTUM NUMBERS ALREADY OBTAINED. * NC=2 MEANS OCCUPIED. THEN ALL THE NEW QUANTUM NUMBERS (BOTH FOR * THE SHELL AND FOR THE COUPLING OF THIS SHELL TO THE RESULTANT OF * THE PREVIOUS ONES) ARE DEFINED IN THE CORRESPONDING J1QNRD ARRAY. * NOSH - THE NUMBER OF ELECTRONS IN THIS SHELL, IS DEFINED BY THE * APPROPRIATE ENTRY IN NELCSH . THE R.H.S. IS THEN CONSIDERED * SIMILARLY (I=2) * 25 GO TO (15,16),NC 15 NOSH(IHSH,I)=0 J1QN(IHSH,1,I)=0 J1QN(IHSH,2,I)=1 J1QN(IHSH,3,I)=1 IF(IHSH-2) 22,18,19 18 J1QN(3,1,I)=0 J1QN(3,2,I)=J1QN(1,2,I) J1QN(3,3,I)=J1QN(1,3,I) GO TO 22 19 DO 27 K=1,3 J1QN(I2HSH,K,I)=J1QN(I2HSH-1,K,I) 27 CONTINUE GO TO 22 16 NOSH(IHSH,I)=NELCSH(IC,JC) JD = J1QNRD(IC,JC) J1QN(IHSH,1,I)=MOD(JD,64) JD = JD/64 J1QN(IHSH,2,I) = MOD(JD,64) J1QN(IHSH,3,I) = JD/64 * * IS THIS THE FIRST OCCUPIED SHELL OF EITHER CONFIGURATION. IF SO, * THEN THERE ARE NO INTERMEDIATE COUPLINGS TO CONSIDER AT THIS STAGE * IF(IHSH .GT. 1) THEN * * IS THIS THE FIRST OCCUPIED SHELL OF THIS CONFIGURATION, THOUGH NOT * THE FIRST OF THE OTHER CONFIGURATION. IF SO, THE INTERMEDIATE * COUPLING FORMED HAS THE SAME L,S VALUES AS THIS OCCUPIED SHELL, * SINCE WE COUPLE THE SHELL TO A DUMMY SINGLET S. * IF(IC .LE.1) THEN I2 = 1 ELSE I2 = NOCCSH(JC)+IC-1 END IF JD = J1QNRD(I2,JC) IF (IC .LE. 1) THEN J1QN(I2HSH,1,I) = 0 ELSE J1QN(I2HSH,1,I) = MOD(JD,64) END IF JD = JD/64 J1QN(I2HSH,2,I) = MOD(JD, 64) J1QN(I2HSH,3,I) = JD/64 END IF * * SENIORITY SET (ARBITRARILY) ZERO FOR INTERMEDIATE COUPLING * 22 IF(I-2) 23,24,24 23 NC=NB I=2 IC=J2 JC=JB GO TO 25 * * --- SET THE NJ AND LJ VALUES OF THE OCCUPIED SHELLS * 24 NJ(IHSH)=NJCOMP(I1) LJ(IHSH)=LJCOMP(I1) IJFUL(IHSH)=I1 * * --- RETURN TO 1 TO SEE IF MAXORB HAS BEEN REACHED * GO TO 1 100 RETURN END * * ------------------------------------------------------------------ * S K L I M * ------------------------------------------------------------------ * SUBROUTINE SKLIM(LET) * * * --- DETERMINES RANGES OF K FOR DIRECT AND EXCHANGE INTEGRALS FOR * THE SPIN-SPIN INTERACTION * * COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 * LET=1 LA=2 CALL KLIM(LRHO,LRHOP,LSIG,LSIGP,LA,K1,K2) KDS1=K1+1 KDS2=K2+1 CALL KLIM(LSIG,LSIGP,LRHO,LRHOP,LA,K1,K2) KDS3=K1+1 KDS4=K2+1 CALL KLIM(LRHO,LSIGP,LSIG,LRHOP,LA,K1,K2) KES1=K1+1 KES2=K2+1 CALL KLIM(LSIG,LRHOP,LRHO,LSIGP,LA,K1,K2) KES3=K1+1 KES4=K2+1 IF(KDS1.GT.KDS2.AND.KDS3.GT.KDS4.AND.KES1.GT.KES2.AND.KES3.GT. : KES4) LET=0 RETURN END * * ------------------------------------------------------------------ * S O O P A R * ------------------------------------------------------------------ * SUBROUTINE SOOPAR(XMULT1) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/DENKVK/D00N2(12),D00NK(12),D00VK(12),D11N2(12),D11NK(12), : D11VK(12),E01N2(12),E01NK(12),E01VK(12),E10N2(12),E10NK(12), : E10VK(12) COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/RMEPRD/RMEDIR(15),RMEEX(15) COMMON/SOORME/RMEDR0(12,3),RMEDR1(12,3),RMEEX0(12,3),RMEEX1(12,3) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * * * --- EVALUATE THE COEFFICIENTS FOR THE SPIN-OTHER-ORBIT INTERACTION * * * * --- ZEROIZE THE SPIN-OTHER-ORBIT PARAMETERS * CALL SOOZER * XC=XMULT1*TWO * * --- DIRECT INTEGRAL * * * --- IF MULDSO=0 MEANS NO =DIRECT= COEFFICIENTS * IF(MULDSO-1) 2,1,1 1 L=0 DO 3 J=KD1,KD2,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT(K+1) FLOAT2=DFLOAT(K+K-1) FLOAT3=DFLOAT(K+K+1) FLOAT4=DFLOAT(K+K+3) IF(K.EQ.0) GO TO 50 AN21=FLOAT3*DSQRT(FLOAT2) 50 AN22=-FLOAT1*DSQRT(FLOAT3) ANK2=DFLOAT(K)*DSQRT(FLOAT3) ANK3=-FLOAT3*DSQRT(FLOAT4) AVK=DSQRT(K*FLOAT1*FLOAT3) IF(K) 3,6,7 7 D00N2(L)=(AN21*DMULT0(L,1)*RMEDR0(L,1)+AN22*DMULT0(L,2)*RMEDR0(L,2 :))*XC 6 D00NK(L)=(ANK2*DMULT0(L,2)*RMEDR0(L,2)+ANK3*DMULT0(L,3)*RMEDR0(L,3 :))*XC IF(K.EQ.0) GO TO 5 D00VK(L)=AVK*DMULT0(L,2)*RMEDIR(J)*XC 5 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 3 IF(K) 3,8,9 9 D11N2(L)=(AN21*DMULT1(L,1)*RMEDR1(L,1)+AN22*DMULT1(L,2)*RMEDR1(L,2 :))*XC 8 D11NK(L)=(ANK2*DMULT1(L,2)*RMEDR1(L,2)+ANK3*DMULT1(L,3)*RMEDR1(L,3 :))*XC IF(K.EQ.0) GO TO 3 D11VK(L)=AVK*DMULT1(L,2)*RMEDIR(J)*XC 3 CONTINUE * * --- EXCHANGE INTEGRAL * * * --- IF MULESO=0 MEANS NO =EXCHANGE= COEFFICIENTS * 2 IF(MULESO-1) 10,11,11 11 L=0 DO 12 J=KE1,KE2,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT(K+1) FLOAT2=DFLOAT(K+K-1) FLOAT3=DFLOAT(K+K+1) FLOAT4=DFLOAT(K+K+3) IF(K.EQ.0) GO TO 60 AN21=FLOAT3*DSQRT(FLOAT2) 60 AN22=-FLOAT1*DSQRT(FLOAT3) ANK2=DFLOAT(K)*DSQRT(FLOAT3) ANK3=-FLOAT3*DSQRT(FLOAT4) AVK=DSQRT(K*FLOAT1*FLOAT3) IF(M2.EQ.0) GO TO 14 IF(K) 12,15,16 16 E01N2(L)=(AN21*EMULT0(L,1)*RMEEX0(L,1)+AN22*EMULT0(L,2)*RMEEX0(L,2 :))*XC 15 E01NK(L)=(ANK2*EMULT0(L,2)*RMEEX0(L,2)+ANK3*EMULT0(L,3)*RMEEX0(L,3 :))*XC IF(K.EQ.0) GO TO 14 E01VK(L)=AVK*EMULT0(L,2)*RMEEX(J)*XC 14 IF(M1.EQ.0) GO TO 12 IF(K) 12,17,18 18 E10N2(L)=(AN21*EMULT1(L,1)*RMEEX1(L,1)+AN22*EMULT1(L,2)*RMEEX1(L,2 :))*XC 17 E10NK(L)=(ANK2*EMULT1(L,2)*RMEEX1(L,2)+ANK3*EMULT1(L,3)*RMEEX1(L,3 :))*XC IF(K.EQ.0) GO TO 12 E10VK(L)=AVK*EMULT1(L,2)*RMEEX(J)*XC 12 CONTINUE 10 RETURN END * * ------------------------------------------------------------------ * S O O R E D * ------------------------------------------------------------------ * SUBROUTINE SOORED * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEMULT/DMULT0(12,3),DMULT1(12,3),EMULT0(12,3),EMULT1(12,3), : MULDSO,MULESO COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/RMEPRD/RMEDIR(15),RMEEX(15) COMMON/SOORME/RMEDR0(12,3),RMEDR1(12,3),RMEEX0(12,3),RMEEX1(12,3) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * * * THIS SUBROUTINE ZEROIZES MULTIPLYING FACTORS FOR ALLOWED K-VALUES * FOR THE SPIN-OTHER-ORBIT INTERACTION. THE LOWEST KD1 AND KE1 * VALUES ARE ALWAYS ALLOWED (UNLESS THEY ARE GREATER THAN KD2 AND * KE2 RESPECTIVELY). ALLOWED K-VALUES THEN STEP UP BY 2 TO SATISFY * THE EVEN CONDITION OF THE REDUCED MATRIX ELEMENTS, WHICH ARE THEN * CALCULATED AND STORED * * * --- DIRECT INTEGRALS * IF(KD1-KD2) 1,1,2 1 L=0 DO 3 J=KD1,KD2,2 RMEP=RMEDIR(J) N=0 L=L+1 K=J-1 J2=J+2 DO 4 JJ=J,J2 N=N+1 I=JJ-2 DMULT0(L,N)=ZERO DMULT1(L,N)=ZERO RMEDR0(L,N)=ZERO RMEDR1(L,N)=ZERO IF(LRHOP.EQ.0.AND.LSIGP.EQ.0) GO TO 4 IF(I.LE.0.AND.K.EQ.0) GO TO 4 * * --- EPSILON=ZERO, EPSILONP=ZERO, /EPSILON-EPSILONP/=ZERO * IF(LRHOP.EQ.0) GO TO 5 CALL RMECLL(LRHO,LRHOP,K,I,RMECL) RMEDR0(L,N)=RMECL*RMEP 5 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 4 * * --- EPSILON=ONE, EPSILONP=ONE , /EPSILON-EPSILONP/=ZERO * IF(LSIGP.EQ.0) GO TO 4 CALL RMECLL(LSIG,LSIGP,K,I,RMECL) RMEDR1(L,N)=RMECL*RMEP 4 CONTINUE 3 CONTINUE * * --- EXCHANGE INTEGTALS * 2 IF(M1.EQ.0.AND.M2.EQ.0) RETURN L=0 IF(KE1-KE2) 6,6,7 6 DO 8 J=KE1,KE2,2 RMEP=RMEEX(J) N=0 L=L+1 K=J-1 J2=J+2 DO 9 JJ=J,J2 N=N+1 I=JJ-2 EMULT0(L,N)=ZERO EMULT1(L,N)=ZERO RMEEX0(L,N)=ZERO RMEEX1(L,N)=ZERO IF(LRHOP.EQ.0.AND.LSIGP.EQ.0) GO TO 9 IF(I.LE.0.AND.K.EQ.0) GO TO 9 IF(M2.EQ.0.OR.LSIGP.EQ.0) GO TO 10 * * --- EPSILON=ZERO, EPSILONP=ONE, /EPSILON-EPSILONP/=ONE * CALL RMECLL(LRHO,LSIGP,K,I,RMECL) RMEEX0(L,N)=RMECL*RMEP 10 IF(M1.EQ.0.OR.LRHOP.EQ.0) GO TO 9 * * --- EPSILON=ONE, EPSILONP=ZERO, /EPSILON-EPSILONP/=ONE * CALL RMECLL(LSIG,LRHOP,K,I,RMECL) RMEEX1(L,N)=RMECL*RMEP 9 CONTINUE 8 CONTINUE 7 RETURN END * * ------------------------------------------------------------------ * S O O Z E R * ------------------------------------------------------------------ * SUBROUTINE SOOZER * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DENKVK/D00N2(12),D00NK(12),D00VK(12),D11N2(12),D11NK(12), : D11VK(12),E01N2(12),E01NK(12),E01VK(12),E10N2(12),E10NK(12), : E10VK(12) COMMON/XATION/AMULT(15),BMULT(15),KD1,KD2,KE1,KE2,MULTD,MULTE * * * -- :EROIZE THE ARRAYS FOR THE SPIN-OTHER-ORBIT INTERACTION * * L=0 DO 3 J=KD1,KD2,2 L=L+1 D00N2(L)=ZERO D00NK(L)=ZERO D00VK(L)=ZERO D11N2(L)=ZERO D11NK(L)=ZERO D11VK(L)=ZERO 3 CONTINUE L=0 DO 4 J=KE1,KE2,2 L=L+1 E01N2(L)=ZERO E01NK(L)=ZERO E01VK(L)=ZERO E10N2(L)=ZERO E10NK(L)=ZERO E10VK(L)=ZERO 4 CONTINUE RETURN END * * ------------------------------------------------------------------ * S P N O R B * ------------------------------------------------------------------ * SUBROUTINE SPNORB(ICOUNT,JA,JB) * IMPLICIT REAL *8(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * DIMENSION VSHELL(20) COMMON/BLUME/ COEFN2(4),COEFNK(4),COEFVK(4) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) COMMON/SPORB/ ACMULT(NWD) COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) * 3 FORMAT(9H (CONFIG ,I3,12H/SO /CONFIG ,I3,1H),/35X,F14.8,11X, : 4HS-O(,A3,1H,,A3,1H)) 15 FORMAT(35X,F14.8,15X,4HS-O(,A3,1H,,A3,1H)) 301 FORMAT(F14.8,2HZ(,A3,I3,1H,,A3,I3,1H)) * * * --- THIS SUBROUTINE EVALUATES THE SPIN-ORBIT INTERACTION * * IZOUT = 0 ISPIN=2 KA=1 KB=1 KR=-3 IRHO=0 ISIG=0 CALL TENSOR(KA,KB,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO.EQ.0) RETURN IF(IRHO.EQ.ISIG) GO TO 2 I1=IJFUL(IRHO) I2=IJFUL(ISIG) LJR=LJ(IRHO)+1 LJS=LJ(ISIG)+1 A1=VSHELL(1) IF(LJR.NE.LJS.OR.LJR.EQ.1) RETURN ALJR=DFLOAT(LJR) A4=DSQRT(ALJR*(ALJR-ONE)*(ALJR+ALJR-ONE)*THREE/TWO) A5=A1*A4 A5=A5*TWO ACMULT(1) = A5 IF(ICOUNT-1) 5,7,7 5 IF(DABS(A5).LT.EPS) RETURN IF (IFULL.NE.0) WRITE(IWRITE,3) JA,JB,A5,IAJCMP(I1),IAJCMP(I2) * WRITE(JSC0,301) A5,IAJCMP(I1),JA,IAJCMP(I2),JB CALL SAVE(5,A5,0,0,I1,0,I2,JA,JB,0) 1 ICOUNT=1 IZOUT = 1 RETURN 7 IF(DABS(A5).LT.EPS) RETURN IF (IFULL.NE.0) WRITE(IWRITE,15) A5,IAJCMP(I1),IAJCMP(I2) * WRITE(JSC0,301) A5,IAJCMP(I1),JA,IAJCMP(I2),JB CALL SAVE(5,A5,0,0,I1,0,I2,JA,JB,0) IZOUT = 1 RETURN 2 DO 6 K=1,IHSH A1=VSHELL(K) I1=IJFUL(K) LJR=LJ(K)+1 IF(LJR.EQ.1) GO TO 6 ALJR=DFLOAT(LJR) A4=DSQRT(ALJR*(ALJR-ONE)*(ALJR+ALJR-ONE)*THREE/TWO) A5=A1*A4 A5=A5*TWO ACMULT(I1) = A5 IF(ICOUNT-1) 8,9,9 8 IF(DABS(A5).LT.EPS) GO TO 6 IF (IFULL.NE.0) WRITE(IWRITE,3) JA,JB,A5,IAJCMP(I1),IAJCMP(I1) * WRITE(JSC0,301) A5,IAJCMP(I1),JA,IAJCMP(I1),JB CALL SAVE(5,A5,0,0,I1,0,I1,JA,JB,0) ICOUNT = 1 IZOUT = 1 GO TO 6 9 IF(DABS(A5).LT.EPS) GO TO 6 IF (IFULL.NE.0) WRITE(IWRITE,15) A5,IAJCMP(I1),IAJCMP(I1) * WRITE(JSC0,301) A5,IAJCMP(I1),JA,IAJCMP(I1),JB CALL SAVE(5,A5,0,0,I1,0,I1,JA,JB,0) IZOUT = 1 6 CONTINUE RETURN END * * ------------------------------------------------------------------ * S S P A R * ------------------------------------------------------------------ * SUBROUTINE SSPAR(XMULT1) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/IMAGNT/CONST,CONSOO,CONSS,ISPORB,ISOORB,ISPSPN, : IREL,ISTRICT,IZOUT,IELST,ITENPR COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 COMMON/SSMULT/DMULS0(12),DMULS1(12),EMULS0(12),EMULS1(12) COMMON/SSRME/DRRME0(12),DRRME1(12),EXRME0(12),EXRME1(12) * DATA FIVE/5.0D 00/ * * * --- EVALUATE THE COEFFICIENTS FOR THE SPIN-SPIN INTERACTION * * * * --- ZEROIZE THE SPIN-SPIN PARAMETERS * CALL SSZERO * XC=XMULT1*DSQRT(ONE/FIVE)*THREE * * --- DIRECT INTEGRAL * * * --- IF MULDSS=0 MEANS NO =DIRECT= COEFFICIENTS * IF(MULDSS-1) 2,1,1 1 L=0 DO 3 J=KDS1,KDS2,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT((K+K+1)*(K+K+2)*(K+K+3)*(K+K+4)*(K+K+5)) DKJ=XC*DSQRT(FLOAT1) D00SNK(L)=DKJ*DMULS0(L)*DRRME0(L) 3 CONTINUE * * --- IF MULDSP=0 MEANS NO =DIRECT= COEFFICIENTS * 2 IF(MULDSP-1) 4,5,5 5 L=0 DO 6 J=KDS3,KDS4,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT((K+K+1)*(K+K+2)*(K+K+3)*(K+K+4)*(K+K+5)) DKJ=XC*DSQRT(FLOAT1) D11SNK(L)=DKJ*DMULS1(L)*DRRME1(L) 6 CONTINUE * * --- EXCHANGE INTEGRAL * * * --- IF MULESS=0 MEANS NO =EXCHANGE= COEFFICIENTS * 4 IF(MULESS-1) 7,8,8 8 L=0 DO 9 J=KES1,KES2,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT((K+K+1)*(K+K+2)*(K+K+3)*(K+K+4)*(K+K+5)) DKJ=XC*DSQRT(FLOAT1) E01SNK(L)=DKJ*EMULS0(L)*EXRME0(L) 9 CONTINUE * * --- IF MULESP=0 MEANS NO =EXCHANGE= COEFFICIENTS * 7 IF(MULESP.EQ.0) RETURN L=0 DO 10 J=KES3,KES4,2 L=L+1 K=J-1 * * --- INCLUDE MULTIPLICATIVE FACTORS COMMON TO ALL TERMS WITHIN THE * FOUR-FOLD SUMMATION * FLOAT1=DFLOAT((K+K+1)*(K+K+2)*(K+K+3)*(K+K+4)*(K+K+5)) DKJ=XC*DSQRT(FLOAT1) E10SNK(L)=DKJ*EMULS1(L)*EXRME1(L) 10 CONTINUE RETURN END * * ------------------------------------------------------------------ * S S R E D * ------------------------------------------------------------------ * SUBROUTINE SSRED * IMPLICIT REAL *8(A-H,O-Z) * * * --- THIS SUBROUTINE ZEROIZES MULTIPLYING FACTORS FOR ALLOWED K-VALUES * FOR THE SPIN-SPIN INTERACTION. THE LOWEST KDS1, KDS3, KES1 AND * KES3 VALUES ARE ALWAYS ALLOWED (UNLESS THEY ARE GREATER THAN * KDS2, KDS4, KES2 AND KES4 RESPECTIVELY). ALLOWED K-VALUES THEN * STEP UP BY 2 TO SATISFY THE EVEN CONDITION OF THE REDUCED MATRIX * ELEMENTS WHICH ARE THEN CALCULATED AND STORED. * * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, : M16,M17,M18,M19,M20 COMMON/NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 COMMON/SSMULT/DMULS0(12),DMULS1(12),EMULS0(12),EMULS1(12) COMMON/SSRME/DRRME0(12),DRRME1(12),EXRME0(12),EXRME1(12) * * --- DIRECT INTEGRALS * * * --- EPSILON-ZERO, EPSILONP=ZERO, /EPSILON-EPSILONP/=ZERO * IF(KDS1.GT.KDS2) GO TO 1 L=0 DO 5 J=KDS1,KDS2,2 L=L+1 K=J-1 K2=K+2 DMULS0(L)=ZERO DRRME0(L)=RME(LRHO,LRHOP,K2)*RME(LSIG,LSIGP,K) 5 CONTINUE * * --- EPSILON=ONE, EPSILONP=ONE, /EPSILON-EPSILONP/=ZERO * 1 IF(KDS3.GT.KDS4) GO TO 2 IF(M1.EQ.0.OR.M2.EQ.0) GO TO 2 L=0 DO 6 J=KDS3,KDS4,2 L=L+1 K=J-1 K2=K+2 DMULS1(L)=ZERO DRRME1(L)=RME(LSIG,LSIGP,K2)*RME(LRHO,LRHOP,K) 6 CONTINUE * * --- EXCHANGE INTEGRALS * 2 IF(M1.EQ.0.AND.M2.EQ.0) RETURN * * --- EPSILON=ZERO, EPSILONP=ONE, /EPSILON-EPSILONP/=ONE * IF(KES1.GT.KES2.OR.M2.EQ.0) GO TO 3 L=0 DO 7 J=KES1,KES2,2 L=L+1 K=J-1 K2=K+2 EMULS0(L)=ZERO EXRME0(L)=RME(LRHO,LSIGP,K2)*RME(LRHOP,LSIG,K) 7 CONTINUE * * --- EPSILON=ONE, EPSILONP=ZERO, /EPSILON-EPSILONP/=ONE * 3 IF(KES3.GT.KES4.OR.M1.EQ.0) RETURN L=0 DO 8 J=KES3,KES4,2 L=L+1 K=J-1 K2=K+2 EMULS1(L)=ZERO EXRME1(L)=RME(LSIG,LRHOP,K2)*RME(LRHO,LSIGP,K) 8 CONTINUE RETURN END * * ------------------------------------------------------------------ * S S Z E R O * ------------------------------------------------------------------ * SUBROUTINE SSZERO * IMPLICIT REAL *8(A-H,O-Z) * COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DESSNK/D00SNK(12),D11SNK(12),E01SNK(12),E10SNK(12), : MULDSS,MULDSP,MULESS,MULESP COMMON/SSKLIM/KDS1,KDS2,KDS3,KDS4,KES1,KES2,KES3,KES4 * * * --- ZEROIZE THE ARRAYS FOR THE SPIN-SPIN INTERACTION * * L=0 DO 1 I=KDS1,KDS2,2 L=L+1 D00SNK(I)=ZERO 1 CONTINUE L=0 DO 2 I=KDS3,KDS4,2 L=L+1 D11SNK(I)=ZERO 2 CONTINUE L=0 DO 3 I=KES1,KES2,2 L=L+1 E01SNK(I)=ZERO 3 CONTINUE L=0 DO 4 I=KES3,KES4,2 L=L+1 E10SNK(I)=ZERO 4 CONTINUE RETURN END * * * ------------------------------------------------------------------ * U S E E A V * ------------------------------------------------------------------ * SUBROUTINE USEEAV(IRHO,ISIG) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NCD=100,NCD2=2*NCD) * COMMON/DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL COMMON/DIAGNL/IDIAG,JA,JB COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8) COMMON/STATES/NCFG,NOCCSH(NCD2),NOCORB( 5,NCD2),NELCSH( 5,NCD2), : J1QNRD( 9,NCD2),MAXORB,NJCOMP(NWD),LJCOMP(NWD),IAJCMP(NWD) COMMON/ENAV/NINTS,KVALUE(15),COEFCT(15) COMMON/MEDEFN/IHSH,NJ(10),LJ(10),NOSH1(10),NOSH2(10),J1QN1(19,3), : J1QN2(19,3),IJFUL(10) 6 FORMAT(35X,F14.8,11X,1HF,I2,1H(,A3,1H,,A3,1H)) 10 FORMAT(//23H INTERACTING SHELLS ARE,6X,6H RHO =,A3,6X,6H SIG =,A3, :6X,7H RHOP =,A3,6X,7H SIGP =,A3//) 11 FORMAT(35X,F14.8,11X,1HG,I2,1H(,A3,1H,,A3,1H)) 100 FORMAT(F14.8,1HF,I2,1H(,A3,I3,1H,,A3,I3,1H)) 101 FORMAT(F14.8,1HG,I2,1H(,A3,I3,1H,,A3,I3,1H)) 102 FORMAT(' (CONFIG ',I3,'/Rij/CONFIG ',I3,')') * * DETERMINE THE INTERACTION ENERGY * IF (IFULL .NE. 0) WRITE(IWRITE,102) JA,JB JRHO=IJFUL(IRHO) JSIG=IJFUL(ISIG) N1=NOSH1(IRHO) N2=NOSH2(ISIG) M1=ISIG-IRHO IZERO=0 ZERO=0.D0 IF(M1.EQ.0) GO TO 1 IEQUIV=2 AC2=DFLOAT(N1*N2) GO TO 2 1 IEQUIV=1 AC2=DFLOAT(N1*(N1-1)/2) 2 LA=LJ(IRHO) LB=LJ(ISIG) CALL INTACT(LA,LB,IEQUIV) IF(IBUG2-1) 4,7,7 * * PRINT OUT RESULTS AS IN SUBROUTINE PRNTWT * 7 IF (IFULL.NE.0) WRITE(IWRITE,10) IAJCMP(JRHO),IAJCMP(JSIG), : IAJCMP(JRHO),IAJCMP(JSIG) 4 CONTINUE IF (IFULL.NE.0) : WRITE(IWRITE,6)AC2,IZERO,IAJCMP(JRHO),IAJCMP(JSIG) * WRITE(IOUT,100) AC2,IZERO,IAJCMP(JRHO),JA,IAJCMP(JSIG),JB CALL SAVE(1,AC2,IZERO,0,JRHO,0,JSIG,JA,JB,0) IF(NINTS.EQ.0) RETURN DO 8 N=1,NINTS ZA=AC2*COEFCT(N) K=KVALUE(N) IF(IEQUIV.EQ.1) GO TO 9 IF (IFULL.NE.0) : WRITE(IWRITE,11) ZA,K,IAJCMP(JRHO),IAJCMP(JSIG) * WRITE(ISC1,101) ZA,K,IAJCMP(JRHO),JA,IAJCMP(JSIG),JB CALL SAVE(2,ZA,K,0,JRHO,0,JSIG,JA,JB,0) GO TO 8 9 IF (IFULL .NE. 0)WRITE(IWRITE,6) ZA,K,IAJCMP(JRHO),IAJCMP(JSIG) * WRITE(IOUT,100) ZA,K,IAJCMP(JRHO),JA,IAJCMP(JSIG),JB CALL SAVE(1,ZA,K,0,JRHO,0,JSIG,JA,JB,0) 8 CONTINUE RETURN END SH2(10),J1QN1(19,3), : J1QN2(19,3)atsp/src/CI.f010064400002010000036000000573030623623513000126520ustar00cffcsf00000400000020* ------------------------------------------------------------------ * PROGRAM CI * * C O P Y R I G H T -- 1994 * * by C. Froese Fischer * Vanderbilt University * Nashville, TN 37235 USA * * May, 1983 * * Computer Physics Communications, Vol. 64, 473--485 (1991). * ------------------------------------------------------------------ * * A CONFIGURATION INTERACTION PROGRAM EITHER NON-RELATIVISTIC * OR IN THE BREIT-PAULI APPROXIMATION * * The PARAMETER values in this program define the following: * IREAD - The unit number of standard input * IWRITE- The unit number of printed output * MD - Maximum number of eigen-pairs * NCD2 - Maximum number of configuration state functions * NOD - Maximum number of points in the range of a * - function * NTERMD- Maximum number of terms * NWD - Maximum number of functions (or electrons) * NZ - Maximum number of configuration state functions * - defining the zero-order set * * ------------------------------------------------------------------ * IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS PARAMETER (IREAD=5,IWRITE=6) CHARACTER*1 PP, NAME(5)*24 LOGICAL PRINT, LS , REL * WRITE(6,9999) 9999 FORMAT(/20X,'==========================='/ : 20X,' CONFIGURATION INTERACTION '/ : 20X,'==========================='/) CSUN i = iargc() 999 NAME(2) = 'int.lst' CSUN if (i .eq. 0) then WRITE(0,*) ' Name of State' read(5,'(A)') NAME(1) CSUN else CSUN call getarg(1,NAME) CSUN if (i .eq. 2) call getarg(2,NAME(2)) CSUN end if j = index(NAME(1),' ') if (j .eq. 1) then WRITE(0,*) ' Names may not start with a blank' go to 999 else NAME(1) = NAME(1)(1:j-1)//'.c' NAME(3) = NAME(1)(1:j-1)//'.w' NAME(4) = NAME(1)(1:j-1)//'.l' NAME(5) = NAME(1)(1:j-1)//'.j' end if * CALL INITA CALL INITR REL = .TRUE. WRITE(0,*) ' Is this a relativistic calculation ? (Y/N) : ' READ(IREAD,'(A1)') PP IF (PP.EQ.'N' .OR. PP.EQ.'n') REL = .FALSE. WRITE(0,*) ' Is mass-polarization to be included ? (Y/N) : ' READ(IREAD,'(A1)') PP MASS = 0 IF (PP.EQ.'Y' .OR. PP.EQ.'y') THEN WRITE(0,*) ' Gradient or Slater integral form ? (G/S) : ' READ(IREAD,'(A1)') PP MASS = 1 IF (PP.EQ.'S' .OR. PP.EQ.'s') MASS = 2 END IF * OPEN(UNIT=1,FILE=NAME(1),STATUS='OLD') OPEN(UNIT=2,FILE=NAME(2),STATUS='OLD') OPEN(UNIT=4,FILE=NAME(3),STATUS='OLD',FORM='UNFORMATTED') OPEN(UNIT=7,FILE=NAME(4),STATUS='UNKNOWN') IF (REL) THEN OPEN(UNIT=8,FILE=NAME(5),STATUS='UNKNOWN') OPEN(UNIT=3,STATUS='SCRATCH',FORM='UNFORMATTED') END IF OPEN(UNIT=9,STATUS='SCRATCH',FORM='UNFORMATTED') * CALL EVAL(N,REL,NZERO) LS = .TRUE. PRINT = .FALSE. CALL LSJMAT(N, NZERO, 0, PRINT, LS) IF ( .NOT. REL) GO TO 99 * * ***** DETERMINE DATA ABOUT THE CASE * WRITE(0,*) ' Maximum and minimum values of 2*J ? ' READ( IREAD,*) MAXJ,MINJ WRITE(0,*) ' Do you want the matrix printed? (Y or N) ' READ (IREAD,'(A)') PP IF (PP .EQ. 'Y' .OR. PP .EQ. 'y') THEN PRINT = .TRUE. ELSE PRINT = .FALSE. END IF LS = .FALSE. * * ***** PERFORM CALCULATION FOR EACH J VALUE * DO 1 J = MAXJ, MINJ, -2 CALL LSJMAT(N, NZERO, J, PRINT, LS) 1 CONTINUE 99 IF (REL) THEN CLOSE(UNIT=3) WRITE(8,'(A)') '***' END IF WRITE(7,'(A)') '***' CLOSE(UNIT=7) CLOSE(UNIT=8) CLOSE(UNIT=9) END * * ----------------------------------------------------------------- * E V A L * ----------------------------------------------------------------- * Read the configuration state list and radial functions. Call * MATRIX to read the non-relativistic portion of the int.lst, then * read the fine-structure integrals, evaluating the integrals and * storing the coefficient data. * * SUBROUTINE EVAL(NC,REL,NZERO) * PARAMETER(IREAD=5,IWRITE=6) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER(NOD=220,NWD=30,NCD2=200,MD=20,NZ=200,NTERMD=10, : IDIM2=1000) LOGICAL REL, PRINT/.false./ CHARACTER CONFIG*66,EL*3,ATOM*6,END*1,TT*6,HEADER*72,CLSDEL*72 CHARACTER*3 EL1, EL2, EL3, EL4, COUPLE(9), ELC(5), ANS*1 INTEGER S, IQ(5) COMMON /INTGRL/VALUE(IDIM2),LL(NCD2),S(NCD2),LENGTH(NCD2),EC, : ICPTR(IDIM2),IOV(2),OVALUE(20),LSP(NCD2),INDEX(NTERMD),NTERM COMMON /LABEL/CONFIG(NCD2),EL(NWD) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD), : YR(NOD),X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * * ***** READ THE CONFIGURATIONS * I = 1 READ(1,'(A/A)' ) HEADER,CLSDEL 1 READ(1,'(5(1X,A3,1X,I2,1X))', END= 2) (ELC(K),IQ(K),K=1,5) NOCC = 0 8 IF (ELC(NOCC+1) .NE. ' ') THEN NOCC = NOCC + 1 IF (NOCC .LT. 5) GO TO 8 END IF IF (NOCC .EQ. 0) GO TO 2 IF (I .GT. NCD2) THEN WRITE(0,*) ' Too many configurations: Max = ',NCD2 STOP 1 END IF NEL = IQ(1)+IQ(2)+IQ(3)+IQ(4)+IQ(5) READ(1,'(9(5X,A3))') (COUPLE(J),J=1,9) CALL PACK(NOCC,ELC,IQ,COUPLE,CONFIG(I)) K = 66 9 IF (CONFIG(I)(K:K) .EQ. ' ') THEN K = K-1 GO TO 9 END IF LENGTH(I) = K LAST = 2*NOCC - 1 LL(I) = 2*LVAL(COUPLE(LAST)(2:2)) S(I) = ICHAR(COUPLE(LAST)(1:1)) - ICHAR('1') I = I + 1 GO TO 1 2 NC = I - 1 NZERO = MIN0(NC,(NZ)) * * ***** Determine the list of TERMS * DO 14 I = 1,NC LSP(I) = 0 14 CONTINUE NTERM = 0 DO 15 I = 1,NC IF (LSP(I) .EQ. 0) THEN NTERM = NTERM + 1 LSP(I) = NTERM INDEX(NTERM) = I DO 16 J = I+1,NC IF (LSP(J) .EQ. 0 .AND. : LL(I).EQ.LL(J) .AND. S(I).EQ.S(J)) LSP(J) = NTERM 16 CONTINUE END IF 15 CONTINUE IF (NTERM .GT. NTERMD) THEN WRITE(0,'(/A,I3/A,I3)') ' The number of terms is ', NTERM, : ' The maximum allowed in current dimensions is ', NTERMD STOP 1 END IF * * WRITE(0,'(/A,A,I4)' * : ' The zero-order calculation will diagonalize', * : ' a matrix of order ', NZERO * WRITE(0,*) ' Enter a new value IF you wish to reduce NZERO: ' * READ(IREAD,*) NEW * IF (NEW .NE. 0) NZERO = NEW * * ***** READ THE RADIAL FUNCTIONS * I = 1 NCLOSD = 18 12 READ(4,END=13) ATOM,TT,EL(I),M,Z,ETI,EKI,AZ(I),(P(J,I),J=1,M) 7 FORMAT(24X,8X,A3,I6,F6.0/40X,D14.7/(5D14.7)) IF (I.GT.NWD) THEN WRITE(0,*) 'Too many functions: MAX = ',NWD STOP END IF IF (I .LE. NCLOSD) THEN II = 4*(I-1)+2 EL1 = CLSDEL(II:II+2) IF (EL1 .NE. ' ' .AND. EL(I) .NE. EL1) THEN STOP 'Radial functions do match list of closed shells' ELSE IF (EL1 .EQ. EL(I)) THEN J = 3 IF (EL1(1:1) .NE. ' ') J = 2 NEL = 4*LVAL(EL1(J:J)) + 2 + NEL ELSE IF (EL1 .EQ. ' ') THEN NCLOSD = I-1 END IF END IF IF (EL(I)(1:1) .NE. ' ') THEN N(I) = ICHAR(EL(I)(1:1)) - ICHAR('1') + 1 L(I) = LVAL(EL(I)(2:2)) ELSE N(I) = ICHAR(EL(I)(2:2)) - ICHAR('1') + 1 L(I) = LVAL(EL(I)(3:3)) ENDIF MM = M+1 DO 24 J = MM,NO 24 P(J,I) = D0 MAX(I)=M I = I+1 GO TO 12 13 NWF = I-1 * * ***** SET UP DATA FOR AN INTERACTION CALCULATION * WRITE (6,3) ATOM,Z 3 FORMAT(//3X,'ATOM = ',A6,3X,'Z = ',F3.0/) IF (REL) :WRITE (8,'(2X,A6,A,F5.1,A,I3,A,I3)' ) ATOM,' Z = ',Z ,' N = ', : NEL, ' NCFG = ',NC WRITE (7,'(2X,A6,A,F5.1,A,I3,A,I3)' ) ATOM,' Z = ',Z ,' N = ', : NEL, ' NCFG = ',NC DO 4 J=1,NO R(J)=DEXP(RHO)/Z RR(J)=R(J)*R(J) R2(J)=DSQRT(R(J)) 4 RHO=RHO+H * IF (MASS .GT. 0) THEN WRITE(0,*) ' Default Rydberg constant (Y or N) ? ' READ(IREAD,'(A1)') ANS IF ( ANS .EQ. 'Y' .OR. ANS .EQ. 'y' ) THEN IF ( Z .EQ. 1.) THEN ZMU = 1. ELSE IF ( Z .GT. 10.) THEN ZMU = 2*Z+1 + (Z-11)/2 ELSE IF ( MOD(INT(Z),2) .EQ. 0 .OR. Z .EQ. 7. ) THEN ZMU = 2*Z ELSE ZMU = 2*Z+1 END IF ELSE WRITE(0,*) ' Enter the mass of the atom' READ(IREAD,*) ZMU END IF RMASS = 548.579903E-6/ZMU END IF * * ***** COMPUTE ENERGY OF THE CORE * CALL ECORE(EL,EC,REL) CALL MATRIX(NC, REL, MASS, NZERO, PRINT) IF (.NOT. REL) RETURN * I = 1 50 FORMAT(1X,A1,I2,1X,2A3,1X,2A3,1X,I5) 60 FORMAT(1X,A1,3X,A3,1X,A3,1X,I5) * * ***** READ Z INTEGRALS * 71 READ(2,60,END=111) END, EL1, EL2, ICPTR(I) IF ( END .EQ. '*' ) GO TO 72 CALL EPTR(EL, EL1, I1, *999) CALL EPTR(EL, EL2, I2, *999) VALUE(I) = ZETA(I1,I2) I = I + 1 IF( I .LE. IDIM2) THEN GO TO 71 ELSE WRITE(0,*) : ' Too many integrals for current dimensions: MAX=',IDIM2 STOP 1 END IF 72 CALL LSJPTR * * ***** READ Nk INTEGRALS * 81 READ(2,50,END=111) END, K, EL1, EL2, EL3, EL4, ICPTR(I) IF ( END .EQ. '*' ) GO TO 82 CALL EPTR(EL, EL1, I1, *999) CALL EPTR(EL, EL2, I2, *999) CALL EPTR(EL, EL3, I3, *999) CALL EPTR(EL, EL4, I4, *999) VALUE(I) = SN(I1, I2, I3, I4, K) I = I + 1 IF (I .LE. IDIM2) THEN GO TO 81 ELSE WRITE(0,*) : ' Too many integrals for current dimensions: MAX=',IDIM2 STOP 1 END IF 82 CALL LSJPTR * * ***** READ Vk INTEGRALS * 91 READ(2,50,END=111) END, K, EL1, EL2, EL3, EL4, ICPTR(I) IF ( END .EQ. '*' ) GO TO 92 CALL EPTR(EL, EL1, I1, *999) CALL EPTR(EL, EL2, I2, *999) CALL EPTR(EL, EL3, I3, *999) CALL EPTR(EL, EL4, I4, *999) VALUE(I) = VK(I1, I2, I3, I4, K) I = I + 1 IF (I .LE. IDIM2) THEN GO TO 91 ELSE WRITE(0,*) : ' Too many integrals for current dimensions: MAX=',IDIM2 STOP 1 END IF 92 CALL LSJPTR * * ***** READ SPIN-SPIN INTEGRALS * 101 READ(2,50,END=111) END, K, EL1, EL2, EL3, EL4, ICPTR(I) IF ( END .EQ. '*' ) GO TO 102 CALL EPTR(EL, EL1, I1, *999) CALL EPTR(EL, EL2, I2, *999) CALL EPTR(EL, EL3, I3, *999) CALL EPTR(EL, EL4, I4, *999) VALUE(I) = SN(I1, I2, I3, I4, K) I = I + 1 IF (I .LE. IDIM2) THEN GO TO 101 ELSE WRITE(0,*) : ' Too many integrals for current dimensions: MAX=',IDIM2 STOP 1 END IF 102 CALL LSJPTR 111 CLOSE(UNIT=1) CLOSE(UNIT=2) CLOSE(UNIT=4) REWIND(UNIT=3) * RETURN 999 STOP END * * ------------------------------------------------------------------ * F I R S T * ------------------------------------------------------------------ * * Compute the first-order corrections to the eigenvalue and * eigenvectors. * SUBROUTINE FIRST(N, NZERO, MFOUND) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER(NOD=220,NWD=30,NCD2=200,MD=20,NZ=200) COMMON H(NCD2,NZ),RLB,RUB,HD(NCD2),W(MD),U(NCD2,MD) DIMENSION EIGVAL(MD),EIGVEC(NCD2,MD) EQUIVALENCE (W(1),EIGVAL(1)),(U(1,1),EIGVEC(1,1)) CHARACTER*3 CONFIG*66, COUPLE, END*1, EL COMMON /LABEL/CONFIG(NCD2),EL(NWD) * DO 1 I = 1,MFOUND E0 = W(I) E1 = 0.D0 U2 = 0.D0 DO 2 J = NZERO+1, N * * ... Clear the components * U(J,I) = 0.D0 2 CONTINUE DO 4 J = NZERO+1, N * * ... Compute inner product of zero-order vectors with * first-order interactions * V = 0.D0 DO 6 JJ = 1,NZERO V = V - H(J,JJ)*U(JJ,I) 6 CONTINUE U(J,I) = V/(HD(J)-E0) E1 = E1 - U(J,I)*V U2 = U2 + U(J,I)*U(J,I) 4 CONTINUE W(I) = W(I) + E1/(1.D0 +U2) SCALE = 1.D0/SQRT(1.D0+U2) DO 8 J = 1,N U(J,I) = SCALE*U(J,I) 8 CONTINUE 1 CONTINUE END * * ------------------------------------------------------------------ * L S J M A T * ------------------------------------------------------------------ * Read the non-fine structure matrix, and the fine structure * corrections (if any), for the current case, find eigenvalues and * corresponding eigenvectors. * SUBROUTINE LSJMAT(N, NZERO, JJ, PRINT ,LS) IMPLICIT DOUBLE PRECISION(A-H,O-Z) INTEGER L,S LOGICAL PRINT,LS PARAMETER(NOD=220,NWD=30,NCD2=200,MD=20,NZ=200,NTERMD=10, : IDIM2=1000) COMMON /INTGRL/VALUE(IDIM2),L(NCD2),S(NCD2),LENGTH(NCD2),EC, : ICPTR(IDIM2),IOV(2),OVALUE(20),LSP(NCD2),INDEX(NTERMD),NTERM COMMON H(NCD2,NZ),RLB,RUB,HD(NCD2),W(MD),U(NCD2,MD),V1(NZ),V2(NZ), : V3(NZ),V4(NZ),V5(NZ),V6(NZ),D(NZ),E(NZ),E2(NZ),IND(NZ) DIMENSION EIGVAL(MD),EIGVEC(NCD2,MD),FLSJ(NTERMD,NTERMD,2) EQUIVALENCE (W(1),EIGVAL(1)),(U(1,1),EIGVEC(1,1)) CHARACTER*3 CONFIG*66, END*1, EL COMMON /LABEL/CONFIG(NCD2),EL(NWD) * * ***** READ THE LS-INTERACTION MATRIX * READ (9) ((H(I,J),I=J,N),J=1,NZERO), (HD(J),J=NZERO+1,N) REWIND 9 IF (LS) GO TO 30 * * ***** INCLUDE ONLY THOSE INTERACTIONS FOR WHICH * |L - S| <= JJ <= L + S * DO 1 J = 1,N IF ( JJ .LT. ABS(L(J) - S(J)) .OR. JJ .GT. L(J) + S(J) ) THEN IF (J .LE. NZERO) THEN DO 2 I = J+1,N H(I,J) = 0. 2 CONTINUE H(J,J) = 1.D0 ELSE HD(J) = 1.D0 END IF END IF 1 CONTINUE * * ***** CLEAR TABLE OF J-DEPENDENT FACTORS * DO 3 II = 1,NTERM I = INDEX(II) DO 4 JJJ = 1,NTERM J = INDEX(JJJ) PHASE =(-1)**((L(I)+S(J)-JJ +L(I)+S(I)-JJ +L(J)+S(J)-JJ)/2) CALL GRACAH(L(J),S(J),L(I),S(I),JJ,2,W1) CALL GRACAH(L(J),S(J),L(I),S(I),JJ,4,W2) FLSJ(II,JJJ,1) = PHASE*W1 FLSJ(II,JJJ,2) = PHASE*W2 4 CONTINUE 3 CONTINUE * * ***** ADD THE LSJ CONTRIBUTIONS * C READ(3,'()' ) INT = 1 V = VALUE(INT) LAST = ICPTR(INT) DO 10 II = 1,4 IC = 1 11 READ(3) C,END,I,J * 12 FORMAT(F14.8,A1,2I3) IF ( END .EQ. '*' ) GO TO 10 IF (J .GT. NZERO .AND. .NOT.(J .EQ. N) ) THEN WRITE(0,'(A,I3,A,I3,A)') ' Data for (',I,',',J,') IGNORED!' GO TO 13 END IF IF (II .EQ. 4) THEN FACTOR = FLSJ(LSP(I),LSP(J),2) ELSE FACTOR = FLSJ(LSP(I),LSP(J),1) END IF H(I,J) = H(I,J) + C*FACTOR*V 13 IC = IC + 1 IF (IC .GT. LAST) THEN INT = INT + 1 V = VALUE(INT) LAST = ICPTR(INT) END IF GO TO 11 10 CONTINUE REWIND 3 30 IF ( .NOT. PRINT ) GO TO 32 * * ***** PRINT THE MATRIX * WRITE(6,'(//A)') ' LSJ interaction matrix' DO 70 J=1,N IF (J .LE. NZERO) THEN WRITE(6,71) (H(J,K),K=1,J) ELSE WRITE(6,71) (H(J,K),K=1,NZERO),HD(J) END IF 70 CONTINUE 71 FORMAT(/(8F16.7)) * * ***** COMPUTE THE EIGENVALUES AND EIGENVECTORS * * * NOW THAT THE INPUT MATRIX H IS READIED, WE MAY CALL THE * EISPACK ROUTINE TRED1 WHICH REDUCES H TO A SYMMETRIC * TRIDIAGONAL MATRIX USING ORTHOGONAL SIMILARITY * TRANSFORMATIONS * 32 CALL TRED1(NCD2,NZERO,H,D,E,E2) * * PREPARE TO CALL THE EISPACK ROUTINE BISECT * EPS1=-1D0 * * CALL THE EISPACK ROUTINE BISECT WHICH WILL USE THE * TRIDIAGONAL MATRIX FOUND BY TRED1 TO ZERO IN ON ALL * OF THE EIGENVALUES IN THE RANGE FROM RLB TO RUB * CALL BISECT(NZERO,EPS1,D,E,E2,RLB,RUB,MD,MFOUND,W,IND,IERR,V4,V5) IF (IERR .NE. 0 ) THEN * * PRINT OUT THE ERROR CONDITION INDICATOR SET BY BISECT * WRITE (6,400) IERR 400 FORMAT(/1H1,' IERR (FROM BISECT) =',I5) STOP END IF * * CONTINUE IF NO EIGENVALUES WERE FOUND IN THE DESIRED RANGE, * IF (MFOUND .EQ. 0) GO TO 50 WRITE (6,73) MFOUND 73 FORMAT(// I5,' EIGENVALUES FOUND ') IF (LS) THEN IU = 7 ELSE IU = 8 END IF WRITE (IU, '(//A8,I4,2X,A8,I4)' ) ' 2*J = ',JJ,'NUMBER =',MFOUND * * THE EISPACK ROUTINE TINVIT WILL NEXT BE CALLED TO FIND * THE EIGENVECTORS (OF THE TRIDIAGONAL MATRIX FOUND BY TRED1) * CORRESPONDING TO THE EIGENVALUES FOUND BY ROUTINE BISECT * CALL TINVIT(NCD2,NZERO,D,E,E2,MFOUND,W,IND,U,IERR,V1,V2,V3,V4,V6) IF ( IERR .NE. 0 ) THEN * * PRINT OUT THE ERROR CONDITION INDICATOR SET BY TINVIT * WRITE(6,460)IERR 460 FORMAT('-',' IERR (FROM TINVIT) =',I5) STOP END IF * * THE EIGENVECTORS FOUND BY TINVIT WILL NOW BE BACKTRANSFORMED * BY THE EISPACK ROUTINE TRBAK1 TO FORM THE DESIRED EIGENVECTORS * OF THE ORIGINAL INPUT MATRIX H, USING THE INFORMATION ABOUT THE * ORTHOGONAL TRANSFORMATIONS USED IN REDUCING H TO TRIDIAGONAL * FORM (THE LOWER PART OF H NOW CONTAINS THIS INFORMATION) * CALL TRBAK1(NCD2,NZERO,H,E,MFOUND,U) * * ***** COMPUTE FIRST-ORDER CORRECTIONS * IF (NZERO .LT. N) CALL FIRST(N,NZERO,MFOUND) * * ***** PRINT OUT THE EIGENVALUES AND EIGENVECTORS * DO 40 K = 1,MFOUND * * ***** SEARCH FOR THE LARGEST COMPONENT IN THE EIGENVECTOR FOR * LABELLING PURPOSES * VMAX = 0.D0 JMAX = 0 DO 90 J = 1,N ABSEIG = DABS(EIGVEC(J,K)) IF ( ABSEIG .LT. VMAX ) GO TO 90 JMAX = J VMAX = ABSEIG 90 CONTINUE IF (EIGVEC(JMAX,K) .LT. 0.D0 ) THEN DO 91 J = 1,N EIGVEC(J,K) = - EIGVEC(J,K) 91 CONTINUE END IF WRITE (IU,204) JMAX, EIGVAL(K), CONFIG(JMAX)(1:LENGTH(JMAX)) 204 FORMAT(/I6,F16.8,2X,A) WRITE (IU,'(7F10.7)') (EIGVEC(J,K),J=1,N) 40 WRITE(6,41) EIGVAL(K),CONFIG(JMAX)(1:LENGTH(JMAX)), : (EIGVEC(J,K),J=1,N) 41 FORMAT(/1X,F14.8,2X,A/(1X,7F10.6)) RETURN 50 WRITE (6,51) RLB,RUB,JJ 51 FORMAT(1X,'NO EIGENVALUES FOUND IN (',F14.7,',',F14.7, : ') FOR J = ',I3) RETURN END * *----------------------------------------------------------------------- * L S J P T R *----------------------------------------------------------------------- * Read the J-dependent data and write onto a scratch file * SUBROUTINE LSJPTR CHARACTER*1 END DOUBLE PRECISION C * 1 READ(2,12) C, END, I, J 12 FORMAT(F14.8,A1,2I3) WRITE(3) C, END, I, J IF (END .NE. '*') GO TO 1 END * *----------------------------------------------------------------------- * M A T R I X *----------------------------------------------------------------------- * This subroutine computes and stores on disk the LS interaction * matrix. * SUBROUTINE MATRIX(N, REL, MASS, NZERO, PRINT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (IREAD=5,IWRITE=6) LOGICAL REL, PRINT CHARACTER CONFIG*66,EL*3,END*1 CHARACTER*3 EL1, EL2, EL3, EL4 INTEGER S PARAMETER(NOD=220,NWD=30,NCD2=200,MD=20,NZ=200,NTERMD=10, : IDIM2=1000) COMMON /INTGRL/VALUE(IDIM2),LL(NCD2),S(NCD2),LENGTH(NCD2),EC, : ICPTR(IDIM2),IOV(2),OVALUE(20),LSP(NCD2),INDEX(NTERMD),NTERM COMMON /LABEL/CONFIG(NCD2),EL(NWD) COMMON H(NCD2,NZ),RLB,RUB,HD(NCD2),DIAG(NZ) * 1 FORMAT(1X,A1,I2,1X,A3,1X,A3,1X,I5) 2 FORMAT(1X,A1,I2,1X,2A3,1X,2A3,1X,I5) 3 FORMAT(1X,A1,I2,1X,A3,1X,A3,2X,I2,1X,A3,1X,A3,I5) 4 FORMAT(F14.8,A1,3I3) * * ***** INITIALIZE THE INTERACTION MATRIX TO ZERO * DO 5 J=1,N IF (J .LE. NZERO) THEN DO 6 I = 1,N H(I,J) = 0. 6 CONTINUE H(J,J) = EC ELSE HD(J) = EC END IF 5 CONTINUE C C ***** READ AND ADD THE LIST OF INTEGRALS C READ(2,'()') DO 10 INT = 1,6 I = 1 IF (INT.NE.4 .AND. INT.NE.5) THEN * * ...F, G, L, or O1 integrals.... * 12 READ(2,1) END, KVAL, EL1, EL2, ICPTR(I) IF (END .EQ. '*') GO TO 16 CALL EPTR( EL, EL1,IEL1,*999) CALL EPTR( EL, EL2,IEL2,*999) IF (INT .EQ. 1) THEN VALUE(I) = FK(IEL1,IEL2,KVAL,REL) ELSE IF (INT .EQ. 2) THEN VALUE(I) = GK(IEL1,IEL2,KVAL,REL) ELSE IF (INT .EQ. 3) THEN OVALUE(I) = QUADR(IEL1,IEL2,0)**KVAL ELSE VALUE(I) = HLC(EL, IEL1, IEL2, REL) END IF I = I + 1 IF (INT .NE. 3) THEN IF (I .LE. (IDIM2) ) GO TO 12 WRITE(0,*) ' Too many integrals - MAX = ',(IDIM2) ELSE IF (I .LE. (20) ) GO TO 12 WRITE(0,*) ' Too many overlap integrals - MAX = ',(20) END IF ELSE 14 IF (INT.EQ.5) THEN * * ... R integrals ... * READ(2,2) END, KVAL, EL1, EL2, EL3, EL4, ICPTR(I) * ELSE * * ... O2 integrals ... * READ(2, 3) END, K1, EL1, EL2, K2, EL3, EL4 END IF * IF ( END .EQ. '*') GO TO 16 CALL EPTR( EL, EL1, IEL1, *999) CALL EPTR( EL, EL2, IEL2, *999) CALL EPTR( EL, EL3, IEL3, *999) CALL EPTR( EL, EL4, IEL4, *999) IF (INT .EQ. 5) THEN VALUE(I) = RK( IEL1, IEL2, IEL3, IEL4, KVAL, REL) ELSE OVALUE(I+IOV(1)) : = QUADR(IEL1,IEL2,0)**K1*QUADR(IEL3,IEL4,0)**K2 END IF I = I + 1 IF (INT .NE. 3) THEN IF (I .LE. (IDIM2) ) GO TO 14 WRITE(0,*) ' Too many integrals - MAX = ',IDIM2 STOP 1 ELSE IF (I .LE. (20) ) GO TO 14 WRITE(0,*) ' Too many overlap integrals - MAX = ',(20) STOP 1 END IF END IF 16 IF (INT .EQ. 3 .OR. INT .EQ. 4) THEN IOV(INT-2) = I-1 GO TO 10 END IF * * ... Read the data ... * I = 1 IC = 1 20 READ(2,4) COEFF, END, IH, JH, IOVPTR IF ( END .NE. '*') THEN IF (IOVPTR .LT. 0) IOVPTR = IOV(1) - IOVPTR C = COEFF*VALUE(I) IF (IOVPTR .NE. 0) C = C*OVALUE(IOVPTR) IF (JH .LE. NZERO) THEN H(IH,JH) = H(IH,JH) + C ELSE IF(IH .EQ. JH) HD(JH) = HD(JH) + C END IF IC = IC + 1 IF (IC .GT. ICPTR(I)) I = I+1 GO TO 20 END IF 10 CONTINUE * * ***** WRITE THE LS MATRIX ONTO SCRATCH DISK * WRITE (9) ((H(I,J),I=J,N),J=1,NZERO), (HD(J),J=NZERO+1,N) ENDFILE 9 REWIND 9 IF (.NOT. PRINT) GO TO 32 * * ***** PRINT THE LS MATRIX * WRITE (6,'(//A)') ' LS interaction matrix' DO 30 I = 1,N IF (I .LE. NZERO ) THEN WRITE(6,'(/(8F16.7))') (H(I,J),J=1,I) ELSE WRITE(6,'(/(8F16.7))') (H(I,J),J=1,NZERO),HD(I) END IF 30 CONTINUE 32 WRITE(0,'(/A,I5/A)') 'The size of the matrix is ', N, : ' Enter the approximate number of eigenvalues required ' READ( IREAD, *) MEIV IF (MEIV .GT. (MD)) THEN WRITE(0,*)' Maximum for current dimensions is',MD,' :Re-enter' GO TO 32 END IF * * ***** DETERMINE THE APPROXIMATE RANGE OF THE MEIV LOWEST * EIGENVALUES * DO 33 I = 1,NZERO DIAG(I) = H(I,I) 33 CONTINUE NUMBER = 0 DO 34 I = 1,MIN(MEIV+1,NZERO) DL = DIAG(I) K = I DO 35 J = I+1,NZERO IF (DIAG(J) .LT. DL) THEN DL = DIAG(J) K = J END IF 35 CONTINUE DIAG(K) = DIAG(I) DIAG(I) = DL IF (DL .NE. 1.D0) NUMBER = NUMBER + 1 34 CONTINUE IF (NUMBER .EQ. 0) STOP ' ERROR IN MATRIX' RLB = 1.5*DIAG(1) IF (MEIV .LT. NUMBER) THEN RUB = 0.5*(DIAG(MEIV) + DIAG(MEIV+1)) ELSE RUB = 2*DIAG(NUMBER)/3 END IF RETURN * 999 WRITE(0,*) ' Electron in ',END,'-data not found in ', : 'configuration data' STOP END 2 CONTINUE H(J,J) = 1.D0 ELSE HD(J) = 1.D0 END IF END IF 1 CONTINUE * * ***** CLEAR TABLE OF J-DEPENDENT FACTORS * DO 3 II = 1,NTERM I = INDEX(II) DO 4 JJJ = 1,NTERM J = INDEX(JJJ) PHASE =(-1)**((L(I)+S(J)-JJ +L(I)+S(I)-JJ +L(J)+S(J)-JJ)/2) atsp/src/CMCHF.f010064400002010000036000003570110631202501300131660ustar00cffcsf00000400000020* ------------------------------------------------------------------ * CONTINUUM PROGRAM * * Written by : Charlotte Froese Fischer * Department of Computer Science * Vanderbilt University * * 1987 Version, Updated October 1993. * * Modified by: Jinhua Xi, December 1994 * for use of WKB method for normalization * ------------------------------------------------------------------ * * All comments in the program listing assume the radial function P * is the solution of an equation of the form * * P" + ( 2Z/R - Y - L(L+1)/R**2 - E)P = X + T * * where Y is called a potential function * X is called an exchange function, and * T includes contributions from off-diagonal energy parameter, * interactions between configurations, etc. * * The program uses LOG(Z*R) as independent variable and * P/SQRT(R) as dependent variable. * As a result all equations must be transformed as described in * Sec. 6-2 and 6-4. * * ------------------------------------------------------------------ * M A I N P R O G R A M * ------------------------------------------------------------------ * PROGRAM CMCHF IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH,IOU(7) COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL PRINT,LD CHARACTER*3 ANS*1,NAME(7)*24,ELORT(20,2) EQUIVALENCE (IUC,IOU(1)),(OUC,IOU(4)) DATA NAME/'cfg.inp','int.lst','wfn.inp','cfg.out', : ' ','wfn.out', ' '/ REAL times(2),rtime,dtime * * ***** Define unit numbers and open files ********************* * * * UNIT NUMBERS AND FILE NAMES MAY BE MACHINE * * DEPENDENT. CHECK THE FOLLOWING SECTION. * * * * IN - Standard input unit, normally the terminal * * OUT- Standard output unit, normally the terminal * * PRI- Printer output unit or file. * * * IN = 5 OUT = 6 PRI = 3 * * ***** WRITE OUT HEADER * WRITE(OUT,9) 9 FORMAT(//20X,'======================='/ : 20X,' UNIX CMCHF ... 1987'/ : 20X,'=======================') * * ***** WRITE OUT DIMENSION INFORMATION * WRITE(OUT,99) 'NCFG',NCFG,'NWF',NWD,'NO',NOD 99 FORMAT(//10X,'THE DIMENSIONS FOR THE CURRENT VERSION ARE:'/ : (10X,3(A6,'=',I3,4X)/)/) * * ***** INITIALIZE COMMON DATA ARRAYS * CALL INITA CALL INITR * * * ***** IN THE OPEN STATEMENTS CHECK FOR VALID FILE NAMES ****** * * 1 WRITE(ERR,'(//A/A//)') ' START OF CASE',' =============' DO 37 J = 1,7 IOU(J) = 0 IF (J.LE.3) THEN IF (NAME(J) .NE. ' ') THEN IF (J.NE. 3) THEN IOU(J) = 20+J OPEN(UNIT=IOU(J),FILE=NAME(J),STATUS='OLD') ELSE INQUIRE(FILE=NAME(J),EXIST=LD) IF (LD) THEN IOU(J) = 20+J OPEN(UNIT=IOU(J),FILE=NAME(J),STATUS='OLD', : FORM = 'UNFORMATTED') END IF END IF END IF ELSE IF (NAME(J) .NE. ' ') THEN IOU(J) = 20+J IF (J.NE.6) THEN OPEN(UNIT=IOU(J),FILE=NAME(J),STATUS='UNKNOWN') ELSE OPEN(UNIT=IOU(J),FILE=NAME(J),STATUS='UNKNOWN', : FORM='UNFORMATTED') END IF END IF END IF 37 CONTINUE OPEN(UNIT=PRI,FILE='summry',STATUS='UNKNOWN') * .. on systems where 'APPEND' is allowed, this is useful * OPEN(UNIT=31,FILE='phase.out',STATUS='UNKNOWN',ACCESS='APPEND') OPEN(UNIT=31,FILE='phase.out',STATUS='UNKNOWN') write(31,*) ' k^2 sum(c^2) delta delta/pi' * * ***** END OF INPUT/OUTPUT INTERFACE ************************** * * The following is a non-standard procedure for timing a * calculation. It may be deleted or replaced. * * RTIME = DTIME(TIMES) * FAIL = .FALSE. DO 4 I=1,(30) DPM(I) = D10 IEPTR(I) = 0 4 CONTINUE DO 5 I = 1,(98) IJE(I) = 0 5 CONTINUE * * ***** DETERMINE DATA ABOUT THE PROBLEM * iend= - 1 CALL CDATA(Etarget,nort,ELORT,iend) * * ***** SET PARAMETERS TO THEIR DEFAULT VALUE * 13 PRINT = .FALSE. SCFTOL = 1.D-6 NSCF = 20 IC = 0 ACFG = D0 TRACE = .FALSE. WRITE(ERR,'(/A)') ' Default values for other parameters ? (Y/N) ' READ (IN,'(A)') ANS IF (ANS .EQ. 'N' .OR. ANS .EQ. 'n') THEN WRITE(ERR,'(/A,A)') ' Default values for', : ' PRINT, SCFTOL ? (Y/N) ' READ(IN,'(A)') ANS IF ( ANS .NE. 'Y' .AND. ANS .NE. 'y' ) THEN WRITE(ERR,'(A)') ' Input free FORMAT(L, F) ' READ(IN,*) PRINT, SCFTOL END IF WRITE(ERR,'(/A)') ' Default values for NSCF, IC ? (Y/N) ' READ(IN,'(A)') ANS IF (ANS .NE. 'Y' .AND. ANS .NE. 'y' ) THEN WRITE(ERR,*) ' Input free FORMAT(I, I) ' READ(IN,*) NSCF, IC END IF WRITE(ERR,'(/A)') ' Default values for ACFG,TRACE ? (Y/N) ' READ(IN,'(A)') ANS IF (ANS .NE. 'Y' .AND. ANS .NE. 'y') THEN WRITE(ERR,'(A)') ' Input free FORMAT( F, L) ' READ(IN,*) ACFG,TRACE END IF END IF WRITE(OUT,2) PRINT,CFGTOL,SCFTOL,NSCF,IC,ACFG,ID,TRACE 2 FORMAT(/L3,2D6.1,2I3,F3.1,I3,L3) * * 11 ekk = e(nwf,nwf) if( ekk .ge. d0 ) goto 7 WRITE(OUT,'(//A,F15.7/)') ' *** CALCULATIONS FOR k^2 =',-EKK WRITE(ERR,'(//A,F15.7/)') ' *** CALCULATIONS FOR k^2 =',-EKK call CSCF(Etarget,EKK,ACFG,SCFTOL,PRINT,nort,elort,iend) CALL CDATA(Etarget,nort,ELORT,iend) if( iend .le. 0 ) goto 11 22 WRITE(ERR,'(//A)') ' continue for other energies? ' READ(IN,'(A)') ANS IF (ANS .ne. 'Y' .and. ANS .ne. 'y') goto 6 * Determine the range of values for K*K * 7 WRITE(ERR,'(//A)') ' Enter k^2: MIN, DELTA, MAX ' READ(5,*) ELOW, EDELTA, EHIGH EK = ELOW 100 EKK = -EK WRITE(OUT,'(//A,F10.4/)') ' *** CALCULATIONS FOR k^2 =',-EKK CALL EIJSET(NWF,NWF,EKK) * * ***** PERFORM THE MCHF ITERATION * CALL CSCF(Etarget,EKK,ACFG,SCFTOL,PRINT,nort,elort,iend) EK = EK + EDELTA IF (EDELTA .GT. D0) THEN IF (EK .LE. EHIGH + 0.5*EDELTA) GO TO 100 ELSE IF (EK .GE. EHIGH + 0.5*EDELTA) GO TO 100 END IF goto 22 * * ***** DETERMINE END OF CASE * 6 CONTINUE * * ON systems where dtime is implemented, these are useful * RTIME = DTIME(TIMES) * WRITE(ERR,'(//A/A//A/3F12.3//)') ' END OF CASE',' ===========', * : ' Real User System Time (in minutes)', * : RTIME/60.,TIMES(1)/60., TIMES(2)/60. END * * ------------------------------------------------------------------ * C D A T A * ------------------------------------------------------------------ * * Data concerning the number of configurations (NCFG), the number * and type of electrons in each configuration, as well as data * associated with the energy expression are read and stored. * * SUBROUTINE CDATA(Etarget,nort,ELORT,nend) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON /zzind/ZZ(NWD),IND(NwD),IELI(5),NOCCSH(NCD) * LOGICAL SETORT,STRONG CHARACTER*3 ELORT(20,2) CHARACTER*3 EL1,EL2,ELCLSD(18),ELI(5),ANS*1,STRING*40,LIST*72 * 1 FORMAT(18(1X,A3)) 7 FORMAT(A3,F6.0,I3,I3,F3.1) if( nend .eq. -1 ) goto 5 cxi cxi read configuration weight for another continuum orbital energy cxi nend = 0 read(IUC,'(A)', end=99) string read(IUC,'(A)', end=99) string do 77 nc = 1, ncfg read(IUC,'(A40,F10.8)', end=99) string, WT(NC) read(IUC,'(A)', end=99) string 77 continue read(IUC,'(A)', end=99) string goto 28 * * ***** First time to enter CDATA, READ 'ATOM' CARD * 5 WRITE(ERR,'(/A)') ' ATOM, TERM, Z in FORMAT(A,A,F) : ' READ(IN,'(A)') STRING I = INDEX(STRING,',') IF ( I .EQ. 0) THEN WRITE(ERR,*) ' ATOM, TERM, and Z must be separated by commas ' GO TO 5 END IF ATOM = STRING(1:I-1) J = INDEX(STRING(I+1:),',') IF ( J .EQ. 0) THEN WRITE(ERR,*) ' ATOM, TERM, and Z must be separated by commas ' GO TO 5 END IF TERM = STRING(I+1:I+J-1) READ(STRING(I+J+1:),*) Z * * * ***** READ CONFIGURATIONS FROM A FILE * READ(IUC,'(15X,F14.7/18(1X,A3))') Etarget,(ELCLSD(I),I=1,18) NCFG = 0 3 READ(IUC,'(A40,F10.8)',END=10) STRING,W IF (STRING(1:1) .NE. '*' .AND. STRING(1:3) .NE. ' ') THEN NCFG = NCFG+1 if( w .eq. 0.d0 ) w = 1.d0 IF (NCFG .LE. (NCD) ) THEN CONFIG(NCFG) = STRING WT(NCFG) = W READ(IUC,'(9(5X,A3))') (COUPLE(NCFG,J),J=1,9) GO TO 3 ELSE STOP ' TOO MANY CONFIGURATIONS: MAX =(NCD)' END IF END IF 10 CONTINUE ID = -1 * * ***** DETERMINE NCLOSD SHELLS * I = 0 SS = D0 12 IF (ELCLSD(I+1) .NE. ' ') THEN I = I+1 VARIED(I) = .TRUE. EL(I) = ELCLSD(I) J = 3 IF (EL(I)(1:1) .NE. ' ') J = 2 L(I) = LVAL(EL(I)(J:J)) N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 IFULL = 2*(2*L(I)+1) S(I) = SS + IFULL/2 SS = SS + IFULL METH(I) = 1 ACC(I) = D0 IND(I) = 0 SUM(I) = 4*L(I)+2 IF (IUF .NE. 0) IND(I) = -1 IF( I .LT. 18) GO TO 12 STOP ' TOO MANY CLOSED SHELLS: MAX = 18' END IF NCLOSD = I * * ***** DETERMINE THE OTHER ELECTRONS * MAXORB = NCLOSD DO 15 NC = 1,NCFG STRING = CONFIG(NC) J = 2 I = 0 16 IF (STRING(J:J+2) .NE. ' ' ) THEN * * ***** An electron has been found; is it a new one? * I = I+1 EL1 = STRING(J:J+2) K = NCLOSD + 1 17 IF (K .LE. MAXORB) THEN IF ( EL(K) .NE. EL1 ) THEN K = K+1 IF (K .GT. (30)) STOP ' TOO MANY ELECTRONS: MAX= (30)' GO TO 17 END IF ELSE * * ***** A new electron has been found; add it to the list * MAXORB = K EL(MAXORB) = EL1 IF ((EL1(1:1) .EQ. 'k' .OR. EL1(2:2) .EQ. 'k' .OR. : EL1(1:1) .EQ. 'n' .OR. EL1(2:2) .EQ. 'n') ) then korb = k if( ID .EQ. -1) ID = NC-1 endif END IF J = J+8 IF (J .LT. 40) GO TO 16 END IF NOCCSH(NC) = I 15 CONTINUE IF (ID .EQ. -1) THEN WRITE(ERR,*) ' STOP in DATA: No continuume function found' CALL EXIT(1) END IF * * ***** The list of electrons has been determined * NWF = MAXORB cxi cxi move the continuum orbital to the last cxi if( korb .ne. nwf ) then el1 = el(korb) do 82 j=korb,nwf-1 el(j) = el(j+1) 82 continue el(nwf) = el1 endif WRITE(ERR,19) MAXORB,(EL(J),J=1,MAXORB) 19 FORMAT(/' There are ',I3,' orbitals as follows:'/(1X,18(1X,A3))) 21 WRITE(ERR,'(A,A)') ' Enter orbitals to be varied:', : ' (ALL,NONE,SOME,NIT=,comma delimited list)' READ '(A)', LIST IF (LIST(1:3) .EQ. 'ALL' .OR. LIST(1:3) .EQ. 'all') THEN NIT = NWF ELSE IF (LIST(1:4).EQ.'SOME' .OR. LIST(1:4).EQ.'some') THEN NIT = NWF - NCLOSD ELSE IF (LIST(1:4).EQ.'NONE' .OR. LIST(1:4).EQ.'none') THEN NIT = 0 ELSE IF (INDEX(LIST,'=') .NE. 0) THEN J = INDEX(LIST,'=') READ(LIST(J+1:),*) NIT ELSE NIT = 0 J = 1 22 NEXT = INDEX(LIST(J:),',') * * *** Search for last electron label which need not be followed * by a comma * IF (NEXT .EQ. 0 .AND. LIST(J:J+2) .NE. ' ') : NEXT = INDEX(LIST(J+1:),' ') + 1 IF (NEXT .NE. 0) THEN IF (NEXT .EQ. 4) THEN EL1 = LIST(J:J+2) ELSE IF (NEXT .EQ. 3) THEN EL1 = ' '//LIST(J:J+1) ELSE WRITE(ERR,*)'Electron labels must be separated by commas;' WRITE(ERR,*)' each label must contain 2 or 3 characters' GO TO 21 END IF CALL REORD(EL,EL1,NWF,IERR) IF (IERR .EQ. 0) THEN NIT = NIT + 1 J = J + NEXT IF (J .LT. 72) GO TO 22 ELSE WRITE(ERR,*) ' Case must match as well as position of', : ' imbedded blanks' WRITE(ERR,*) ' For 3rd character of label to be blank', : ' follow blank with comma' GO TO 21 END IF END IF END IF * IB = NWF - NIT + 1 WRITE(ERR,'(/,A)') ' Default electron parameters ? (Y/N) ' READ '(A)', ANS IF ( ANS.NE.'Y' .AND. ANS.NE.'y' .AND. NIT.NE.0) then WRITE(ERR,*) : ' S, IND, METH, ACC for electrons to be varied (free-format)' ENDIF DO 20 I = NCLOSD+1,NWF IF (ANS.EQ.'Y' .OR. ANS.EQ.'y' .OR. I.LT.IB) THEN S(I) = SS METH(I) = 3 ACC(I) = D0 IND(I) = 0 IF (IUF .NE. 0) IND(I) = -1 ELSE WRITE(ERR,*) EL(I) READ(IN,*) S(I),IND(I),METH(I),ACC(I) END IF VARIED(I) = .TRUE. J = 2 IF (EL(I)(1:1) .EQ. ' ') J = 3 L(I) = LVAL(EL(I)(J:J)) N(I) = ICHAR(EL(I)(J-1:J-1)) - ICHAR('1') + 1 IF (EL(I)(J-1:J-1) .EQ. 'n') METH(I) = 5 20 CONTINUE * * ***** CHECK METHOD AND SET ORTHOGONALITY * 28 EL1 = EL(NWF) IF (.NOT. (EL1(1:1).EQ.'k' .OR. EL1(2:2).EQ.'k')) : STOP ' Last orbital not a continuum orbital' IF (METH(NWF) .NE. 4) THEN METH(NWF) = 4 * IND(NWF) = 1 DO 95 J = 1,NO P(J,NWF) = D0 95 CONTINUE AZ(NWF) = D1 MAX(NWF) = NO END IF DO 35 NC = 1,NCFG STRING = CONFIG(NC) J = 2 I = 0 30 IF (STRING(J:J+2) .NE. ' ' ) THEN * * ***** An electron has been found; find its index * I = I+1 ELI(I) = STRING(J:J+2) CALL EPTR(EL,ELI(I),IELI(I),*99) READ(STRING(J+4:J+5),'(I2)') IQ J = J+8 IF (J .LT. 40) GO TO 30 END IF * * ***** DEFINE ALL ORBITALS IN THE CONFIGURATION TO BE ORTHOGONAL * DO 34 I1 = 2,I J1 = IELI(I1) DO 33 I2 = 1,I1-1 J2 = IELI(I2) IF (L(J1) .EQ. L(J2) ) THEN CALL EIJSET(J1,J2,1.D-5) CALL EIJSET(J2,J1,1.D-5) END IF 33 CONTINUE 34 CONTINUE 35 CONTINUE * * ***** SET THE FOLLOWING ORBITALS ORTHOGONAL * * 1) ORBITALS WITH DIFFERENT L'S * 2) IN THE SAME ORTHOGONAL SET * 3) SPECIFIED ORTHOGONALITY * * ***** * DO 38 I = 2,NWF DO 39 J = 1,I-1 IF (L(I) .EQ. L(J) .AND. SETORT(EL(I),EL(J)) ) THEN C = 1.D-5 IF (I.LE.NCLOSD .AND. J.LE.NCLOSD) C = 1.D-10 CALL EIJSET(I,J,C) CALL EIJSET(J,I,C) END IF 39 CONTINUE 38 CONTINUE * * ***** DETERMINE ADDITIONAL ORTHOGONALITY PAIRS * if( nend .eq. 0 ) then do 87 i = 1, NORT EL1 = ELORT(I,1) EL2 = ELORT(I,2) CALL EPTR(EL,EL1,I1,*99) CALL EPTR(EL,EL2,I2,*99) CALL EIJSET(I1,I2,1.D-5) CALL EIJSET(I2,I1,1.D-5) 87 continue goto 66 endif I = 0 IF ( IUC .NE. IN) THEN 40 READ(IUC,1,END=50) EL1,EL2 IF ( EL1(1:1) .NE. '*' .AND. EL2 .NE. ' ') THEN I = I +1 IF (I .GT. (20)) STOP ' TOO MANY ORTHOGONALITIES: MAX=(20)' ELORT(I,1) = EL1 ELORT(I,2) = EL2 CALL EPTR(EL,EL1,I1,*99) CALL EPTR(EL,EL2,I2,*99) CALL EIJSET(I1,I2,1.D-5) CALL EIJSET(I2,I1,1.D-5) GO TO 40 END IF END IF 50 CONTINUE NORT = I * * ***** ADDITIONAL PARAMETERS * WRITE(ERR,'(/,A)') ' Default values (NO,REL,STRONG) ? (Y/N) ' READ(IN,'(A)') ANS IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'y') THEN NO = (220) REL = .FALSE. STRONG = .FALSE. IF (NCFG .GT. 1) STRONG = .TRUE. ELSE WRITE(ERR,*) ' Enter values in FORMAT(I,L,L) ' READ(IN,*) NO, REL, STRONG IF (NO .GT. (220)) STOP : ' TOO MANY POINTS FOR EACH FUNCTION: MAX=(220)' END IF ND = NO - 2 WRITE(OUT,61) ATOM,TERM,Z,NO,NWF,NIT,NCFG,REL,STRONG 61 FORMAT(/1X,2A6,F6.0,I6,3I3,2L3) WRITE(PRI,62) ATOM,TERM,Z,(EL(I),4*L(I)+2,I=1,NCLOSD) 62 FORMAT(1H1///9X,33HHARTREE-FOCK WAVE FUNCTIONS FOR ,2A6,4H Z =, 1 F5.1//14X,'CORE = ',5(A3,'(',I2,')')) OMIT = .NOT. STRONG 66 WRITE(PRI,'(//11X,A,37X,A//)') 'CONFIGURATION','WEIGHT' * * ***** WRITE 'CONFIGURATION' CARDS AND CHECK THE WEIGHTS * W = D0 DO 63 I=1,NCFG 63 W = W + WT(I)**2 IF (W .EQ. D0) STOP ' WEIGHT information omitted' DO 68 I = 1, NCFG NOCC=NOCCSH(I) WRITE(PRI,70) I, CONFIG(I), WT(I),(COUPLE(I,J),J=1,NOCC) 70 FORMAT(/3X,I3,6X,A40,F19.8/12X,9(5X,A3)) WRITE(PRI,73) (COUPLE(I,J),J=NOCC+1,2*NOCC-1) 73 FORMAT(23X,4(5X,A3)) 68 CONTINUE WRITE(PRI,71) 71 FORMAT(//9X,10HINPUT DATA/9X,10H----- ----//13X,13HWAVE FUNCTION, 1 11H PROCEDURE/17X,22HNL SIGMA METH ACC OPT///) DO 79 I = 1,NWF WRITE(PRI,78) I,EL(I),N(I),L(I),S(I),METH(I),ACC(I),IND(I) 78 FORMAT(I8, 2X,A3,2I3,F7.1,I4,F4.1,I4) 79 CONTINUE * * ***** INITIALIZE ARRAYS, IF NECESSARY * if( nend .eq. 0 ) then cxi cxi keep core and target orbitals unchanged cxi do 83 i = 1, nwf if( i .lt. ib ) then ind(I) = 1 else ind(i) = - 1 endif 83 continue endif CALL WAVEFN(nend) if( nend .ne. -1 ) return DO 100 I=1,6 INTPTR(I) = 0 100 CONTINUE * IF (IUD .NE. IN) CALL INTGRL * * ***** DEFINE SUM(I) * IBEGIN = INTPTR(5)+1 IEND = INTPTR(6) DO 80 I = IBEGIN,IEND IF (IEL(I,1).EQ.IEL(I,2)) SUM(IEL(I,1)) = -2*COEF(I) 80 CONTINUE * RETURN 99 if( nend .eq. -1 ) then STOP else nend = 1 return endif END * * ------------------------------------------------------------------ * C D E * ------------------------------------------------------------------ * * This routine controls the solution of the differenttial equation * for the radial function P . One of three methods is selected - * I1 * M1, M2, or M3 - for solving the equations, the initial choice * being determined by an input paramter, METH(I), except when no * exchange is present, in which case M2 is selected. (For further * information see Sec. 7-4) * * Value of METH(I) Method * --------------- ------ * < or =1 M1 with search for an acceptable solution * =2 M2 with search for an acceptable solution * =3 M3 without any checking * * If M1 fails to find an acceptable solution, the radial functions * are orthogonalized, off-diagonal energy parameters recomputed, * and the method tried again. Should it continue to fail, METH(I) * is set to 2. * * SUBROUTINE CDE(I1) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON P2(NOD),HQ(NOD),XX(NOD),AC(20,20),BC(20),JV(20), : AZZ,PP,FN,EM,FM,EU,FU,DELTAE,M,NODE,MK,KK,NJ * LOGICAL DIAG CHARACTER*2 ASTER(5) DATA ASTER/' ','* ','**',' c',' b'/ * I = I1 ED2 = E(I,I) KK= MAX0(1,METH(I)) IF (NWF .EQ. 1) KK = 2 NODE = N(I) - L(I) - 1 * * ***** CALL METHD1 TO SOLVE THE DIFFERENTIAL EQUATION * CALL METHD1(I) IF ( FAIL ) GO TO 25 * 12 PN = DSQRT(QUAD(I,M,PDE,PDE)) IF (METH(I) .LE. 3) THEN DO 9 J = 1,M 9 PDE(J) = PDE(J)/PN AZZ = AZZ/PN END IF * * ***** CHECK IF METHOD 2 SHOULD BE USED * IF ( KK .NE. 1 ) GO TO 13 IF (DABS(D1 -ED2/E(I,I)) .GT. 0.01D0 .OR. 1 DMAX1(DABS(D1 - PN), DABS(D1/PN - D1)) .LT. 0.10D0 ) 2 GO TO 13 METH(I) = 2 KK = 2 GO TO 25 * * ***** SET THE ACCELERATING PARAMETER * * 13 IF (IPR .NE. I .OR. KK.GT.3) GO TO 33 ED2 = ED2 - E(I,I) IF (ED1*ED2 .GT. D0) ACC(I) = .75*ACC(I) IF (ED1*ED2 .LT. D0) ACC(I) = (D1 + D3*ACC(I))/D4 33 C = ACC(I) CD = D1 - C DP = DP/PN * * ***** IMPROVE THE ESTIMATES * AZ(I) = CD*AZZ + C*AZ(I) AZZ = AZ(I) MAX(I) = M DP = D0 DO 21 J = 1,M DIFF = P(J,I)-PDE(J) DP = DMAX1(DP ,DABS(DIFF)*R2(J)) 21 P(J,I) = PDE(J) + C*DIFF IF (M .EQ. NO) GO TO 26 M = M + 1 DO 24 J = M,NO 24 P(J,I) = D0 * * ***** CHECK THE ORTHOGONALIZATION * 26 NN = NWF IF (OMIT) NN = IB - 1 IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1) + 1 IP = IBEGIN IJ = 0 50 JI = IJE(IP) IF (JI .NE. I .AND. JI .NE. NWF) THEN IF (JI .GE. IB .AND. DPM(JI) .GE. DPM(I)) THEN * * The JI orbital should be orthogonalized * C = QUADR(I,JI,0) MM = MIN0(MAX(JI),MAX(I)) DO 51 J = 1,MM P(J,JI) = P(J,JI) - C*P(J,I) 51 CONTINUE AZ(JI) = AZ(JI) - C*AZ(I) IF ( METH(JI) .LE. 3) THEN C2 = SQRT(QUADR(JI,JI,0)) DO 52 J = 1,MM P(J,JI) = P(J,JI)/C2 52 CONTINUE AZ(JI) = AZ(JI)/C2 END IF VARIED(JI) = .TRUE. MAX(JI) = MM WRITE(OUT,63) EL(I),EL(JI),C ELSE * * The I'th orbital must be orthogonalized * IJ = IJ + 1 IF (IJ .GT. 20) STOP ' TOO MANY ORTHOGONALITY CONDITIONS' JV(IJ) = JI END IF END IF IP = IP + 1 IF (IP .LE. IEPTR(I)) GO TO 50 IF (IJ .NE. 0 ) THEN DIAG = .TRUE. DO 61 J = 1,IJ BC(J) = QUADR(I,JV(J),0) AC(J,J) = D1 DO 62 JJ = J+1, IJ IF (E(JV(J),JV(JJ)) .NE. D0 ) THEN AC(J,JJ) = D0 AC(JJ,J) = D0 ELSE AC(J,JJ) = QUADR(JV(J),JV(JJ),0) AC(JJ,J) = AC(J,JJ) DIAG = .FALSE. END IF 62 CONTINUE 61 CONTINUE IF ( .NOT. DIAG .AND. IJ .GT. 1) CALL LINEQN(20,IJ,AC,BC) M = MAX(I) DO 65 JJ = 1,IJ C = BC(JJ) WRITE(OUT,63) EL(JV(JJ)),EL(I),C 63 FORMAT(6X,'<',A3,'|',A3,'>=',1PD8.1) M = MAX0(M,MAX(JV(JJ))) DO 64 J = 1,M P(J,I) = P(J,I) - C*P(J,JV(JJ)) 64 CONTINUE AZZ = AZZ - C*AZ(JV(JJ)) 65 CONTINUE IF (METH(I) .LE. 3) THEN PNN = DSQRT(QUADR(I,I,0)) DO 66 J = 1,M P(J,I) = P(J,I)/PNN 66 CONTINUE AZZ = AZZ/PNN END IF END IF M = NO 67 IF (DABS(P(M,I)) .LT. 1.D-15) THEN P(M,I) = D0 M = M-1 GO TO 67 END IF MAX(I) = M * IF (AZZ .GT. D0) AZ(I) = DMAX1(AZZ,D5*AZ(I)) WRITE(OUT,17) EL(I),E(I,I),AZ(I),PN,ASTER(KK),DP 17 FORMAT(20X,A3,2F15.7,F12.7, A2,1PD10.2) DPM(I) = DP IF (IPR .EQ. I1) ED1 = ED2 IF (IPR .NE. I1) ED1 = ED2 - E(I1,I1) IPR = I1 VARIED(I) = .TRUE. RETURN * * ***** IF METHD1 FAILED TO FIND AN ACCEPTABLE SOLUTION, ORTHOGONALIZE * ***** THE ESTIMATES AND TRY AGAIN * 25 IF (I .EQ. IB) GO TO 27 CALL ORTHOG CALL CUPDATE CALL CGRANGE 27 CALL METHD1(I) IF ( FAIL ) GO TO 23 GO TO 12 * * ***** ERROR RETURN FROM SECOND TRY. IF M1 WAS USED,SWITCH TO * M2 AND TRY ONCE MORE. * 23 IF ( KK .EQ. 2) RETURN KK = 2 GO TO 27 END * * ------------------------------------------------------------------ * 3-5 D I A G * ------------------------------------------------------------------ * * The CDIAG subroutine computes an energy matrix and if the number * of configurations is greater than 1, finds an eigenvalue and * eigenvector of this matrix. * * Given the accelerating parameter for configuration mixing, * ACFG, the new mixing coefficients are stored in COMMON. * * SUBROUTINE CDIAG(ETOTAL,ACFG,PCONV) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR LOGICAL PCONV COMMON WP(NCD),W(NCD,NCD) * DO 1 I = 1,NCFG DO 2 J = 1,NCFG W(I,J) = D0 2 CONTINUE WP(I) = WT(I) W(I,I) = EC-ETOTAL 1 CONTINUE * IBEGIN = 1 IEND = INTPTR(6) J = 0 DO 10 I = IBEGIN,IEND 11 IF (CPTR(I) .GT. J) THEN J = J + 1 C = COEFF(J)*VALUE(I) IF (OPTR(J) .NE. 0) C = C*VALUE(OPTR(J)) W(IH(J),JH(J)) = W(IH(J),JH(J)) + C GO TO 11 END IF 10 CONTINUE * * ***** SYMMETRIZE THE MATRIX * DO 12 I = 1,NCFG-1 DO 13 J = I+1,NCFG W(I,J) = W(J,I) 13 CONTINUE 12 CONTINUE IF (TRACE) THEN WRITE(OUT,'(/10X,A,F16.8,10X,A,F16.8/)') : 'EC =',EC,'ETOTAL =',ETOTAL DO 15 I=1,ID WRITE(OUT,'(I4,6F12.7/(4X,6F12.7))') : I,(W(I,J),J=1,NCFG) 15 CONTINUE END IF * 14 IF (NCFG .EQ. 1) GO TO 37 * * * GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING * DO 35 K = 1,ID-1 KP1= K+1 * * FIND PIVOT * M = K DO 21 I = KP1,ID IF (DABS(W(I,K)) .GT. DABS(W(M,K))) M = I 21 CONTINUE T = W(M,K) W(M,K) = W(K,K) W(K,K) = T * * SKIP STEP IF PIVOT IS ZERO * IF (T .EQ. 0.0D0) GO TO 35 * * COMPUTE MULTIPLIERS * DO 20 I = KP1,ID W(I,K) = -W(I,K)/T 20 CONTINUE * * INTERCHANGE AND ELIMINATE BY COLUMNS * DO 30 J = KP1,NCFG T = W(M,J) W(M,J) = W(K,J) W(K,J) = T IF (T .EQ. 0.0D0) GO TO 30 DO 23 I = KP1,ID W(I,J) = W(I,J) + W(I,K)*T 23 CONTINUE 30 CONTINUE 35 CONTINUE DO 24 J = ID,1,-1 JP = J+1 WT(J) = D0 DO 25 K = JP,NCFG 25 WT(J) = WT(J) - W(J,K)*WT(K) 24 WT(J) = WT(J)/W(J,J) DO 28 I = 1,ID WT(I) = WT(I) + ACFG*(WP(I) - WT(I)) 28 CONTINUE * 37 WRITE(OUT,636) (I,WT(I),I=1,ID) 636 FORMAT(/(5(I4,F12.6))) * * ***** REDEFINE SUM(I) * IBEGIN = INTPTR(5)+1 IEND = INTPTR(6) DO 50 I = IBEGIN,IEND IF (IEL(I,1).EQ.IEL(I,2)) SUM(IEL(I,1)) = -2*COEF(I) 50 CONTINUE END * * ------------------------------------------------------------------ * C G R A N G E * ------------------------------------------------------------------ * * Controls the calculation of off-diagonal energy parameters. * It searches for all pairs (i,j) which are constrained through an * orthogonality requirement. When one of the pair , say P * i * must be orthogonal not only to P but also to P where n = n , * j k j k * a system of equations must be solved, the exact form depending on * whether or not any of the functions are part of the frozen core. * When only one pair with a given set of principal quantum numbers * is present, ELAGR(I,J) is used to determine the off- diagonal * energy parameters as long as |q -q | > 0.05. Otherwise Eq. * i j * (7-10) modified for configuration interaction is used. * * SUBROUTINE CGRANGE IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON W(NCD,NCD),U(NCD),DWT(NCD),AC(20,20),BC(20),JV(20),IV(20) LOGICAL DIAG, FIRST, REL * * * ***** FOR EACH l COMPUTE OFF-DIAGONAL ENERGY PARAMETERS * DO 10 IL = 0,5 IJ = 0 DO 11 I = IB,NWF IF ( L(I) .NE. IL ) GO TO 11 DO 12 J = 1,I-1 IF (DABS(E(I,J)) .GT. 1.D-10 ) THEN IJ = IJ + 1 IF ( IJ .GT. 20) STOP ' TOO MANY LAGRANGE MULTIPLIERS' IV(IJ) = I JV(IJ) = J END IF 12 CONTINUE 11 CONTINUE * * ***** IJ IS THE NUMBER OF LAGRANGE MULTIPLIERS FOR l = IL * IF (IJ .EQ. 0) GO TO 10 DO 13 II = 1,IJ BC(II) = D0 DO 14 III = 1,IJ AC(II,III) = D0 14 CONTINUE 13 CONTINUE DO 16 I = IB,NWF IF ( L(I) .NE. IL ) GO TO 16 FIRST = .TRUE. DO 18 II = 1,IJ J = 0 IF ( IV(II) .EQ. I) THEN J = JV(II) ELSE IF ( JV(II) .EQ. I) THEN J = IV(II) END IF IF ( J .NE. 0) THEN IF (FIRST) THEN CALL XCH(I,2) CALL POTL(I) DO 20 JJ = 1,NO YK(JJ) = YR(JJ) 20 CONTINUE FIRST = .FALSE. END IF DO 22 JJ = 1,NO YR(JJ) = P(JJ,J) 22 CONTINUE BC(II) = BC(II) + : HL(EL,I,J,REL)-D2*QUADS(I,J,1)-QUAD(J,NO,YR,X) END IF 18 CONTINUE 16 CONTINUE DO 24 II = 1,IJ DO 26 III = 1,II IF ( II .EQ. III) THEN AC(II,II) = D1/SUM(IV(II)) IF (JV(II) .GE. IB) THEN AC(II,II) = AC(II,II) + D1/SUM(JV(II)) END IF ELSE IF (IV(II) .EQ. IV(III) .AND. : E(JV(II),JV(III)) .EQ. D0 ) THEN AC(II,III) = QUADR(JV(II),JV(III),0)/SUM(IV(II)) AC(III,II) = AC(II,III) DIAG = .FALSE. ELSE IF (JV(II) .EQ. JV(III) .AND. JV(II) .GE. IB : .AND. E(IV(II),IV(III)) .EQ. D0) THEN AC(II,III) = QUADR(IV(II),IV(III),0)/SUM(JV(II)) AC(III,II) = AC(II,III) DIAG = .FALSE. END IF 26 CONTINUE 24 CONTINUE IF ( .NOT. DIAG ) CALL LINEQN(20,IJ,AC,BC) DO 28 II = 1,IJ CALL EIJSET(IV(II),JV(II),BC(II)/SUM(IV(II))) IF ( JV(II) .GE. IB ) : CALL EIJSET(JV(II),IV(II),BC(II)/SUM(JV(II))) 28 CONTINUE 10 CONTINUE * * ***** PRINT THE OFF-DIAGONAL ENERGY PARAMETERS * DO 30 I = IB,NWF DO 32 J = 1,I-1 IF (DABS(E(I,J)) .GT. 1.D-10) THEN WRITE(OUT,35) EL(I),EL(J),E(I,J),EL(J),EL(I),E(J,I) 35 FORMAT(7X,2(3X,'E(',2A3,') =',1PE12.5)) END IF 32 CONTINUE 30 CONTINUE RETURN END * * ------------------------------------------------------------------ * C N M R V * ------------------------------------------------------------------ * * CNMRV Solves the differential equation * * y" = FK y + X * * In two different regions - inner (1,NJ+1) and outer (NJ+2,M) - by * outwards integration. * * SUBROUTINE CNMRV(NJ,M,M0,AZZ,FK,X,FH,XH,PH,PDE) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) DIMENSION PDE(*),FK(*),X(*),FH(*),XH(*),PH(*) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS c c starting from JH=5, JH corresponding to J=NJ+2, c two points each J, JH=2*(J-NJ) + 1 c R(J) --> rh(JH) cxi comment by Jinhua Xi * * * ....INNER REGION ..... * * ***** Integrate outward to NJ+1 * Y1 = PDE(M0) Y2 = PDE(M0+1) G1 = FK(M0) G2 = FK(M0+1) DO 11 J = M0+2,NJ+1 G3 = FK(J) Y3 = (Y2+Y2-Y1 + (D10*G2*Y2 + G1*Y1) + X(J-1)) / (D1 - G3) PDE(J) = Y3 Y1 = Y2 Y2 = Y3 IF (ABS(Y3) .GT. 1.E5) THEN * * ....Scale down to avoid overflow * AZZ = AZZ/100.D0 DO 12 JJ = 1,J PDE(JJ) = PDE(JJ)/100.D0 12 CONTINUE Y1 = Y1/100.D0 Y2 = Y2/100.D0 END IF G1 = G2 G2 = G3 11 CONTINUE * * ....OUTER REGION .... * * ***** Redefine Y2 for half the step-size * G1 = FH(1) G2 = FH(2) G3 = FH(3) Y2 = (-XH(2) + Y1+Y3 - G1*Y1 - G3*Y3)/(D2 + D10*G2) * * ...Integrate outwards from NJ+2 to M. * Y1 = Y2 Y2 = Y3 G1 = G2 G2 = G3 JH = 4 DO 20 J = NJ+2,M DO 22 K = 1,2 G3 = FH(JH) Y3 = (Y2+Y2-Y1 + (D10*G2*Y2 + G1*Y1) + XH(JH-1)) / (D1 - G3) ph(jh) = y3 Y1 = Y2 Y2 = Y3 G1 = G2 G2 = G3 JH = JH+1 22 CONTINUE PDE(J) = Y3 20 CONTINUE END * * ------------------------------------------------------------------ * C O U L O M * ------------------------------------------------------------------ * * This subroutine handles three different tasks: * * 1) Computes and stores the FK function; * * FK(r) =[-2(Z-YR(r))*r + (l+.5)**2 + (k*r)**2]CH * * It will remain constant for the rest of the calculations. * * 2) Determines the onset of the asymptotic, Coulomb region, as * the classical turning point, R(NJ). * * 3) Determines the point, R(MP)>R(NJ), outside which the potential * could be described as Zeff/r, ie the change in YR is negligible. * * 4) Interpolates FK, to obtain and store FH, in the asymptotic * region. (That is between R(NJ) and R(MM), where MM = * MIN(NO-2,NJ+99)) The FK functions is determined in the normal * grid points, while the FH is defined for Half the stepsize. * SUBROUTINE COULOM(I,EKK) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) COMMON /CONTIN/FK(NOD),FH(260),XH(260),rh(260),r2h(260),ph(260), : CD,FL,ZL,ZF,V,NJ,MJ,MP,IX COMMON /COULFG/FKC(NOD),XC(NOD),PDC(NOD),FHC(260),PHC(260),NJM * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * * ***** Set arrays for the asymptotic region * * JJ = 0 M = NOD MAX(I) = M CALL POTL(I) FL = L(I) ZL = Z/(FL+D1) ZF = Z - YR(NO) V = YR(1)/R(1) CD = (FL+D5)**2 yrno = yr(no) * * 1) Compute the direct function, FK. * NJM=0 DO 4 J = 1,M if( dabs( yrno-yr(j) ) .lt. 1.d-7 .and. NJM .eq. 0 ) NJM=J FKC(J) = (-D2*ZF*R(J) + CD + EKK*RR(J))*CH 4 FK(J) = (-D2*(Z - YR(J))*R(J) + CD + EKK*RR(J))*CH * * 2) Search for the point at which FK(J)<0 for J>NJ * NJ = M 5 IF ( FK(NJ) .LT. D0 ) THEN NJ = NJ-1 IF (NJ .GT. 90 ) GO TO 5 END IF NJ = NJ+1 * * 3) Search for the point, MP, outside which YR is constant * and we can define a Zeff. * MP = M 6 IF ( YR(MP) - YR(MP-1) .LT. r(mP)*1.D-4 ) THEN MP = MP-1 IF (MP .GE. NJ) GO TO 6 END IF MP = MP+1 * * 4) Interpolate FK to obtain FH in "half-grid-points". * EXPH = EXP(H/D2) CHH = CH/D4 JH = 1 MM = MIN0(NO-2,NJ+129) DO 50 J = NJ,MM FH(JH) = FK(J)/D4 FHC(JH) = FKC(J)/D4 YRH = (9.*(YR(J)+YR(J+1))-YR(J-1)-YR(J+2))/D16 RHH = R(J)*EXPH RRH = RHH*RHH FH(JH+1) = (-D2*(Z-YRH)*RHH +CD + EKK*RRH)*CHH FHC(JH+1) = (-D2*ZF*RHH +CD + EKK*RRH)*CHH JH = JH+2 50 CONTINUE IX = 0 END * * ------------------------------------------------------------------ * C O U T P U T * ------------------------------------------------------------------ * * The radial functions and orthogonality integrals are printed, * if PRINT is .TRUE. The functions will also be punched (or * stored) on unit OUF, if OUF .NE. 0. * * SUBROUTINE COUTPUT(PRINT,DELTA,Nstart) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) INTEGER MMX * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL PRINT, REL DIMENSION POUT(8) IF ( .NOT. PRINT ) GO TO 31 C C ***** PRINT RADIAL FUNCTIONS, 7 PER PAGE C ML = 1 2 MU = MIN0(ML+7,NWF) I = MU - ML + 1 MX = 0 DO 1 J = ML,MU 1 MX = MAX0(MX,MAX(J)) WRITE(PRI,5) ATOM,TERM,(EL(J),J=ML,MU) 5 FORMAT(1H1,9X,19HWAVE FUNCTIONS FOR ,2A6//10X,1HR,8(10X,A3)) K= 0 KK = 0 DO 6 J = 1,MX DO 9 JJ = ML,MU IJ = JJ - ML + 1 POUT(IJ) = P(J,JJ)*R2(J) 9 CONTINUE K = K+1 IF (K .LE. 10) GO TO 6 K = 1 KK = KK+1 IF (KK .LT. 5) GO TO 21 KK = 0 WRITE(PRI,23) 23 FORMAT(1H1//) GO TO 6 21 WRITE(PRI,8) 8 FORMAT(1X) WRITE(PRI,10) R(J),(POUT(JJ),JJ=1,I) 6 CONTINUE 10 FORMAT(F13.5,F15.6,7F13.6) DO 15 J = ML,MU IJ = J - ML + 1 POUT(IJ) = DPM(J) 15 CONTINUE WRITE(PRI,16) (POUT(J),J=1,I) 16 FORMAT(4X,10HMAX. DIFF. ,F15.7,7F13.7) ML = ML+8 IF (ML .LE. NWF) GO TO 2 31 IF ( NWF .LE. 1) GO TO 30 * * ***** PRINT ORTHOGONALITY INTEGRALS * WRITE(PRI,11) ATOM,TERM 11 FORMAT(////10X,33HORTHOGONALITY INTEGRALS FOR ATOM ,A6,6H TERM ,A6 : //20X, 4H(NL),3X,4H(NL),7X,8HINTEGRAL //) LM = IB ML = MAX0(2,LM) DO 12 I = ML,NWF JF = I - 1 DO 13 J = 1,JF IF (L(I) .NE. L(J)) GO TO 13 T = QUADR(I,J,0) WRITE(PRI,17) EL(I),EL(J),T 17 FORMAT(21X,A3,4X,A3,F15.8) 13 CONTINUE 12 CONTINUE 30 IF ( OUF .EQ. 0) GO TO 14 * * ***** Output functions on unit OUF for future input * * EKI retained only for compatibility with MCHF format * cxi DO 3 I = NCLOSD+1,NWF DO 3 I = Nstart,NWF IF (METH(I) .NE. 4) THEN EKI = -D5*HL(EL,I,I,REL) ELSE EKI = DELTA END IF MMX = MAX(I) WRITE (OUF) ATOM,TERM,EL(I),MMX,Z,E(I,I),EKI,AZ(I), : (P(J,I),J=1,MMX) 3 CONTINUE WRITE (OUF) ATOM,TERM,EL(NWF),0,Z,E(NWF,NWF),EKI,AZ(NWF) * 14 RETURN END * * ------------------------------------------------------------------ * 3-32 C S C F * ----------------------------------------------------------------- * * This routine controls the SCF procedure described in Chapter * 7. If certain input parameters are zero (or blank) they will be * set to their default value. * * Parameter Default Value * -------- ------------- * SCFTOL 1.D-5 * IC (NWF + 1 - IB)/4 + 3 * NSCF 20 * * The self-consistency convergence criterion is * * Z2 = SCFTOL * * It is increased by a factor two at the end of each iteration * * SUBROUTINE CSCF(Etarget,EKK,ACFG,SCFTOL,print,nort,elort,nend) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL PCONV,PRINT CHARACTER*3 ELORT(20,2) * * ***** SET THE SCF CONVERGENCE PARAMETER TO AN OPTIMISTIC VALUE * cxi================================================================ cxi Nstart is the first orbital position to be written to wfn.out. cxi We need only to write the target orbitals once for the cxi first continuum orbitel energy. cxi BUT if so, we need to modify PHOTO, PHOTO reads all target cxi and channel orbitals for each energy cxi cxi IF you want to use wfn.out as wfn.inp again, then you need cxi to set Nstart = 1 when nend = - 1 cxi Nstart = IB if( nend .eq. -1 ) Nstart = 1 cxi cxi=============================================================== cxi cxi Nstart = NCLOSD + 1 !!! PHOTO requires so PI = dacos(-1.d0) ETOTAL = Etarget - D5*EKK TOL = DSQRT(Z)*1.D-5 Z2 = SCFTOL WRITE(OUT,15) 15 FORMAT(//) WRITE(OUT,16) OMIT,ACFG,Z2,NO,REL 16 FORMAT(10X,44HWEAK ORTHOGONALIZATION DURING THE SCF CYCLE=,L4/ : 10X,44HACCELERATING PARAMETER FOR MCHF ITERATION =,F5.2/ : 10X,44HSCF CONVERGENCE TOLERANCE (FUNCTIONS) =,1PD9.2 : /10X,44HNUMBER OF POINTS IN THE MAXIMUM RANGE =,I4/ : 10X,44HRELATIVISTIC DIAGONAL ENERGY CORRECTIONS =,L4//) * * ***** SET ITERATION PARAMETERS * ICYCLE = 0 IPR = 0 CALL COULOM(NWF,EKK) if (P(1,nwf) .eq. D0) then CALL CSOLVE(NWF,DELTA) call orthog end if PCONV = DPM(NWF) .LE. Z2 CALL CUPDATE IF (ID .GE. 1) CALL CDIAG(ETOTAL,ACFG,PCONV) IF ( IB .GT. NWF ) GO TO 17 * * ***** PERFORM NSCF SELF-CONSISTENT FIELD ITERATIONS * 9 DO 100 I = 1,NSCF ICYCLE = ICYCLE + 1 WRITE(OUT,7) ICYCLE,Z2 7 FORMAT(//10X,17HITERATION NUMBER ,I2/10X,16H----------------/ 1 10X,'CONVERGENCE CRITERIA =',1PD9.1/) IF (IB .GT. NWF) GO TO 17 CALL CGRANGE * * ***** SOLVE EACH DIFFERENTIAL EQUATION IN TURN * WRITE(OUT,14) 14 FORMAT(/20X,' EL',6X,'ED/DELTA',10X,'AZ',11X,'NORM',7X,'DPM') CALL CSOLVE(NWF,DELTA) DP1 = DPM(NWF) JJ = NWF DO 2 J = IB,NWF-1 CALL CDE(J) IF ( FAIL ) RETURN DP = DPM(J)*DSQRT(SUM(J)) IF ( DP1 .GE. DP ) GO TO 2 DP1 = DP JJ = J 2 CONTINUE IF (((NCFG .EQ. 1 .OR. ID .EQ. 0) .AND. DP1 .LT. Z2) .OR. : IC .LE. 0) GO TO 6 * * ***** SOLVE IC DIFFERENTIAL EQUATIONS EACH TIME SELECTING THE * ***** ONE WITH THE LARGEST DPM * DO 4 II =1,IC IF (JJ .EQ. NWF) THEN CALL CSOLVE(NWF,DELTA) FAIL = .FALSE. ELSE CALL CDE(JJ) END IF IF ( FAIL ) RETURN DP1 = DPM(NWF) JJ = NWF DO 5 J = IB,NWF-1 DP = DSQRT(SUM(J))*DPM(J) IF ( DP .LT. DP1 ) THEN JJ = J DP1 = DP END IF 5 CONTINUE IF (DP1 .LT. Z2) GO TO 6 4 CONTINUE 6 CALL ORTHOG CALL CUPDATE PCONV = DPM(NWF) .LE. Z2 .and. DP1 .LE. Z2 12 IF (.NOT. (NCFG .EQ. 1 .OR. ID.EQ.0)) : CALL CDIAG(ETOTAL,ACFG,PCONV) IF (PCONV) GO TO 17 * * ***** IF FUNCTIONS APPEAR TO HAVE CONVERGED,SOLVE EACH AGAIN, IN * ***** TURN, AND TEST AGAIN * 1 CONTINUE WRITE(OUT,8) EL(JJ),DP1 8 FORMAT(/ 6X,34HLEAST SELF-CONSISTENT FUNCTION IS ,A3, 1 27H :WEIGHTED MAXIMUM CHANGE =,1PD10.2) 100 Z2=1.3*Z2 * * ***** OUTPUT FINAL CALCULATIONS * 17 CONTINUE WRITE(PRI,'(/10X,A,F16.8,10X,A,F16.8/)') : 'EC =',EC,'ETOTAL =',ETOTAL * * ***** PUNCH CONFIGURATIONS AND WEIGHTS ON UNIT OUC * WRITE(3,'(//A/)') ' Final Mixing' WRITE(OUC,46) ATOM,TERM,Etarget,ETOTAL,delta,-EKK 46 FORMAT(3X,2A6,4F14.7) WRITE(OUC,'(18(1X,A3))') (EL(J),J=1,NCLOSD) cxi cxi get the sum of wt^2 cxi wtol=0.d0 DO 47 J = 1,NCFG if( j .le. id ) wtol = wtol + wt(j)*wt(j) cxi========================================================== cxi these two lines are used to confine the data for output cxi you can comment out these two lines, and modify the cxi format statement 648 . cxi if( wt(j) .gt. 999.999999 ) wt(j) = 999.999999 if( wt(j) .lt. -99.999999 ) wt(j) = -99.999999 cxi=========================================================== WRITE(3,648) J,CONFIG(J),WT(J),(COUPLE(J,JJ),JJ=1,9) 47 WRITE(OUC,48) CONFIG(J),WT(J),(COUPLE(J,JJ),JJ=1,9) 48 FORMAT(A40,F10.6/9(5X,A3)) 648 FORMAT(I4,2X,A40,F10.6/(6X,9(5X,A3))) WRITE (OUC,'(A)') '****' if( nend .eq. -1 ) then nend = 0 cxi cxi========================================================== cxi cxi if you include the following lines, the output file cxi cfg.out can be used as input file cfg.inp again, cxi cxi The PHOTO program has been modified to fit this cxi format requirement cxi do 55 j=1,nort write(OUC,'(1x,A3,1x,A3)' ) ELORT(j,1),ELORT(J,2) 55 continue WRITE (OUC,'(A)') '****' cxi========================================================== cxi endif CALL CSUMMRY(DELTA) CALL COUTPUT(PRINT,DELTA,Nstart) NIT = NWF - IB + 1 WRITE(PRI, 105) NIT, DP1 105 FORMAT(//10X,'NUMBER OF FUNCTIONS ITERATED =',I6/ 1 10X,'MAXIMUM WEIGHTED CHANGE IN FUNCTIONS =',D10.2) cxi cxi save useful informations seperately, in file phase.out cxi unit = 31 cxi write(31,'(F10.6,F13.7,2F12.6)') : -sngl(ekk),sngl(wtol),sngl(delta),sngl(delta/pi) RETURN END * Jinhua's version without adjusting lagrange multiplier * ------------------------------------------------------------------ * C S O L V E * ------------------------------------------------------------------ * * CSOLVE performs the following tasks: * * 1) Computes the Exchange function, X(r), by calling CXCH. * 2) Redefines the outer region; * * Initialization stage (IX = 0) - first call: * reduce outer region (MAX(NWF) -> M) if step size is too * big (R(I) - R(I-1) > 2/K) and where NJ <= M <= MAX(NWF). * M-NJ is also, by dimensions, bound to be less than 130. * * During SCF-cycle (IX = 1): * find MJ; MP < MJ < M and * X(r)/FK(r) < 0.0025 if R > R(MJ). * This will be used to calculate phase shift. If MJ = M * the X function might be truncated -> warning. * 3) Interpolates X(r) to XH(r), for half the step size, in * the azymptotic region; r(NJ) <= r <= r(M). * 4) Prepares for the Numerov method of solving the * differential equation, both in azymptotic and inner region. * 5) Solves the differential equation, by calling CNMRV. * 6) Calculates the phase shift and renormalization, by using * regular, FC, and irregular, GC, Coulomb functions, as * obtained from RCWFN. Renormalizes the continuumfunction. * 7) Orthogonalize the continuum function. * The following subroutines are called in the different * steps: * 1) CXCH * 5) CNMRV * 6) FGCOUL * * SUBROUTINE CSOLVE(I,DELTA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON /CONTIN/FK(NOD),FH(260),XH(260),rh(260),r2h(260),ph(260), : CD,FL,ZL,ZF,V,NJ,MJ,MP,IX COMMON /COULFG/FKC(NOD),XC(NOD),PDC(NOD),FHC(260),PHC(260),NJM * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1)+1 IP = IBEGIN PI = ACOS(-D1) ED = E(I,I) ekk = -ed eK = SQRT(ekk) AZD = AZ(I) DELTA0 = DELTA IPR = NWF M = MAX(NWF) * * ***** Computes the Exchange function. * CALL XCH(I,3) * * ***** Redefine the outer region. * 678 IF (IX .EQ. 0) THEN 5 IF (eK*(R(M)-R(M-1)) .GT. 1.0D0) THEN M = M-1 CORRECTION: ?? * IF (M .GT. NJ) GO TO 5 IF (M .GT. MP) GO TO 5 END IF IF (M .LT. MAX(NWF)) THEN WRITE(OUT,*) 'Outer region reduced by ',MAX(NWF)-M,'points', : ' in CSOLVE. ' END IF MJ = M print *, ' End of range: ', r(m), ' au.' ELSE 2 IF (ABS(X(MJ)/FK(MJ)) .LT. 0.0025) THEN MJ = MJ-1 IF (MJ .GT. MP) GO TO 2 END IF END IF IF (M-NJ .GE. (130)) THEN WRITE(OUT,*) ' Outer region contains ',M-NJ+1,' points' WRITE(OUT,*) ' Maximum allowed value is (130)' STOP 'In CSOLVE - Too large outer region' END IF IF (MJ .EQ. M .AND. IX.NE.0) THEN WRITE(OUT,'(/1X,A,I4)') : 'WARNING: Outer region may be truncated. M = MJ =',M WRITE(OUT,'(A)') : ' Exchange function not small at M!' ELSE IX = 1 END IF * * ***** Interpolate X in outer region to obtain XH. * ehh = exp(h/2.d0) e2hh = exp(h/4.d0) JH = 1 DO 3 J = NJ,M XH(JH) = X(J) rh(jh) = r(j) r2h(jh) = r2(j) XH(JH+1) = (9.*(X(J)+X(J+1)) -X(J-1)-X(J+2))/D16 rh(jh+1) = r(j)*ehh r2h(jh+1) = r2(j)*e2hh JH = JH + 2 3 CONTINUE * * ***** Prepare for Numerovs method. * ***** i) Compute the RHS of the Numerov equation for the outer region * CHH = CH/D4 JH = JH-2 X1 = XH(1) X2 = XH(2) DO 4 J = 2,JH X3 = XH(J+1) XH(J) = CHH*(X1 + D10*X2 +X3) X1 = X2 X2 = X3 4 CONTINUE * * ***** ii) Compute the RHS of the Numerov equation * XY = X(1) XP = X(2) X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) DO 1 J = 3,NJ X5 = X(J+2) X(J) =CH*(-X5+24.D0*(X4+X2) + 194.D0*X3 - X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 1 CONTINUE * * ***** iii) Add the deferred difference correction to the exchange * ***** for the outward integration region * X1 = P(1,I)*FK(1) X2 = P(2,I)*FK(2) X3 = P(3,I)*FK(3) X4 = P(4,I)*FK(4) DO 7 J = 3,NJ X5 = P(J+2,I)*FK(J+2) X(J) = X(J) - (X5 -D4*(X2 + X4) + D6*X3 +X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 7 CONTINUE RL = L(I) + 2.5 X(2) = R(2)**RL*(X(5)/R(5)**RL - D3*(X(4)/R(4)**RL - : X(3)/R(3)**RL)) * * ***** iv) Compute starting values from series expansion * CC = D2*FL + D3 A2 = (V + ED/D2 + ZL*Z)/CC A3 = -((V + ED/D2)*ZL + Z*A2)/(D3*(FL+D2)) DO 6 J = 1,2 6 PDE(J) = AZ(I)*R(J)**L(I)*R2(J)* : (R(J)*(R(J)*(R(J)*A3 + A2) -ZL) +D1) PDE(1) = PDE(1) + XY/(D2*CC) PDE(2) = PDE(2) + XP/(D2*CC) * * ***** Solve the differential equation. * CALL CNMRV(NJ,M,1,AZ(I),FK,X,FH,XH,PH,PDE) CALL FGCOUL(I,M,CN,DELTA) cxi cxi note: the sign of the overlop depends on cn, cxi because we need to adjust the off-diagonal parameters cxi repeatedly to find a zero overlap, we can not change the sign of cxi the wavefunction cxi so, save the sign in cnn cxi if( cn .lt. 0.d0 ) then cnn = -1.d0 cn = - cn else cnn = 1.d0 endif * * ***** Renormalise. * DO 92 J = 1,M PDE(J) = PDE(J)*CN 92 CONTINUE AZ(I)=CN*AZ(I) DO 13 J = 1,M DIF = P(J,I) - PDE(J) P(J,I) = PDE(J) + acc(i)*dif 13 CONTINUE AZ(I) = (1.d0 - acc(i))*AZ(i) + acc(i)*AZD cxi cxi if the acc(i) is used, the wavefunction needs to be cxi re-normalized cxi MAX(I) = M * * ***** Orthogonalize the continuum function * 50 JI = IJE(IP) IF ( JI .NE. I) THEN CC = QUADR(I,JI,0) cxi cxi the first orthogonal requirements, use new approach cxi if( e(i,ji) .eq. 0.d0 .or. dabs(cc) .lt. 1.d-7) goto 65 AZ(I) = AZ(I) - CC*AZ(JI) DO 51 J = 1,M P(J,I) = P(J,I) - CC*P(J,JI) 51 CONTINUE 65 WRITE(OUT,63) EL(JI),EL(I),CC 63 FORMAT(6X,'<',A3,'|',A3,'>=',1PD8.1 ) c cxi re-normalize the wavefunction cxi cnn= cnn*pde(M)/P(M,i) Az(i) = cnn*Az(i) do 52 j = 1,m p(j,i) = cnn*p(j,i) 52 continue cxi cxi normalize the off diagonal parameters cxi IP = IP+1 IF (IP .LE. IEPTR(I)) GO TO 50 END IF * VARIED(I) = .TRUE. DP = ABS((delta0-delta)/delta) DPM(I) = DP WRITE(OUT,17) EL(I),DELTA,AZ(I),CN,'c',DP 17 FORMAT(20X,A3,2F15.7,F12.7,A2,1PD10.2) return END C C ------------------------------------------------------------------ C 3-35 C S U M M R Y C ------------------------------------------------------------------ C C The results of a calculation are summarized. These include C the following for each electron: C C E(NL) - diagonal energy parameter C AZ(NL) - starting parameter, P(r)/r**(l+1) as r -> 0. C SIGMA - screening parameter as defined by Eq. (6- ). C 1/R**3 - expected value of <1/r**3> C 1/R - expected value of <1/r> C R - expected mean radius C R**2 - expected value of C I(NL) - -(1/2) C KE - I(NL) + Z C REL - Relativistic shift (mass-velocity, Darwin term, C spin-spin contact term) C C These results are followed by: C C TOTAL ENERGY--RELATIVISTIC OR NON-RELATIVISTIC (ET) C KINETIC ENERGY-- NON-RELATIVISTIC (EN) C POTENTIAL ENERGY (EP) = ET - EN C RATIO = - EP/EN C k k k C The values of all F , G , R and integrals which enter C into the calculation are printed, but only if OUD > 0. C C SUBROUTINE CSUMMRY(DELTA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON R3(NWD),SS(3),R1,RM,RMM,RH,R0,QI,QJ,SP,C,CC, 1 EKINP,EN,EPOT,RATIO,LI,LJ,K,KF,I1,I2,J1,J2,I,J,MIN CHARACTER*1 SYMBOL * WRITE(PRI,9) ATOM,TERM 9 FORMAT(/// 24X,5HATOM ,A6,3X,5HTERM ,A6//45X,13HMEAN VALUE OF, 1 /3X,2HNL,9X,5HE(NL),9X,6HAZ(NL), 2 4X,5H R0 ,6X,3H1/R, 9X,1HR, 6X, 3 11HI(NL)/DELTA,5X,3HREL) EN = D0 C C ***** COMPUTE AND PRINT ONE-ELECTRON PARAMETERS C DO 10 I = 1,NWF R0 = D1 R1 = D0 RM = D0 EK = DELTA S(I) = D0 IF (METH(I) .NE. 4) THEN R0 = QUADR(I,I,0) R1 = QUADR(I,I,-1)/R0 RM = QUADR(I,I,1)/R0 EK = -D5*HL(EL,I,I,REL)/R0 END IF RELS = RLSHFT(I,I)/R0 WRITE(PRI,15)EL(I),E(I,I),AZ(I),R0,R1,RM,EK,RELS 15 FORMAT( 2X,A3,F14.7,F15.7,F10.5,F11.5,F10.5,F11.6,2F13.6) 10 CONTINUE C C ***** PRINT TABLES OF 'FK' AND 'GK' INTEGRALS WHICH WERE USED IN C ***** DETERMINING THE ENERGY C IF ( OUD .EQ. 0 ) GO TO 13 WRITE (OUD,126) 126 FORMAT(//2X,27HVALUES OF F AND G INTEGRALS //) IBEGIN = 1 IEND = INTPTR(2) DO 17 I = IBEGIN,IEND SYMBOL = 'F' IF (I .GT. INTPTR(1)) SYMBOL = 'G' 17 WRITE(OUD,19) SYMBOL,KVAL(I),EL(IEL(I,1)),EL(IEL(I,2)),VALUE(I) 19 FORMAT( 2X,A1,I2,1H(,A3,1H,,A3,4H ) =, F10.7) C C ***** PRINT TABLES OF 'RK' INTEGRALS C WRITE (OUD,21) 21 FORMAT(//2X,21HVALUES OF R INTEGRALS //) IBEGIN = INTPTR(4) + 1 IEND = INTPTR(5) DO 22 I = IBEGIN,IEND I1 = IEL(I,1) I2 = IEL(I,2) J1 = IEL(I,3) J2 = IEL(I,4) 22 WRITE (OUD,23) KVAL(I),EL(I1),EL(I2),EL(J1),EL(J2),VALUE(I) 23 FORMAT(2X,1HR,I2,1H(,2A3,1H,, 2A3,3H) =, F11.7 ) C C ***** PRINT TABLES OF 'L' INTEGRALS C WRITE (OUD,28) 28 FORMAT(//2X,21HVALUES OF L INTEGRALS //) IBEGIN = IEND + 1 IEND = INTPTR(6) DO 29 I = IBEGIN,IEND 29 WRITE(OUD,30) EL(IEL(I,1)),EL(IEL(I,2)),VALUE(I) 30 FORMAT(2X,2HL(,A3,1H,,A3,4H) = ,F12.7) 13 RETURN END * ------------------------------------------------------------------ * C U P D A T E * ------------------------------------------------------------------ * SUBROUTINE CUPDATE IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR LOGICAL CHANGE * IBEGIN = 1 IEND = INTPTR(3) DO 1 I = IBEGIN,IEND * Omit if one of the orbitals is a continuum orbital. * Value(i) should remain zero in this case * IF (IEL(I,1) .EQ. NWF .OR. IEL(I,2) .EQ. NWF) GO TO 1 IF (VARIED(IEL(I,1)) .OR. VARIED(IEL(I,2))) THEN IF (I .LE. INTPTR(1)) THEN VALUE(I) = FK(IEL(I,1),IEL(I,2),KVAL(I),REL) ELSE IF (I .LE. INTPTR(2)) THEN VALUE(I) = GK(IEL(I,1),IEL(I,2),KVAL(I),REL) ELSE VALUE(I) = QUADR(IEL(I,1),IEL(I,2),0)**KVAL(I) END IF END IF 1 CONTINUE * IBEGIN = IEND + 1 IEND = INTPTR(4) DO 30 I = IBEGIN,IEND CHANGE = .FALSE. DO 31 J = 1,4 CHANGE = CHANGE .OR. VARIED(IEL(I,J)) 31 CONTINUE IF (CHANGE) THEN K1 = KVAL(I)/64 K2 = KVAL(I) - 64*K1 VALUE(I) = QUADR(IEL(I,1),IEL(I,2),0)**K1 : *QUADR(IEL(I,3),IEL(I,4),0)**K2 END IF 30 CONTINUE IBEGIN = IEND + 1 IEND = INTPTR(5) DO 10 I = IBEGIN,IEND CHANGE = .FALSE. DO 11 J = 1,4 CHANGE = CHANGE .OR. VARIED(IEL(I,J)) 11 CONTINUE IF (CHANGE) VALUE(I) : = RK(IEL(I,1),IEL(I,2),IEL(I,3),IEL(I,4),KVAL(I),REL) 10 CONTINUE * IBEGIN = IEND + 1 IEND = INTPTR(6) DO 20 I = IBEGIN,IEND IF (IEL(I,1) .EQ. NWF .OR. IEL(I,2) .EQ. NWF) GO TO 20 IF (VARIED(IEL(I,1)) .OR. VARIED(IEL(I,2))) : VALUE(I) = HLC(EL,IEL(I,1),IEL(I,2),REL) 20 CONTINUE * * ... Test if any of the core functions have changed * CHANGE = .FALSE. DO 35 I = 1,NCLOSD CHANGE = CHANGE .OR. VARIED(I) 35 CONTINUE IF (CHANGE .OR. EC.EQ.D0) CALL ECORE(EL,EC,REL) * DO 40 I = 1,NWF VARIED(I) = .FALSE. 40 CONTINUE * print *, ' Values of Integrals' * do 100 i = 1, intptr(6) * print *, i, (iel(i,j),j=1,4), value(i) *100 continue * print *, ' Value of EC =', ec END DOUBLE PRECISION FUNCTION COEF(INT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * * COEF = 0.D0 IBEGIN = 1 IF (INT .GT. 1) IBEGIN = CPTR(INT-1)+1 IEND = CPTR(INT) DO 1 II = IBEGIN,IEND T = WT(IH(II))*WT(JH(II))*COEFF(II) IF (OPTR(II).NE.0) T = T*VALUE(OPTR(II)) IF (IH(II) .NE. JH(II)) T = T+T COEF = COEF+T 1 CONTINUE END DOUBLE PRECISION FUNCTION COV(M) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * COV = 0.D0 IBEGIN = INTPTR(4)+1 IEND =INTPTR(6) DO 10 I = IBEGIN,IEND JBEGIN = CPTR(I-1)+1 JEND = CPTR(I) DO 12 J = JBEGIN,JEND IF ( OPTR(J) .EQ. M) THEN CC = COEFF(J)*WT(IH(J))*WT(JH(J))*VALUE(I) IF (IH(J) .NE. JH(J)) CC = 2*CC COV = COV + CC END IF 12 CONTINUE 10 CONTINUE END C C ------------------------------------------------------------------ C 3-6 D I F F C ------------------------------------------------------------------ C C C Stores LP in the array YK. The difference approximation of C i C Eq. (6-14) is used. C C SUBROUTINE DIFF(I) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * C ***** FORM DD + 2Z/R -L(L+1)/RR|P(I)> C MM = MAX(I) - 3 FL = L(I) TWOZ = Z + Z C = (FL+D5)**2 HH = 180.D0*H*H DO 11 K = 4,MM 11 YK(K) = (D2*(P(K+3,I)+P(K-3,I)) - 27.D0*(P(K+2,I)+P(K-2,I)) + 1 270.D0*(P(K+1,I)+P(K-1,I)) - 490.D0*P(K,I))/HH + 2 P(K,I)*(TWOZ*R(K) - C) C C ***** BECAUSE OF THE POSSIBILITY OF EXTENSIVE CANCELLATION NEAR THE C ***** ORIGIN, SEARCH FOR THE POINT WHERE THE ASYMPTOTIC BEHAVIOUR C ***** BEGINS AND SMOOTH THE ORIGIN. C LEXP = L(I) + 2 Y1 = YK(4)/R2(4)/R(4)**LEXP Y2 = YK(5)/R2(5)/R(5)**LEXP DO 1 K = 4,100 KP = K+2 Y3 = YK(KP)/R2(KP)/R(KP)**LEXP IF (Y2 .EQ. D0) GO TO 1 IF (DABS(Y1/Y2 - D1) .LT..1D0 .OR. DABS(Y3/Y2 - D1) .LT..1D0) 1 GO TO 2 Y1 = Y2 Y2 = Y3 1 CONTINUE WRITE(OUT,3) I 3 FORMAT(6X, 'ASYMPTOTIC REGION NOT FOUND FOR FUNCTION NUMBER',I3) STOP C C ***** ASYMPTOTIC REGION HAS BEEN FOUND C 2 KP = K KM = KP - 1 DO 4 K = 1,KM 4 YK(K) = Y1*R2(K)*R(K)**LEXP MM = MM + 1 YK(MM) = (-(P(MM+2,I)+P(MM-2,I)) + D16*(P(MM+1,I)+P(MM-1,I)) 1 -D30*P(MM,I))/(D12*H*H) + P(MM,I)*(TWOZ*R(MM) - C) MM = MM + 1 YK(MM) = (P(MM+1,I) + P(MM-1,I) - D2*P(MM,I))/(H*H) + 1 P(MM,I)*(TWOZ*R(MM) - C) MM = MM+1 DO 5 K =MM,NO 5 YK(K) = D0 RETURN END DOUBLE PRECISION FUNCTION E(I,J) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1) + 1 IEND = IEPTR(I) E = 0.D0 DO 10 II = IBEGIN,IEND IF (IJE(II) .EQ. J) THEN E = EIJ(II) RETURN END IF 10 CONTINUE END SUBROUTINE EIJSET(I,J,E) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * IBEGIN = 1 IF (I .GT. 1) IBEGIN = IEPTR(I-1)+1 IEND = IEPTR(I) DO 10 II = IBEGIN,IEND IF (IJE(II) .EQ. J) THEN EIJ(II) = E RETURN END IF 10 CONTINUE * * ***** J-value not found - enter into list * IF (IJE(98) .NE. 0) : STOP ' Too many off-diagonal energy parameters' * * ***** Find point at which the insertion should be made * IEND = IEPTR(I) IF (IEND .NE. 0) THEN IP = 1 IF (I .GT. 1) IP = IEPTR(I-1)+1 30 IF (IJE(IP) .LT. J .AND. IP .LE. IEND) THEN IP = IP + 1 GO TO 30 END IF ELSE IP = 1 END IF * * ***** IP is the location in which EIJ should be stored * Move other data * DO 40 JJ = (98)-1,IP,-1 IJE(JJ+1) = IJE(JJ) EIJ(JJ+1) = EIJ(JJ) 40 CONTINUE * * ***** Space has been made - insert data * IJE(IP) = J EIJ(IP) = E * * ***** Update pointers * DO 50 II = I,NWF IEPTR(II) = IEPTR(II) +1 50 CONTINUE END SUBROUTINE INTGRL IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * CHARACTER END*1, EL1*3, EL2*3, EL3*3, EL4*3 * 1 FORMAT(1X,A1,I2,1X,A3,1X,A3,1X,I5) 2 FORMAT(1X,A1,I2,1X,2A3,1X,2A3,1X,I5) 3 FORMAT(1X,A1,I2,1X,A3,1X,A3,2X,I2,1X,A3,1X,A3,I5) 4 FORMAT(F14.8,A1,2I3,I3) C C ***** READ THE LIST OF INTEGRALS C LAST = 0 IC = 1 I = 1 READ(IUD,'()') DO 10 INT = 1,6 IF (INT.NE.4 .AND. INT.NE.5) THEN * * ...F, G, L, or O1 integrals.... * 12 READ(IUD,1) END, KVAL(I), EL1, EL2, ICPTR IF (END .EQ. '*') GO TO 16 IF (ICPTR+LAST .LE. (NCDIM)) THEN CPTR(I) = ICPTR + LAST ELSE PRINT *,' Too much data - current dimensions =',NCDIM STOP END IF CALL EPTR(EL, EL1,IEL(I,1),*999) CALL EPTR(EL, EL2,IEL(I,2),*999) I = I + 1 IF (I .LE. (IDIM) ) GO TO 12 PRINT *, ' Too many integrals - MAX =',IDIM STOP ELSE 14 IF (INT.EQ.5) THEN * * ... R integrals ... * READ(IUD,2) END, KVAL(I), EL1, EL2, EL3, EL4, ICPTR * ELSE * * ... O2 integrals ... * READ(IUD, 3) END, K1, EL1, EL2, K2, EL3, EL4 KVAL(I) = 64*K1 + K2 END IF IF (ICPTR+LAST .LE. (NCDIM)) THEN CPTR(I) = ICPTR + LAST ELSE STOP ' Too much data - current dimensions = (NCDIM)' END IF * IF ( END .EQ. '*') GO TO 16 CALL EPTR(EL, EL1, IEL(I,1), *999) CALL EPTR(EL, EL2, IEL(I,2), *999) CALL EPTR(EL, EL3, IEL(I,3), *999) CALL EPTR(EL, EL4, IEL(I,4), *999) I = I + 1 IF (I .LE. (IDIM) ) GO TO 14 STOP ' Too many integrals - MAX = (IDIM)' END IF 16 IF (INT .EQ. 3 .OR. INT .EQ. 4) GO TO 18 * * ... Read the data ... * 20 READ(IUD,4) COEFF(IC), END, IH(IC), JH(IC), OPTR(IC) IF ( END .NE. '*') THEN IF (INT .LE. 2) THEN COEFF(IC) = ACURAT(COEFF(IC)) ELSE * * ... Shift origin for overlap integrals * IF (OPTR(IC).LT.0) THEN OPTR(IC) = INTPTR(3) - OPTR(IC) ELSE IF (OPTR(IC).GT.0) THEN OPTR(IC) = INTPTR(2) + OPTR(IC) END IF END IF IC = IC + 1 GO TO 20 END IF * * ... Initialize for next set .. * 18 INTPTR(INT) = I-1 LAST = IC-1 10 CONTINUE RETURN * 999 PRINT *,' Electron in ',END,'-data not found in ', : 'configuration data' STOP END * * ------------------------------------------------------------------ * 3-19 M E T H O D * ------------------------------------------------------------------ * * Uses M1, M2, or M3 to solve the radial equation. If the input * data indicated METH(I) = 3, then this solution is returned to * DE. Otherwise, the routine searches for an acceptable solution * which is both positive near the origin and has the required * number of nodes. * * SUBROUTINE METHD1(I) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * COMMON P2(NOD),HQ(NOD),XX(NOD),AC(20,20),BC(20),JV(20), : AZZ,PP,FN,EM,FM,EU,FU,DELTAE,M,NODE,MK,KK,NJ * LOGICAL V2, FIRST DIMENSION P1(NOD) EQUIVALENCE (PDE(1),P1(1)) * * ***** 'FIRST' MUST BE 'TRUE' THE FIRST TIME SOLVE IS CALLED FOR * ***** POTENTIAL AND EXCHANGE TO BE COMPUTED * ***** 'EU' IS THE UPPER BOUND OF THE ENERGY PARAMETER * ***** 'EM' IS THE MINIMUM VALUE OF THE ENERGY PARAMETER * FIRST = .TRUE. FAIL = .FALSE. EM = D0 EU = ((Z - DMIN1(D5*S(I),D2*S(I)))/N(I))**2 FU = EU MK = 0 17 CALL SOLVE(I,FIRST) * * ***** IF KK EQUALS 3, OMIT THE NODE CHECKING * IF (KK .GE. 3) GO TO 51 * * ***** COUNT THE NUMBER OF NODES * MN = M NC = NODEC(MN) IF (TRACE) WRITE(OUT,99) EL(I),NC,MN,NJ,PDE(MN),ED,EU,EM,DELTAE 99 FORMAT(2X,A3,' NC =',I3,' MN =',I3,' NJ =',I3,' PDE(MN) =', 1 D10.2,' ED =',D10.2,' EU =',D10.2,' EM =',D10.2, 2 ' DELTAE =',D10.2) * * ***** IF NODE COUNT IS OFF BY NO MORE THAN 1 AND DELTAE IS STILL * ***** QUITE LARGE, APPLY THE DELTAE CORRECTION * IF (IABS(NC-NODE) .EQ. 1 .AND. DABS(DELTAE/ED) .GT. 0.02D0) 1 GO TO 46 * * ***** BRANCH ACCORDING TO WHETHER THE NODE COUNT IS TOO SMALL, * ***** JUST RIGHT, OR TOO LARGE * 12 IF (NC - NODE ) 8,9,10 * * ***** THE SOLUTION HAS THE CORRECT NUMBER OF NODES * 9 V2 = DABS(DELTAE)/ED .LT. 1.D-5 IF (PDE(MN) .LT. D0 .AND. .NOT. V2) GO TO 46 IF (PDE(MN) .GT. D0) GO TO 51 DO 52 J = 1,NO 52 PDE(J) = - PDE(J) PP = -D2 - PP 51 AZZ = AZD*(D1 + PP) IF (KK .LE. 3) CALL EIJSET(I,I,ED) RETURN * * ***** THE SOLUTION HAS TOO FEW NODES * 8 IF (PDE(MN) .LE. D0) GO TO 11 DEL = D1 - ED/EU EU = ED IF ( DEL .LT. .05D0) FU = FU*((L(I)+1+NC)/FN)**2.5 IF (DEL .GE. .05D0) FU = ED*((L(I)+1+NC)/FN)**2.5 IF (FU .LT. EM) FU = D5*(EU + EM) IF (DABS(FU - ED) .LT. 0.001D0) GO TO 27 ED = FU GO TO 33 * * ***** TRY A NEW VALUE OF ED WHICH MUST LIE WITHIN THE UPPER AND * ***** LOWER BOUND * 11 EDP = ED ED = ED*((L(I)+1+NC)/FN)**2.5 IF (ED .GE. EU ) ED = D5*(EU + EDP) IF (ED .LE. EM ) ED = D5*(EM + EDP) 33 MK = MK + 1 IF ( EU .LE. EM ) WRITE(OUT,30) EM,EU,ED 30 FORMAT(6X,48HWARNING: DIFFICULTY WITH NODE COUNTING PROCEDURE/ 1 6X,42HLOWER BOUND ON ED GREATER THAN UPPER BOUND/ 2 6X,5HEL = ,F10.6,7H EU = ,F10.6,7H ED = ,F10.6) FIRST = .FALSE. IF ( MK .GT. 3*N(I) .OR. EU-EM .LT. FN**(-3)) GO TO 27 GO TO 17 * * ***** THE SOLUTION HAS TOO MANY NODES * 10 IF (PDE(MN) .LT. D0) GO TO 11 DEL = D1 - EM/ED EM = ED IF (DEL .LT. 0.05D0) FM = FM*((L(I)+1+NC)/FN)**2.5 IF (DEL .GE. 0.05D0) FM = ED*((L(I)+1+NC)/FN)**2.5 IF (FM .GT. EU) FM = D5*(EU + EM) IF (DABS(FM - ED) .LT. 0.001D0) GO TO 27 ED = FM GO TO 33 * * ***** ADJUST ENERGY TO LIE BETWEEN UPPER AND LOWER BOUND * 46 ED = ED - DELTAE IF ( ED .GE. EM .AND. ED .LE. EU ) GO TO 33 EDP = ED IF ( NC-NODE .NE. 0 ) ED = (ED+DELTAE)*((L(I)+1+NC)/FN)**2.5 IF ( ED .GE. EM .AND. ED .LE. EU ) GO TO 33 ED = EDP + DELTAE + DELTAE IF ( ED .GE. EM .AND. ED .LE. EU ) GO TO 33 ED = ED -DELTAE DELTAE = D5*DELTAE GO TO 46 * * ***** METHOD WAS UNABLE TO FIND AN ACCEPTABLE SOLUTION * 27 WRITE(OUT,28) KK,EL(I),NC,NJ,ED,EM,EU 28 FORMAT(10X,6HMETHOD,I2,38H UNABLE TO SOLVE EQUATION FOR ELECTRON, 1 A3/10X,5HNC = ,I3,3X,5HNJ = ,I3,3X,5HED = ,F10.6,3X,5HEL = , 2 F10.6,3X,5HEU = ,F10.6) FAIL = .TRUE. RETURN END C C C ------------------------------------------------------------------ C 3-20 N M R V S C ------------------------------------------------------------------ C C Given two starting values, PDE(1) and PDE(2), values of PDE(j), C j=3,4,...,NJ+1 are obtained by outward integration of C Y" = YR y + F C using the discretization of Eq. (6-27 ) with the difference C correction. With PDE(NJ) given, the tail procedure is applied to C PDE(j),j=NJ+1, NJ+2,...,MM, where MM is determined automatically C and DELTA is the difference between PDE(NJ+1) for outward and C inward integration. (See Eq 6-32, 6-33, and 6-37 for further C details.) C C SUBROUTINE NMRVS(NJ,DELTA,MM,PP,F) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * DIMENSION PP(NOD),F(NOD),A(150),D(150) EQUIVALENCE (G,G3) C C ***** INTEGRATE OUTWARD TO NJ+1 C Y1 = PP(1) Y2= PP(2) G1 = YR(1) G2 = YR(2) M = NJ + 1 DO 1 I = 3,M G3 = YR(I) Y3 = (Y2+Y2-Y1 + (D10*G2*Y2 + G1*Y1) + F(I-1)) / (D1 - G3) PP(I) = Y3 Y1 = Y2 Y2 = Y3 G1 = G2 1 G2 = G3 DELTA = Y3 C C ***** APPLY THE TAIL PROCEDURE C K = 1 PP(M) = -(D1 - G1)*Y1 + F(M) A(1) = D1 - G D(1) = -(D2 + D10*G) 22 RATIO = A(K)/D(K) C C ***** THE INTEGER 149 IN THE NEXT STATEMENT IS THE DIMENSION OF A C ***** MINUS 1 C IF (K .GE. (150)-1 .OR. M .EQ. ND) GO TO 23 K = K +1 M = M+1 G = YR(M) A(K) = D1 - G D(K) = -(D2 + D10*G) - A(K)*RATIO PP(M) = -PP(M-1)*RATIO + F(M) IF (DABS(PP(M))+DABS(PP(M-1)) .GT. TOL .OR. K .LT. 9 : .OR. M .LT. 120) GO TO 22 20 CON =DSQRT(EH)*DEXP(-DSQRT(DABS(G/CH-.25)/RR(M))*(R(M+1)-R(M))) PP(M) = PP(M)/(D(K) + CON*(D1- YR(M+1))) J = M+1 DO 2 I= J,NO 2 PP(I) = D0 DO 3 J = 2,K I = M-J+1 II = K-J+1 3 PP(I) = (PP(I)-A(II+1)*PP(I+1))/D(II) C C ***** SET DELTA = DIFFERENCE OF THE TWO SOLUTIONS AT NJ+1 C ***** MM = NUMBER OF POINTS IN THE RANGE OF THE SOLUTION C DELTA = DELTA - PP(I) MM = M RETURN 23 WRITE(OUT,24) 24 FORMAT(6X,52HWARNING: FUNCTIONS TRUNCATED BY NMRVS IN TAIL REGION) GO TO 20 END C C ------------------------------------------------------------------ C 3-21 N O D E C C ------------------------------------------------------------------ C C Counts the number of nodes of the function PDE(j) in the range C j = 40,...,M-10. The node counting procedure counts the local max C and min values. Only nodes between sufficiently large max and C min values are counted. C C FUNCTION NODEC(M) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR C C ***** FIND MAX|PDE(J)| C MM = M - 10 DM = 0.D0 DO 1 J = 40,MM 1 DM = DMAX1(DM, DABS(PDE(J))) C C ***** COUNT THE NUMBER OF LOCAL MAX OR MIN'S C NCC = 0 SIGN = 0.D0 DIFF1 = PDE(40) - PDE(39) DO 2 J = 40, MM DIFF2 = PDE(J+1) - PDE(J) IF (DIFF2*DIFF1 .GT. 0.D0 .OR. DIFF1 .EQ. 0.D0) GO TO 2 C C ***** A MAX OR MIN HAS BEEN FOUND. TEST IF IT IS C SUFFICIENTLY LARGE C IF ( DABS(PDE(J))/DM .LT. 0.05D0 ) GO TO 2 C C ***** CHECK IF THIS IS THE FIRST SIGNIFICANT MAXIMUM C IF (SIGN .NE. 0.D0 ) GO TO 4 M = J GO TO 3 C C ***** IF NOT THE FIRST, TEST WHETHER A SIGN CHANGE HAS C OCCURRED SINCE THE LAST SIGNIFICANT MAX OR MIN C 4 IF (PDE(J)*SIGN .GT. 0.D0 ) GO TO 2 NCC = NCC + 1 C C ***** RESET FOR THE NEXT NODE C 3 SIGN = PDE(J) 2 DIFF1 = DIFF2 NODEC = NCC RETURN END * * ------------------------------------------------------------------ * O R T H O G * ------------------------------------------------------------------ * * This routine orthogonalizes the set of radial functions when an * orthogonality constraint applies. A Gram-Schmidt type of process * is used. When more than one radial function with a given (nl) is * present, it may be necessary to solve a 2x2 system of equations. * * SUBROUTINE ORTHOG IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL DIAG COMMON AC(20,20),BC(20) * IF (NWF .EQ. 1 .OR. IB .GT. NWF) RETURN II = MAX0(2,IB) DO 2 I = II,NWF DIAG = .TRUE. IBEGIN = IEPTR(I-1)+1 IP = IBEGIN IJ = 0 60 JV = IJE(IP) IF (JV .LT. I .AND. IP .LE. IEPTR(I)) THEN IJ = IJ+1 IF ( IJ .GT. (NWD)) : STOP ' TOO MANY ORTHOGONALITY CONDITIONS' BC(IJ) = QUADR(I,JV,0) AC(IJ,IJ) = D1 DO 62 JJ = IBEGIN,IP-1 IK = JJ - IBEGIN + 1 IF (E(IJE(IP),IJE(JJ)) .NE. D0 ) THEN AC(IJ,IK) = D0 AC(IK,IJ) = D0 ELSE AC(IJ,IK) = QUADR(IJE(IP),IJE(JJ),0) AC(IK,IJ) = AC(IJ,IK) DIAG = .FALSE. END IF 62 CONTINUE IP = IP+1 GO TO 60 END IF IF ( IJ .GT. 0) THEN IF ( .NOT. DIAG .AND. IJ.GT.1) CALL LINEQN(20,IJ,AC,BC) M = MAX(I) AZZ = AZ(I) IP = IBEGIN CTOTAL = D0 DO 65 JJ = 1,IJ C = BC(JJ) IF (DABS(C) .GT. 1.D-10) THEN WRITE(OUT,63) EL(IJE(IP)),EL(I),C 63 FORMAT(6X,'<',A3,'|',A3,'>=',1PD8.1) M = MAX0(M,MAX(IJE(IP))) DO 64 J = 1,M P(J,I) = P(J,I) - C*P(J,IJE(IP)) 64 CONTINUE AZZ = AZZ - C*AZ(IJE(IP)) END IF IP = IP + 1 CTOTAL = CTOTAL + ABS(C) 65 CONTINUE IF (CTOTAL .GT. 1.D-10 ) THEN c c only for bound orbitals c if( e(i,i) .gt. d0 ) then PNN = DSQRT(QUADR(I,I,0)) DO 66 JJ = 1,M P(JJ,I) = P(JJ,I)/PNN 66 CONTINUE AZZ = AZZ/PNN M = NO 67 IF (DABS(P(M,I)) .LT. 1.D-15) THEN P(M,I) = D0 M = M-1 GO TO 67 END IF MAX(I) = M endif AZ(I) = AZZ VARIED(I) = .TRUE. END IF END IF 2 CONTINUE END C C ------------------------------------------------------------------ C 3-24 P O T L C ------------------------------------------------------------------ C C Computes and stores the potential function C 2(k-1) C YR = SUM a Y (j,j;r) C j,k ijk C SUBROUTINE POTL(I) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * DO 1 J=1,NO 1 YR(J) = D0 DO 2 J = 1,NWF IF (I.GT.NCLOSD .AND. J.GT.NCLOSD) GO TO 2 C = SUM(J) IF ( I.EQ.J ) C = C - D1 CALL YKF(J,J,0,REL) DO 3 JJ = 1,NO YR(JJ) = YR(JJ) + C*YK(JJ) 3 CONTINUE IF ( I.EQ.J .AND. L(I) .GT. 0) THEN DO 4 K = 2,2*L(I),2 CC = -C*CA(L(I),K) CALL YKF(I,I,K,REL) DO 5 JJ = 1,NO YR(JJ) = YR(JJ) + CC*YK(JJ) 5 CONTINUE 4 CONTINUE END IF 2 CONTINUE * SUMI = SUM(I) IBEGIN = 1 IEND = INTPTR(1) DO 10 J = IBEGIN,IEND IE = 0 IF (IEL(J,1) .EQ. I) THEN IE = IEL(J,2) ELSE IF (IEL(J,2) .EQ. I) THEN IE = IEL(J,1) END IF IF (IE .NE. 0) THEN C = COEF(J)/SUMI IF (IEL(J,1) .EQ. IEL(J,2)) C = 2*C CALL YKF(IE,IE,KVAL(J),REL) DO 12 JJ = 1,NO YR(JJ) = YR(JJ) + C*YK(JJ) 12 CONTINUE END IF 10 CONTINUE END C C ------------------------------------------------------------------ C 3-25 Q U A D C ------------------------------------------------------------------ C C Evaluates the integral of F(r)G(r) with respect to r , where C F(r) and G(r) have the same asymptotic properties as P (r). The C i C composite Simpson's rule is used. The integrand is zero for r > C r . C M C DOUBLE PRECISION FUNCTION QUAD(I,M,F,G) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * DIMENSION F(220),G(220) * D = (D1 + D5*Z*R(1))/(H1*(2*L(I) + 3)) QUAD = RR(1)* F(1)*G(1)*( D -D5) QUAD2 = D0 DO 1 J = 2,M,2 QUAD = QUAD + RR(J-1)*F(J-1)*G(J-1) QUAD2 = QUAD2 + RR(J)*F(J)*G(J) 1 CONTINUE QUAD = H1*(QUAD + D2*QUAD2) RETURN END * * -------------------------------------------------------------------- * R E O R D * -------------------------------------------------------------------- * * Reorder the list of first appearance so that the functions to be * iterated appear last in the list. * SUBROUTINE REORD(OF, ELC, NWF, IERR) PARAMETER (NWD=30) CHARACTER*3 OF(NWD), ELC * IERR = 1 CALL EPTR(OF, ELC, I, *99) DO 10 J = I, NWF-1 OF(J) = OF(J+1) 10 CONTINUE OF(NWF) = ELC IERR = 0 99 RETURN END C C ------------------------------------------------------------------ C 3-32 S E A R C H C ------------------------------------------------------------------ C C This routine searches for the NJ>70 such that YR(j) > 0 for all C j > NJ. C C SUBROUTINE SEARCH(NJ,I) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (NWD=30,NOD=220) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * IA = 70 IL = NO 4 IF (YR(IA) .LT. D0) GO TO 3 IA = IA + 2 IF (IA .LT. IL ) GO TO 4 NJ = MAX0(70,MAX(I)-100) RETURN 3 NK = (IA + IL)/2 IF (YR(NK) .LT. D0) GO TO 1 IL = NK GO TO 2 1 IA = NK 2 IF (IL - IA .GT. 1) GO TO 3 NJ = IL - 7 RETURN END * * --------------------------------------------------------------------- * S E T O R T * --------------------------------------------------------------------- * LOGICAL FUNCTION SETORT(EL1,EL2) CHARACTER*3 EL1,EL2 CHARACTER*1 S1, S2 C IF (EL1(1:1) .EQ. ' ') THEN S1 = ' ' ELSE S1 = EL1(3:3) END IF IF (EL2(1:1) .EQ. ' ') THEN S2 = ' ' ELSE S2 = EL2(3:3) END IF C IF (S1 .EQ. ' ' .OR. S2 .EQ. ' ') THEN SETORT = .TRUE. ELSE IF (S1 .EQ. S2) THEN SETORT = .TRUE. ELSE SETORT = .FALSE. END IF RETURN END * * ------------------------------------------------------------------ * 3-34 S O L V E * ------------------------------------------------------------------ * * When FIRST is .TRUE., SOLVE computes the potential and exchange * function and initializes variables for the i'th radial equation. * The vector P1 is the solution of the radial equation and P2 the * variation of the solution with respect to the energy parameter * E(I,I). * * SUBROUTINE SOLVE(I,FIRST) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON P2(NOD),HQ(NOD),XX(NOD),AC(20,20),BC(20),JV(20), : AZZ,PP,FN,EM,FM,EU,FU,DELTAE,M,NODE,MK,KK,NJ * LOGICAL FIRST DIMENSION ZERO(NOD),P1(NOD) EQUIVALENCE (ZERO(1),XX(1)),(PDE(1),P1(1)) SAVE Zinf,fl,V,b4,CN,C,CD,XY,XP * * ***** IF FIRST IS 'TRUE', CALL POTL AND XCH AND SET UP ARRAYS * IF (.NOT. FIRST) GO TO 17 CALL POTL(I) CALL XCH(I,3) ZINF = DMAX1(0.05D0, Z-YR(ND)) FN = N(I) FL = L(I) V = YR(1)/R(1) B4 = Z*(FL+D4/D3)/((FL+D1)*(FL+D2)) CN = (D2*Z/FN)**(L(I) +1) C = D4*FL +D6 CD = (FL+D5)**2 XY = X(1) XP = X(2) ED = E(I,I) X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) DO 1 J = 3,ND X5 = X(J+2) X(J) =CH*(-X5+24.D0*(X4+X2) + 194.D0*X3 - X1)/20.D0 X1 = X2 X2= X3 X3 = X4 1 X4 = X5 X(NO-1) = CH*(X4 + D10*X3 + X2) DO 4 J = 1,NO 4 YK(J) = -D2*(Z - YR(J))*R(J) + CD X1 = CH*P(1,I)*(YK(1)+ED*RR(1)) X2 = CH*P(2,I)*(YK(2)+ED*RR(2)) X3 = CH*P(3,I)*(YK(3)+ED*RR(3)) X4 = CH*P(4,I)*(YK(4)+ED*RR(4)) DO 7 J = 3,ND X5 = CH* P(J+2,I)*(YK(J+2)+ED*RR(J+2)) X(J) = X(J) - (X5 -D4*(X2 + X4) + D6*X3 +X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 7 X4 = X5 RL = L(I) + 2.5 X(2) = R(2)**RL*(X(5)/R(5)**RL - D3*(X(4)/R(4)**RL - 1 X(3)/R(3)**RL)) * * ***** DETERMINE LOWER BOUND ON THE ENERGY PARAMETER * IF (KK .LT. 3) THEN GO TO 80 ELSE IF (KK .GT. 3) THEN GO TO 18 END IF * DO 11 JJ = 10,ND * J = NO - JJ * IF (YK(J) .LT. D0 ) GO TO 63 *11 CONTINUE * WRITE(OUT,12) *12 FORMAT(10X,'POTENTIAL FUNCTION TOO SMALL - 2R*(Z-Y)<(L+.5)**2') ** STOP * GO TO 80 *63 EM = -YK(J)/RR(J) * print * , 'EM computed from Yk: ',em,j,yk(j),rr(j) * GO TO 81 80 EM = (ZINF/(FN + .01d0))**2 81 FM = EM * * ***** DETERMINE DIAGONAL ENERGY PARAMETER * F1 = D0 C11 = D0 M = MIN0(MAX(I),NO-1) DO 5 J = 2,M FNUM = P(J+1,I) - P(J,I) - P(J,I) + P(J-1,I) FNUM = FNUM - CH*(YK(J+1)* 1 P(J+1,I) + D10*YK(J)*P(J,I) + YK(J-1)*P(J-1,I))-X(J) DEL1 = RR(J+1)*P(J+1,I) + D10*RR(J)*P(J,I) + RR(J-1)*P(J-1,I) F1 = F1 +P(J,I)*FNUM C11 = C11 + P(J,I)*DEL1 5 CONTINUE ED = F1/(C11*CH) IF (ED .GT. EM) GO TO 19 * * ***** ERROR MESSAGE AND ENERGY ADJUSTMENT FOR AN ENERGY PARAMETER * ***** TOO SMALL FOR THE RANGE OF THE FUNCTION * WRITE(OUT,24) ED 24 FORMAT(10X,5HED = ,F10.6,36H; ADJUSTED TO ALLOWED MINIMUM ENERGY ) ED = EM IF ( DABS(FM - E(I,I)) .GT. 1.D-6 .OR. KK .EQ. 3 ) GO TO 19 * * ***** RETURN HYDROGENIC FUNCTION * PN = HNORM(N(I),L(I),ZINF) DO 65 J = 1,NO 65 PDE(J) = PN*HWF(N(I),L(I),ZINF,R(J))/R2(J) AZD = PN*(D2*ZINF/N(I))**(L(I)+1) PP = D0 WRITE(OUT,66) EL(I), ZINF 66 FORMAT(//10X, 'RETURN HYDROGENIC FUNCTION FOR ',A3, 1 ' WITH EFFECTIVE CHARGE ',F10.3) RETURN * * ***** CHECK IF UPPER BOUND IS CORRECT * 19 IF ( D10*ED .LT. EU) GO TO 18 EU = D10*ED FU = EU 18 AZD = AZ(I) 17 DO 26 J=1,NO YR(J) = (YK(J) + ED*RR(J))*CH 26 ZERO(J) = D0 * * ***** SEARCH FOR THE POINT AT WHICH YR BECOMES POSITIVE * CALL SEARCH(NJ,I) * * ***** COMPUTE STARTING VALUES FROM SERIES EXPANSION * B3 = (V + V + ED - (Z/FN)**2)/C DO 6 J = 1,2 HW = HWF(N(I),L(I),Z,R(J))/CN 6 HQ(J) = AZD*(HW + R(J)**(L(I)+3)*B3*(D1-R(J)*B4))/R2(J) * * ***** OBTAIN HOMOGENEOUS SOLUTION * CALL NMRVS(NJ,DELH,MH,HQ,ZERO) P1(1) = HQ(1) + XY/C P1(2) = HQ(2) + XP/C * * ***** OBTAIN PARTICULAR SOLUTION * CALL NMRVS(NJ,DEL1,M1,P1,X) * * ***** DETERMINE THE ENERGY ADJUSTMENT REQUIRED FOR A SOLUTION WITH * ***** GIVEN A0 * M = MAX0(M1,MH) IF (KK .LE. 3) THEN PNORM = D0 DO 50 J = 1,M 50 PNORM = PNORM + RR(J)*HQ(J)*P1(J) Y1 = P1(NJ-1) Y2 = P1(NJ) Y3 = P1(NJ+1) DELTA = Y2 - Y1 + Y2 - Y3 +YR(NJ-1)*Y1 + D10*YR(NJ)*Y2 : + YR(NJ+1)*Y3 + X(NJ) DELTAE = HQ(NJ)*DELTA/(H*H*PNORM) END IF PP = -DEL1/DELH * * ***** MATCH AT THE JOIN FOR A SOLUTION OF THE DIFFERENTIAL EQUATION * DO 13 J = 1,NO 13 P1(J) = P1(J) + PP*HQ(J) * * ***** IF THE EQUATIONS APPEAR TO BE NEARLY * **** SINGULAR, SOLVE THE VARIATIONAL EQUATIONS * IF (KK .NE. 2) RETURN X1 = P(1,I)*RR(1) X2 = P(2,I)*RR(2) P2(1) = X1/C P2(2) = X2/C DO 8 J = 3,NO X3 = P(J,I)*RR(J) XX(J-1) = (D10*X2 + X1 + X3)*CH X1 = X2 8 X2 = X3 CALL NMRVS(NJ,DEL2,M2,P2,XX) AA = -DEL2/DELH M = MAX0(M,M2) DO 9 J = 1,NO 9 P2(J) = P2(J) + AA*HQ(J) A11 = QUAD(I,M,P2,P2) B11 = QUAD(I,M,P1,P2) C11 = QUAD(I,M,P1,P1) - D1 DISC = B11*B11 - A11*C11 IF ( DISC .LT. D0 ) GO TO 70 DE1 = -(B11+DSQRT(DISC))/A11 DE2 = C11/A11/DE1 IF ( P1(3)+DE1*P2(3) .LT. D0) DE1 = DE2 GO TO 71 70 DE1 = C11/A11 71 DO 301 J = 1,NO P1(J) = P1(J) + DE1*P2(J) 301 CONTINUE PP = PP + DE1*AA RETURN END C C ------------------------------------------------------------------ C 3-36 W A V E F N C ------------------------------------------------------------------ C C This routine initializes radial functions by the procedure C indicated by IND(I). C C Value of IND(I) Method C --------------- ------ C -1 Functions read from unit IU2 C 0 Screened hydrogenic functions with ZZ=Z-S(I) C 1 Functions in memory left unchanged C 0 C The set of functions are then orthogonalized, Y (i, i;r) and the C diagonal energy parameters computed, when necessary. C C SUBROUTINE WAVEFN(nend) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR COMMON PN,Z2,FN,M,K,ZT,ETI,EKI,AZI,PT(NOD),MT COMMON /zzind/ZZ(NWD),IND(NwD),IELI(5),NOCCSH(NCD) * CHARACTER EL1*3,AT*6,TT*6,ATM(250)*6,TRM(250)*6,TITLE*24 C C ***** GENERATE ARRAYS FOR R,R*R AND SQRT(R) WITH A CONSTANT MESH C ***** SIZE IN THE LOG(Z*R) VARIABLE C if( nend .eq. -1 ) then DO 1 I=1,NO R(I)= DEXP(RHO)/Z RR(I) = R(I)*R(I) R2(I) = DSQRT(R(I)) 1 RHO = RHO + H RHO = RHO - NO*H endif C C ***** READ THE WAVEFUNCTIONS C IF (IUF .EQ. 0) GO TO 5 2 READ(IUF,END=5) AT,TT,EL1,MM,ZT,ETI,EKI,AZI,(PT(J),J=1,MM) cxi cxi wavefunctions for each continuum energy are ended by a line cxi with MM=0 cxi if( mm .eq. 0 ) goto 5 M = MIN0(NO,MM) CALL EPTR(EL,EL1,I,*2) IF ( I .GT. 0 .AND. IND(I) .EQ. -1) THEN ATM(I) = AT TRM(I) = TT MAX(I) = M ZZ(I) = ZT C = D1 IF ( Z .NE. ZT ) C = Z/ZT C C ***** SCALE RESULTS IF CARDS ARE FOR AN ATOM WITH A DIFFERENT Z C CALL EIJSET(I,I,C*C*ETI) AZ(I) = AZI*C**(L(I)+1)*DSQRT(C) DO 11 J = 1,M P(J,I) = C*PT(J) 11 CONTINUE C C ***** SET REMAINING VALUES IN THE RANGE = 0. C IF ( M .EQ. NO ) GO TO 12 M = M +1 DO 13 J=M,NO 13 P(J,I) = D0 12 IND(I) = -2 ENDIF GO TO 2 C C ***** SET PARAMTERS FOR ELECTRONS AND INITIALIZE FUNCTIONS C 5 DO 9 I = 1,NWF IF (IND(I)) 7,8,9 C C ***** WAVE FUNCTIONS NOT FOUND IN THE INPUT DATA, SET IND = 0 C 7 IF ( IND(I) .EQ. -2 ) GO TO 4 IF ( METH(I) .EQ. 4) GO TO 9 IND(I) = 0 WRITE(OUT,27) EL(I) 27 FORMAT(8X,'WAVE FUNCTIONS NOT FOUND FOR ',A3) C C ***** DETERMINE ESTIMATES OF THE WAVE FUNCTIONS BY THE SCREENED C ***** HYDROGENIC APPROXIMATION C 8 PN = HNORM(N(I),L(I),Z-S(I)) DO 3 J=1,NO P(J,I) = PN*HWF(N(I),L(I),Z-S(I),R(J))/R2(J) 3 CONTINUE M = NO 30 IF ( DABS(P(M,I)) .GT. 1.D-15 ) GO TO 31 P(M,I) = D0 M = M-1 GO TO 30 31 MAX(I) = M C C ***** SET THE AZ(I) VALUE C AZ(I) = PN*(D2*(Z - D5*S(I))/N(I))**(L(I) + 1) CALL EIJSET(I,I,D0) C C ***** ORTHOGONALIZE TO INNER FUNCTIONS C 4 IF (I .EQ. 1 ) GO TO 9 IM = I - 1 DO 6 II =1,IM IF (E(I,II) .EQ. D0) GO TO 6 PN = QUADR(I,II,0) if (abs(pn) .gt. 1.d0) then write(out,*) ' Overlap greater than unity: ', i,ii,pn stop end if IF ( DABS(PN) .GT. 1.D-8 ) THEN PNN = DSQRT(D1 - PN*PN) IF (P(50,I) - PN*P(50,II) .LT. D0) PNN = -PNN M = MAX0(MAX(I),MAX(II)) DO 25 J = 1,M 25 P(J,I) =(P(J,I) - PN*P(J,II))/PNN END IF 6 CONTINUE 9 CONTINUE WRITE(PRI,14) 14 FORMAT(/// 8X,18HINITIAL ESTIMATES //10X,2HNL, 1 4X,5HSIGMA,6X,5HE(NL),4X,6HAZ(NL),4X,9HFUNCTIONS//) C C ***** COMPUTE ONE-ELECTRON ENERGY PARAMETERS IF THEY WERE NOT C ***** SPECIFIED ON INPUT. C DO 15 I = 1,NWF C IF (E(I,I) .EQ. D0) E(I,I) = HL(EL,I,I,REL) - EKIN(I,I) K = IND(I) + 2 IF ( IND(I) .EQ. -2 ) THEN TITLE = ' SCALED '//ATM(I)//TRM(I) ELSE IF (IND(I) .EQ. 0) THEN TITLE = ' SCREENED HYDROGENIC' ELSE TITLE = ' UNCHANGED' END IF 17 WRITE(PRI,19) EL(I),S(I),E(I,I),AZ(I),TITLE 19 FORMAT(9X,A3,F9.2,F11.3,F10.3,3X,A24) 15 CONTINUE cxi IF ( IUF .NE. 0) REWIND(UNIT=IUF) RETURN END SUBROUTINE XCH(I,IOPT) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100,IDIM=550,NCDIM=5000) * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH * CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,30),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * INTEGER KVAL, IEL, CPTR, IH, JH, OPTR COMMON/STATE/WT(NCD),INTPTR(6),KVAL(IDIM),IEL(IDIM,4),CPTR(IDIM) : ,VALUE(IDIM),COEFF(NCDIM),IH(NCDIM),JH(NCDIM),OPTR(NCDIM) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) * COMMON /WAVE/EC,ED,AZD,PDE(NOD),SUM(NWD),S(NWD),DPM(NWD), : ACC(NWD),METH(NWD),IEPTR(NWD),IJE(98),EIJ(98),VIJ(98),IPR * LOGICAL SAME,EXIT * DO 1 J=1,NO 1 X(J) = D0 DO 2 J = 1,NWF IF ((I.LE.NCLOSD .AND. I.NE.J) .OR. : (I.GT.NCLOSD .AND. J.LE.NCLOSD)) THEN DO 4 K = IABS(L(I)-L(J)),L(I)+L(J),2 C = - D2*CB(L(I),L(J),K)*SUM(J) CALL YKF(J,I,K,REL) DO 6 JJ = 1,NO X(JJ) = X(JJ) + C*YK(JJ)*P(JJ,J) 6 CONTINUE 4 CONTINUE END IF 2 CONTINUE SUMI = SUM(I) IF (I .LE. NCLOSD) GO TO 51 * IBEGIN = INTPTR(1)+1 IEND = INTPTR(2) DO 7 INT = IBEGIN,IEND IE1 = 0 IF (IEL(INT,1) .EQ. I) THEN IE1 = IEL(INT,1) IE2 = IEL(INT,2) ELSE IF (IEL(INT,2) .EQ. I) THEN IE1 = IEL(INT,2) IE2 = IEL(INT,1) END IF IF (IE1 .NE. 0) THEN C = D2*COEF(INT)/SUMI CALL YKF(IE1,IE2,KVAL(INT),REL) DO 8 JJ = 1,NO X(JJ) = X(JJ) + C*YK(JJ)*P(JJ,IE2) 8 CONTINUE END IF 7 CONTINUE * IBEGIN = INTPTR(4) + 1 IEND = INTPTR(5) DO 50 INT = IBEGIN,IEND I1 = IEL(INT,1) I2 = IEL(INT,2) J1 = IEL(INT,3) J2 = IEL(INT,4) KK = KVAL(INT) IF ((I1-I)*(I2-I) .EQ. 0 .OR. (J1-I)*(J2-I) .EQ. 0) THEN C = COEF(INT)/SUMI CC = C C C ***** COUNT THE NUMBER OF OCCURRENCES OF I C IK = 0 IF (I1 .EQ. I) IK = IK + 1 IF (I2 .EQ. I) IK = IK + 1 IF (J1 .EQ. I) IK = IK + 1 IF (J2 .EQ. I) IK = IK + 1 EXIT = .FALSE. DO 11 II2=1,2 DO 12 II1=1,2 GO TO (10, 20, 30, 40) IK 10 CONTINUE C C ***** I OCCURS JUST ONCE IN RK C IF (I1 .NE. I) GO TO 13 GO TO 16 20 CONTINUE C C ***** I OCCURS TWICE IN THE RK INTEGRAL C IF (I1 .NE. I) GO TO 13 IF (J1 .EQ. I) GO TO 17 C C ***** TEST IF THE PAIR (I1,J1) = PAIR (I2,J2) C ICODE1 = 100*I1 + J1 ICODE2 = 100*I2 + J2 ICODE3 = 100*J2 + I2 SAME = ICODE1 .EQ. ICODE2 .OR. ICODE1 .EQ. ICODE3 IF ( .NOT. SAME ) GO TO 15 GO TO 17 30 CONTINUE C C ***** I OCCURS THREE TIMES IN THE RK INTEGRAL C C IF (I1 .EQ. I) GO TO 13 CALL YKF(I2, J2, KK, REL) DO 33 J = 1,NO 33 X(J) = X(J) + CC*P(J,I1)*YK(J) CALL YKF(I1, J1, KK, REL) CC = D2*CC DO 34 J = 1,NO 34 X(J) = X(J) + CC*P(J,I2)*YK(J) GO TO 50 C C ***** I OCCURS FOUR TIMES IN RK INTEGRAL C 40 CC = D4*CC GO TO 16 17 CC = D2*CC 16 EXIT = .TRUE. 15 CALL YKF(I2,J2,KK,REL) DO 14 J=1,NO 14 X(J) = X(J) +CC*P(J,J1)*YK(J) IF (EXIT) GO TO 50 13 III = I1 I1= I2 I2= III III = J1 J1 = J2 12 J2 = III III = I1 I1 = J1 J1 = III III = I2 I2= J2 11 J2= III END IF 50 CONTINUE * 51 IBEGIN = INTPTR(5) + 1 IEND = INTPTR(6) DO 60 INT = IBEGIN,IEND C ... Include only if off-diagonal ... IF (IEL(INT,1).NE.IEL(INT,2)) THEN I1 = IEL(INT,1) I2 = IEL(INT,2) IF (I1 .NE. I) THEN ITEMP = I1 I1 = I2 I2 = ITEMP END IF IF (I1 .EQ. I) THEN C = COEF(INT)/SUMI CALL DIFF(I2) DO 62 J = 1,NO X(J) = X(J) + C*YK(J)/R(J) 62 CONTINUE DO 64 II = 1,NCLOSD CC = -D2*(4*L(II)+2)*C CALL YKF(II,II,0,REL) DO 65 J = 1,NO X(J) = X(J) + CC*YK(J)*P(J,I2) 65 CONTINUE DO 66 K = IABS(L(I)-L(II)),L(I)+L(II),2 CCC = CC*CB(L(I),L(II),K) CALL YKF(I2,II,K,REL) DO 67 J = 1,NO X(J) = X(J) - CCC*YK(J)*P(J,II) 67 CONTINUE 66 CONTINUE 64 CONTINUE END IF IF (I .LE. NCLOSD) THEN C = -D2*COEF(INT) CALL YKF(I1,I2,0,REL) CC = D2*C DO 61 J = 1,NO X(J) = X(J) + CC*YK(J)*P(J,I) 61 CONTINUE DO 63 K = IABS(L(I)-L(I1)),L(I)+L(I1),2 CC = C*CB(L(I),L(I1),K) CALL YKF(I2,I,K,REL) DO 68 J = 1,NO X(J) = X(J) - CC*YK(J)*P(J,I1) 68 CONTINUE CALL YKF(I1,I,K,REL) DO 69 J = 1,NO X(J) = X(J) - CC*YK(J)*P(J,I2) 69 CONTINUE 63 CONTINUE END IF END IF 60 CONTINUE IF (I .LE. NCLOSD) GO TO 71 * IBEGIN = INTPTR(2) + 1 IEND = INTPTR(3) DO 70 INT = IBEGIN,IEND I1 = IEL(INT,1) I2 = IEL(INT,2) K1 = KVAL(INT) IF (I1 .NE. I) THEN ITEMP = I1 I1 = I2 I2 = ITEMP END IF IF (I1 .EQ. I) THEN C = COV(INT)/SUMI IF (K1 .GT. 1) C = C*K1*QUADR(I1,I2,0)**(K1-1) DO 72 J = 1,NO X(J) = X(J) + C*P(J,I2)*R(J) 72 CONTINUE END IF 70 CONTINUE * IBEGIN = IEND + 1 IEND = INTPTR(4) DO 80 INT = IBEGIN,IEND I1 = IEL(INT,1) I2 = IEL(INT,2) I3 = IEL(INT,3) I4 = IEL(INT,4) K1 = KVAL(INT)/64 K2 = KVAL(INT) - 64*K1 OV1 = D0 OV2 = D0 DO 82 II = 1,2 IF (I1 .NE. I) THEN ITEMP = I1 I1 = I2 I2 = ITEMP END IF IF (I1 .EQ. I) THEN IF (OV2 .EQ. D0) OV2 = QUADR(I3,I4,0) C = OV2**K2*COV(INT)/SUMI IF (OV1 .EQ. D0 .AND. K1 .GT. 1) : OV1 = QUADR(I1,I2,0) IF (K1 .GT. 1) C = K1*C*OV1**(K1-1) DO 84 J = 1,NO X(J) = X(J) + C*P(J,I2)*R(J) 84 CONTINUE END IF ITEMP = I1 I1 = I3 I3 = ITEMP ITEMP = I2 I2 = I4 I4 = ITEMP ITEMP = K1 K1 = K2 K2 = ITEMP OTEMP = OV1 OV1 = OV2 OV2 = OTEMP 82 CONTINUE 80 CONTINUE 71 GO TO (75,76,77),IOPT 76 DO 78 J = 1,NO 78 X(J) = X(J)/R(J) GO TO 75 77 DO 79 J =1,NO 79 X(J) = R(J)*X(J) DO 74 J = 1,NWF IF (J .NE. I) THEN C = E(I,J) IF (DABS(C) .LE. 1.D-20 ) GO TO 74 DO 73 JJ = 1,NO 73 X(JJ) = X(JJ) + C*P(JJ,J)*RR(JJ) END IF 74 CONTINUE C C ***** CHECK IF EXCHANGE IS ZERO: IF SO, METHOD 2 SHOULD BE USED. C 75 IF (METH(I) .EQ. 2 .OR. METH(I) .GT. 3) RETURN IF ( DABS(X(1)) + DABS(X(2)) + DABS(X(3)) .EQ. D0 ) METH(I) = 2 END * * ------------------------------------------------------------------ * FGCOUL * ------------------------------------------------------------------ * SUBROUTINE FGCOUL(I,M,cn,delta) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NWD=30,NOD=220,NCD=100) DOUBLE PRECISION K * INTEGER IN,OUT,ERR,PRI,OUC,OUD,OUF,OUH COMMON /INOUT/ IN,OUT,ERR,PRI,IUC,IUD,IUF,OUC,OUD,OUF,OUH CHARACTER CONFIG*40,EL*3,ATOM*6,TERM*6,COUPLE*3 COMMON /LABEL/CONFIG(NCD),EL(NWD),ATOM,TERM,COUPLE(NCD,9) * COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),P(NOD,NWD),YK(NOD),YR(NOD) : ,X(NOD),AZ(NWD),L(NWD),MAX(NWD),N(NWD) * LOGICAL FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED COMMON /TEST/FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED(NWD) COMMON /CONTIN/FK(NOD),FH(260),XH(260),rh(260),r2h(260),ph(260), : CD,FL,ZL,ZF,V,NJ,MJ,MP,IX COMMON /COULFG/FKC(NOD),XC(NOD),PDC(NOD),FHC(260),PHC(260),NJM dimension xhc(260) data ED0,LL0 / 1.d0, -1 / PI = ACOS(-D1) PII = PI + PI ED = E(I,I) LL = L(I) K = SQRT(-ED) ifirst = 0 if( ed .eq. ed0 .and. ll .eq. ll0 ) ifirst = 1 if( ifirst .eq. 1 ) goto 10 it =1 azd = d1 do j=1,no pdc(j)= d0 xc(j)=0.d0 enddo ed0 = ed ll0 = ll * * ***** iv) Compute starting values from series expansion * CC = D2*FL + D3 ZLF= ZF/(FL+D1) A2 = ( ED/D2 + ZLF*ZF)/CC A3 = -(( ED/D2)*ZLF + ZF*A2)/(D3*(FL+D2)) DO 6 J = 1,2 6 PDC(J) = AZD*R(J)**LL*R2(J)* : (R(J)*(R(J)*(R(J)*A3 + A2) -ZLF) +D1) * * ***** Solve the differential equation. * MM = MIN0( NO-2, NJ+129) do j=1,260 xhc(j)=0.d0 enddo 2 CALL CNMRV(NJ,MM,1,AZD,FKC,XC,FHC,XHC,PHC,PDC) if( it .eq. 3 ) goto 10 * * * ***** iii) Add the deferred difference correction to the exchange * ***** for the outward integration region * it = it + 1 X1 = PDC(1)*FKC(1) X2 = PDC(2)*FKC(2) X3 = PDC(3)*FKC(3) X4 = PDC(4)*FKC(4) DO 7 J = 3,NJ X5 = PDC(J+2)*FKC(J+2) XC(J) = - (X5 -D4*(X2 + X4) + D6*X3 +X1)/20.D0 X1 = X2 X2 = X3 X3 = X4 X4 = X5 7 CONTINUE RL = LL + 2.5 XC(2) = R(2)**RL*(XC(5)/R(5)**RL - D3*(XC(4)/R(4)**RL - : XC(3)/R(3)**RL)) goto 2 * * ***** From the Coulomb functions we calculate the phase shift and * ***** the amplitude. * 10 H60 = 2.d0/(60.d0*H) MJ = MAX0(NJ+2,NJM) MJ = MAX0(MJ,MP) if( MJ .gt. M - 4 ) MJ = M - 4 95 MJ = MJ + 2 if( MJ .gt. M-2 ) then write(ERR,*) : ' Failed in Calculating Coulomb Functions, R(M) too small ' write(ERR,*) ' R(M) =', R(M) stop endif MJH = 2*(MJ-NJ)+1 cc DO 90 J = MJH-1,MJH xval = RH(j) yval = PHC(J)*R2h(J) c c y'(r) c dyval = ( PHC(J+3) - PHC(J-3) - 9.d0*( PHC(J+2)-PHC(J-2) ) : + 45.d0*( PHC(J+1) - PHC(J-1) ) )*h60 dyval = ( dyval + 0.5d0*PHC(J) )/R2h(J) CALL fgwkb(k,zf,ll,xval,yval,dyval,f2,df,g2,dg,ierr) if( ierr .ne. 0 ) goto 95 if( J .eq. MJH-1 ) then F1 = f2 G1 = G2 endif 90 CONTINUE DNUM = R2h(MJH)*PH(MJH)*F1 - R2H(MJH-1)*PH(MJH-1)*F2 DENO = R2h(MJH-1)*PH(MJH-1)*G2 - R2H(MJH)*PH(MJH)*G1 DELTA = ATAN( DNUM/DENO ) AMP = R2H(MJH)*PH(MJH)/(F2 + G2*(DNUM/DENO) ) CN = COS(DELTA) / AMP END * ------------------------------------------------------------------ * F G W K B * ------------------------------------------------------------------ * * This routine determines the energy normalized * Coulomb functions F , and G, * and their derivatives F' , G' , with respect to r * * Normalization obtained using the WKB method as proposed by * Liu, Xi, and Li, PRA48, 228(1993) * * Written my Jinhua Xi, December, 1994 * ------------------------------------------------------------------ * * F = sin( phi) * sqrt(2/pi k) * subroutine fgwkb(ek,z,l,r,yr,dyr,f,df,g,dg,ierr) Implicit double precision (a-h,o-z) data pi,pii/3.141592653589793d0,6.283185307179586d0/ ierr=0 call wkb(ek,z,l,r,zeta,dz,deltaz) if( dabs(deltaz) .gt. 1.d-4 ) ierr=1 if( dabs(deltaz) .gt. 1.d-1) then ierr=2 return endif * * determine the phase function phi(r) and the * normalization constant * dzz = 0.5d0*dz/zeta pn= dsqrt(2.d0/pi/zeta) * phi = atan( zeta/(dyr/yr + dzz) ) if( sin(phi)*yr .lt. 0.d0 ) phi =phi + pi if( phi .lt. 0.d0 ) phi=phi+pii if( phi .gt. pii ) phi = phi - pii c c for Coulomb potential , get the F, G, F',G' c f = dsin(phi)*pn g = dcos(phi)*pn df = zeta*g - dzz*f dg = - zeta*f - dzz*g return end * * ------------------------------------------------------------------ * W K B * ------------------------------------------------------------------ * * This routine performs the WKB iteration proposed by * Liu, Xi, and Li, PRA48, 228(1993) * * The exact formulas for the iterative procedure were * derived by C. F. Fischer, using the MAPLE Symbol * manipulation package. * * This routine is called by asympn and fgwkb. * asympn: determines phase and normalization, * as proposed by LXL paper * fgwkb: computes only f,g, f',g' * * Written by C. F. Fischer, July, 1994 * Modified by Jinhua Xi, December, 1994 * ------------------------------------------------------------------ subroutine wkb(ek,z,l,r,zeta,dz,deltaz) Implicit double precision (a-h,o-z) double precision w(0:8), u(0:8,0:4) cxi cxi it is ABSOLUTELY necessary to initiate the arrays cxi if you would like to have a correct result. cxi do 1 i=0,8 w(i)=0.d0 do 2 j=0,4 u(i,j)=0.d0 2 continue 1 continue cxi cxi ................................................... cxi a= 2*z/r b= -l*(l+1)/r/r ekk=ek*ek w(0) = ekk + a + b if( w(0) .lt. 0.3d0*ekk ) then write(*,*) ' in WKB: r-value too small, r=', r deltaz=99.d0 return endif u(0,0) = w(0) do 10 i = 1,8 a = -i*a/r b = -(i+1)*b/r w(i) = a+b u(i,0) = w(i)/w(0) 10 continue do 20 j = 0,3 u(0,j+1) = w(0) + (5*u(1,j)**2 -4*u(2,j))/16.d0 do 30 i = 1, 6-2*j if (i .eq. 1) then u(1,j+1) = 7*u(1,j)*u(2,j)-5*u(1,j)**3 -2*u(3,j) else if (i .eq. 2) then u(2,j+1) = 7*u(2,j)**2 -29*u(1,j)**2*u(2,j) + : 9*u(1,j)*u(3,j) +15*u(1,j)**4 -2*u(4,j) else if (i .eq. 3) then u(3,j+1) = 23*u(2,j)*u(3,j) -72*u(2,j)**2*u(1,j) + : 147*u(1,j)**3*u(2,j) - 47*u(1,j)**3*u(2,j) + : 11*u(1,j)*u(4,j) - 15*u(1,j)**5 -2*u(5,j) else if (i .eq. 4) then u(4,j+1) = 23*u(3,j)**2 -284*u(2,j)*u(3,j)*u(1,j) + : 34*u(2,j)*u(4,j) + 657*(u(2,j)*u(1,j))**2 - : 72*u(2,j)**3 - 888*u(1,j)**4*u(2,j) + : 288*u(1,j)**3*u(3,j) -69*u(1,j)**2*u(4,j) + : 13*u(1,j)*u(5,j) + 300*u(1,j)**6 - 2*u(6,j) else if (i .eq. 5) then u(5,j+1) = -2*u(7,j) + 3030*u(2,j)*u(3,j)*u(1,j)**2 - : 490*u(2,j)*u(4,j)*u(1,j) - : 500*u(2,j)**2*u(3,j) +47*u(2,j)*u(5,j) - : 2040*u(1,j)**4*u(3,j) +495*u(1,3)**3*u(4,j) - : 95*u(1,j)**2*u(5,j) +15*u(1,j)*u(6,j) - : 1800*u(1,j)**7 +80*u(3,j)*u(4,j)- : 330*u(3,j)**2*u(1,j) - : 6180*u(2,j)**2*u(1,j)**3 + : 1530*u(2,j)**3*u(1,j) + 6240*u(1,j)**5*u(2,j) else if (i .eq. 6) then u(6,j+1) = -2*u(8,j) + 62100*u(2,j)**2*u(1,j)**4 - : 24660*u(2,j)**3*u(1,j)**2 + : 4020*u(3,j)**2*u(1,j)**2 - : 32640*u(2,j)*u(3,j)*u(1,j)**3 + : 5985*u(2,j)*u(4,j)*u(1,j)**2 + : 12150*u(2,j)**2*u(3,j)*u(1,j) - : 1310*u(3,j)*u(4,j)*u(1,j) - : 774*u(2,j)*u(5,j)*u(1,j) - : 990*u(2,j)**2*u(4,j) -1330*u(2,j)*u(3,j)**2 + : 16440*u(1,j)**5*u(3,j) +17*u(7,j)*u(1,j) + : 127*u(3,j)*u(5,j) +62*u(2,j)*u(6,j) - : 4020*u(1,j)**4*u(1,4) + 780*u(1,j)**3*u(5,j) - : 125*u(1,j)**2*u(6,j) -50040*u(1,j)**6*u(2,j) + : 12600*u(1,j)**8 +80*u(4,j)**2 + 1530*u(2,j)**4 end if u(i,j+1) = (w(i) + u(i,j+1)/8.d0)/u(0,j+1) 30 continue 20 continue if( u(0,3) .le. 0.d0 .or. u(0,4) .le. 0.d0 ) then write(*,*) ' in WKB: r-value too small, r=', r deltaz=99.d0 return endif zeta = sqrt(u(0,4)) dz = (w(1)+(7*u(1,3)*u(2,3)-5*u(1,3)**3-2*u(3,2))/8)/(2*zeta) deltaz = zeta - sqrt(u(0,3)) return end IF (OV2 .EQ. D0) OV2 = QUADR(I3,I4,0) C = OV2**K2*COV(INT)/SUMI IF (OV1 .EQ. D0 .AND. K1 .GT. 1) : OV1 = QUADR(I1,I2,0) IF (K1 .GT. 1) C = K1*C*OV1**(K1-1) DO 84 J = 1,NO X(J) = X(J) + C*P(J,I2)*R(J) 84 CONTINUE END IF ITEMP = I1 I1 = I3 I3 = ITEMP ITEMP = I2 I2 = I4 I4 = ITEMP ITEMP = K1 K1 = K2 K2 atsp/src/COM.f010064400002010000036000001554270623374500500130070ustar00cffcsf00000400000020* * Routines for MCHF_LIB_COM * Computer Physics Communication, Vol. 64, 399-405 (1991) * * C O P Y R I G H T -- 1994 * *----------------------------------------------------------------------- * A C U R A T *----------------------------------------------------------------------- * * Coefficients of Slater integrals are square roots of * rational numbers. To improve the accuracy, certain commonly * occurring coefficients are improved to machine precision. * DOUBLE PRECISION FUNCTION ACURAT(C) IMPLICIT DOUBLE PRECISION(A-H,O-Z) INTEGER NUM INTEGER DEN(11) DATA DEN/2,3,7,9,15,35,49,175,189,315,441/ DATA D1/1.D0/ * C2 = C*C ACURAT = C DO 1 I = 1,11 PROD = DEN(I)*C2 NUM = NINT(PROD) EPS = ABS(NUM-PROD)/DEN(I) IF (EPS .LE. 1.E-8) THEN IF (EPS .NE. 0.) THEN ACURAT = SQRT((NUM*D1)/DEN(I)) IF (C .LT. 0.) ACURAT = -ACURAT RETURN END IF END IF 1 CONTINUE END * * ------------------------------------------------------------- * B I S E C T * ------------------------------------------------------------- * * SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5) * INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM DOUBLE PRECISION D(N),E(N),E2(N),W(MM),RV4(N),RV5(N) DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP DOUBLE PRECISION DABS,DMAX1,DMIN1,DFLOAT INTEGER IND(MM) * * THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE * IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. * HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). * * THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL * SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, * USING BISECTION. * * ON INPUT: * * N IS THE ORDER OF THE MATRIX; * * EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED * EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, * IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, * NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE * PRECISION AND THE 1-NORM OF THE SUBMATRIX; * * D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX; * * E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX * IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY; * * E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. * E2(1) IS ARBITRARY; * * LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. * IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND; * * MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF * EIGENVALUES IN THE INTERVAL. WARNING: IF MORE THAN * MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, * AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. * * ON OUTPUT: * * EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS * (LAST) DEFAULT VALUE; * * D AND E ARE UNALTERED; * * ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED * AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE * MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. * E2(1) IS ALSO SET TO ZERO; * * M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB); * * W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER; * * IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES * ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- * 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM * THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.; * * IERR IS SET TO * ZERO FOR NORMAL RETURN, * 3*N+1 IF M EXCEEDS MM; * * RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. * * THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM * APPEARS IN BISECT IN-LINE. * * NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN * BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. * * QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, * APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY * * ------------------------------------------------------------------ * * :::::::::: MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING * THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. * MACHEP = 16.0D0**(-13) FOR LONG FORM ARITHMETIC * ON S360 :::::::::: DATA MACHEP/1.D-12/ * IERR = 0 TAG = 0 T1 = LB T2 = UB * :::::::::: LOOK FOR SMALL SUB-DIAGONAL ENTRIES :::::::::: DO 40 I = 1, N IF (I .EQ. 1) GO TO 20 IF (DABS(E(I)) .GT. MACHEP * (DABS(D(I)) + DABS(D(I-1)))) : GO TO 40 20 E2(I) = 0.0D0 40 CONTINUE * :::::::::: DETERMINE THE NUMBER OF EIGENVALUES * IN THE INTERVAL :::::::::: P = 1 Q = N X1 = UB ISTURM = 1 GO TO 320 60 M = S X1 = LB ISTURM = 2 GO TO 320 80 M = M - S IF (M .GT. MM) GO TO 980 Q = 0 R = 0 * :::::::::: ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING * INTERVAL BY THE GERSCHGORIN BOUNDS :::::::::: 100 IF (R .EQ. M) GO TO 1001 TAG = TAG + 1 P = Q + 1 XU = D(P) X0 = D(P) U = 0.0D0 * DO 120 Q = P, N X1 = U U = 0.0D0 V = 0.0D0 IF (Q .EQ. N) GO TO 110 U = DABS(E(Q+1)) V = E2(Q+1) 110 XU = DMIN1(D(Q)-(X1+U),XU) X0 = DMAX1(D(Q)+(X1+U),X0) IF (V .EQ. 0.0D0) GO TO 140 120 CONTINUE * 140 X1 = DMAX1(DABS(XU),DABS(X0)) * MACHEP IF (EPS1 .LE. 0.0D0) EPS1 = -X1 IF (P .NE. Q) GO TO 180 * :::::::::: CHECK FOR ISOLATED ROOT WITHIN INTERVAL :::::::::: IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 M1 = P M2 = P RV5(P) = D(P) GO TO 900 180 X1 = X1 * DFLOAT(Q-P+1) LB = DMAX1(T1,XU-X1) UB = DMIN1(T2,X0+X1) X1 = LB ISTURM = 3 GO TO 320 200 M1 = S + 1 X1 = UB ISTURM = 4 GO TO 320 220 M2 = S IF (M1 .GT. M2) GO TO 940 * :::::::::: FIND ROOTS BY BISECTION :::::::::: X0 = UB ISTURM = 5 * DO 240 I = M1, M2 RV5(I) = UB RV4(I) = LB 240 CONTINUE * :::::::::: LOOP FOR K-TH EIGENVALUE * FOR K=M2 STEP -1 UNTIL M1 DO -- * (-DO- NOT USED TO LEGALIZE COMPUTED-GO-TO) :::::::::: K = M2 250 XU = LB * :::::::::: FOR I=K STEP -1 UNTIL M1 DO -- :::::::::: DO 260 II = M1, K I = M1 + K - II IF (XU .GE. RV4(I)) GO TO 260 XU = RV4(I) GO TO 280 260 CONTINUE * 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) * :::::::::: NEXT BISECTION STEP :::::::::: 300 X1 = (XU + X0) * 0.5D0 IF ((X0 - XU) .LE. (2.0D0 * MACHEP * : (DABS(XU) + DABS(X0)) + DABS(EPS1))) GO TO 420 * :::::::::: IN-LINE PROCEDURE FOR STURM SEQUENCE :::::::::: 320 S = P - 1 U = 1.0D0 * DO 340 I = P, Q IF (U .NE. 0.0D0) GO TO 325 V = DABS(E(I)) / MACHEP GO TO 330 325 V = E2(I) / U 330 U = D(I) - X1 - V IF (U .LT. 0.0D0) S = S + 1 340 CONTINUE * GO TO (60,80,200,220,360), ISTURM * :::::::::: REFINE INTERVALS :::::::::: 360 IF (S .GE. K) GO TO 400 XU = X1 IF (S .GE. M1) GO TO 380 RV4(M1) = X1 GO TO 300 380 RV4(S+1) = X1 IF (RV5(S) .GT. X1) RV5(S) = X1 GO TO 300 400 X0 = X1 GO TO 300 * :::::::::: K-TH EIGENVALUE FOUND :::::::::: 420 RV5(K) = X1 K = K - 1 IF (K .GE. M1) GO TO 250 * :::::::::: ORDER EIGENVALUES TAGGED WITH THEIR * SUBMATRIX ASSOCIATIONS :::::::::: 900 S = R R = R + M2 - M1 + 1 J = 1 K = M1 * DO 920 L = 1, R IF (J .GT. S) GO TO 910 IF (K .GT. M2) GO TO 940 IF (RV5(K) .GE. W(L)) GO TO 915 * DO 905 II = J, S I = L + S - II W(I+1) = W(I) IND(I+1) = IND(I) 905 CONTINUE * 910 W(L) = RV5(K) IND(L) = TAG K = K + 1 GO TO 920 915 J = J + 1 920 CONTINUE * 940 IF (Q .LT. N) GO TO 100 GO TO 1001 * :::::::::: SET ERROR -- UNDERESTIMATE OF NUMBER OF * EIGENVALUES IN INTERVAL :::::::::: 980 IERR = 3 * N + 1 1001 LB = T1 UB = T2 RETURN * :::::::::: LAST CARD OF BISECT :::::::::: END * * ------------------------------------------------------------------ * B W I N T * ------------------------------------------------------------------ * SUBROUTINE BWINT(LC,LO) IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON/BLUME/COEFN2(4),COEFNK(4),COEFVK(4) * * ... LC IS THE L-VALUE OF THE FILLED SUBSHELL, LO IS THE L-VALUE * OF THE PARTIALLY-FILLED SUBSHELL. * IF(LC.LE.3.AND.LO.LE.4) GO TO 1 PRINT 100, LC,LO 100 FORMAT (37H INCORRECT CALLING OF BWINT WITH LC =,I2,6H, LO =,I2) 1 LC1 = LC + 1 GO TO (10,20,30,40), LC1 10 GO TO (11,12,13,14), LO * * ... S-P * 11 COEFNK(1) = 1.D0 COEFN2(1) = -2.D0 COEFVK(1) = 1.D0 RETURN * * ... S-D * 12 COEFNK(1) = 6.D0/5.D0 COEFN2(1) = -9.D0/5.D0 COEFVK(1) = 3.D0/5.D0 RETURN * * ... S-F * 13 COEFNK(1) = 9.D0/7.D0 COEFN2(1) = -12.D0/7.D0 COEFVK(1) = 3.D0/7.D0 RETURN * * ... S-G * 14 COEFNK(1) = 4.D0/3.D0 COEFN2(1) = -5.D0/3.D0 COEFVK(1) = 1.D0/3.D0 RETURN 20 GO TO (21,22,23,24), LO * * ... P-P * 21 COEFNK(1) = 0.D0 COEFN2(1) = 3.D0 COEFVK(1) = 9.D0/5.D0 RETURN * * ... P-D * 22 COEFNK(1) = 3.D0/7.D0 COEFNK(2) = 36.D0/35.D0 COEFN2(1) = -12.D0/5.D0 COEFN2(2) = 0.D0 COEFVK(1) = 3.D0/5.D0 COEFVK(2) = 36.D0/35.D0 RETURN * * ... P-F * 23 COEFNK(1) = 1.D0/7.D0 COEFNK(2) = 10.D0/7.D0 COEFN2(1) = -18.D0/7.D0 COEFN2(2) = 0.D0 COEFVK(1) = 18.D0/35.D0 COEFVK(2) = 5.D0/7.D0 RETURN * * ... P-G * 24 COEFNK(1) = 5.D0/77.D0 COEFNK(2) = 18.D0/11.D0 COEFN2(1) = -18.D0/7.D0 COEFN2(2) = 0.D0 COEFVK(1) = 3.D0/7.D0 COEFVK(2) = 6.D0/11.D0 RETURN 30 GO TO (31,32,33,34), LO * * ... D-P * 31 COEFNK(1) = 59.D0/7.D0 COEFNK(2) = -18.D0/7.D0 COEFN2(1) = -4.D0 COEFN2(2) = 0.D0 COEFVK(1) = -1.D0 COEFVK(2) = 18.D0/7.D0 RETURN * * ... D-D * 32 COEFNK(1) = 6.D0/7.D0 COEFNK(2) = 0.D0 COEFN2(1) = 3.D0 COEFN2(2) = 0.D0 COEFVK(1) = 3.D0/7.D0 COEFVK(2) = 10.D0/7.D0 RETURN * * ... D-F * 33 COEFNK(1) = 9.D0/7.D0 COEFNK(2) = -13.D0/77.D0 COEFNK(3) = 75.D0/77.D0 COEFN2(1) = -18.D0/7.D0 COEFN2(2) = 0.D0 COEFN2(3) = 0.D0 COEFVK(1) = 3.D0/7.D0 COEFVK(2) = 3.D0/7.D0 COEFVK(3) = 75.D0/77.D0 RETURN * * ... D-G * 34 COEFNK(1) = 741.D0/693.D0 COEFNK(2) = -215.D0/429.D0 COEFNK(3) = 210.D0/143.D0 COEFN2(1) = -3.D0 COEFN2(2) = 0.D0 COEFN2(3) = 0.D0 COEFVK(1) = 3.D0/7.D0 COEFVK(2) = 255.D0/693.D0 COEFVK(3) = 105.D0/143.D0 RETURN 40 GO TO (41,42,43,44), LO * * ... F-P * 41 COEFNK(1) = 52.D0/3.D0 COEFNK(2) = -20.D0/3.D0 COEFN2(1) = -9.D0 COEFN2(2) = 0.D0 COEFVK(1) = -9.D0/5.D0 COEFVK(2) = 10.D0/3.D0 RETURN * * ... F-D * 42 COEFNK(1) = 5.D0 COEFNK(2) = 142.D0/55.D0 COEFNK(3) = -20.D0/11.D0 COEFN2(1) = -18.D0/5.D0 COEFN2(2) = 0.D0 COEFN2(3) = 0.D0 COEFVK(1) = -3.D0/5.D0 COEFVK(2) = 2.D0/5.D0 COEFVK(3) = 20.D0/11.D0 RETURN * * ... F-F * 43 COEFNK(1) = 1.D0 COEFNK(2) = 5.D0/11.D0 COEFNK(3) = 0.D0 COEFN2(1) = 3.D0 COEFN2(2) = 0.D0 COEFN2(3) = 0.D0 COEFVK(1) = 1.D0/5.D0 COEFVK(2) = 5.D0/11.D0 COEFVK(3) = 175.D0/143.D0 RETURN * * ... F-G * 44 COEFNK(1) = 53.D0/33.D0 COEFNK(2) = 57.D0/143.D0 COEFNK(3) = -115.D0/429.D0 COEFNK(4) = 392.D0/429.D0 COEFN2(1) = -8.D0/3.D0 COEFN2(2) = 0.D0 COEFN2(3) = 0.D0 COEFN2(4) = 0.D0 COEFVK(1) = 1.D0/3.D0 COEFVK(2) = 3.D0/11.D0 COEFVK(3) = 57.D0/143.D0 COEFVK(4) = 392.D0/429.D0 RETURN END * * ------------------------------------------------------------------ * C A * ------------------------------------------------------------------ * * DOUBLE PRECISION FUNCTION CA(L,K) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /EAV/CCA(10),CCB(35) * IF (L .LE. 4) THEN CA = CCA((L*(L-1) + K)/2) ELSE CA = RME(L,L,K)**2 END IF END * * ----------------------------------------------------------------- * C B * ----------------------------------------------------------------- * * DOUBLE PRECISION FUNCTION CB(L,LP,K) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /EAV/CCA(10),CCB(35) INTEGER ICBPTR(0:4) DATA ICBPTR/1,6,14,23,31/ * IF (L .LE. LP) THEN L1 = L L2 = LP ELSE L1 = LP L2 = L END IF IF ( L2 .LE. 4) THEN CB = CCB(ICBPTR(L1)+(K+L1-L2)/2+(L1+1)*(L2-L1)) ELSE CB = RME(L,LP,K)**2/(2*(2*L+1)*(2*LP+1)) END IF END * * ------------------------------------------------------------------ * E P T R * ------------------------------------------------------------------ * * Determines the position of the electron in the electron list * SUBROUTINE EPTR(EL,ELSYMB, IEL, *) IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER(IWRITE=6) CHARACTER CONFIG*66, COUPLE*3, EL(*)*3, ELSYMB*3, BL*3 COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS DATA BL/' '/ * * ***** SEARCH ELECTRON LIST FOR LSYMB * IF ( ELSYMB .EQ. BL ) THEN IEL = 0 RETURN ENDIF DO 10 I=1,NWF IF (EL(I) .EQ. ELSYMB ) THEN IEL = I RETURN ENDIF 10 CONTINUE IEL = -1 WRITE (IWRITE,20) ELSYMB 20 FORMAT(/10X,A3,' NOT FOUND IN ELECTRON LIST') RETURN 1 END * * ----------------------------------------------------------------- * F A C T R L * ----------------------------------------------------------------- * * SUBROUTINE FACTRL(NFACT) * * GAM(I) = LOG( GAMMA(I-1) ), WHERE GAMMA(I) = FACTORIAL I-1 * IMPLICIT REAL *8(A-H,O-Z) * COMMON/FACT/GAM(100) DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ * GAMMA=ONE GAM(1) = ZERO DO 1 I=1,NFACT-1 GAMMA=I*GAMMA GAM(I+1) = DLOG(GAMMA) 1 CONTINUE DO 20 I = NFACT+1,(100) X = I-1 GAM(I) = GAM(I-1) + DLOG(X) 20 CONTINUE RETURN END * * ------------------------------------------------------------------ * F K * ------------------------------------------------------------------ * k * Returns the value of F (i,j) * * DOUBLE PRECISION FUNCTION FK(I,J,K,REL) IMPLICIT DOUBLE PRECISION(A-H,O-Z) LOGICAL REL COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS CALL YKF(I,I,K,REL) FK = QUADS(J,J,1) IF (MASS .EQ. 2) FK = FK*(D1 + RMASS/D2) RETURN END * * ------------------------------------------------------------------ * G K * ------------------------------------------------------------------ * k * Returns the value of G (i,j). * * DOUBLE PRECISION FUNCTION GK(I,J,K,REL) IMPLICIT DOUBLE PRECISION(A-H,O-Z) LOGICAL REL COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS CALL YKF(I,J,K,REL) GK = QUADS(I,J,1) IF (MASS .GT. 0) THEN IF (MASS .EQ. 1) THEN IF (K .EQ. 1) GK = GK + RMASS*GRAD(I,J)**2 ELSE GK = GK*(D1 + RMASS/D2) IF (K .EQ. 1) GK = GK + Z*RMASS*QUADR(I,J,1)*QUADR(J,I,-2) END IF END IF RETURN END * * ----------------------------------------------------------------- * G R A C A H * ----------------------------------------------------------------- * * SUBROUTINE GRACAH(I,J,K,L,M,N,RAC) IMPLICIT DOUBLE PRECISION(A-H,O-Z) * * SUBROUTINE TO CALCULATE RACAH COEFFICIENTS. * THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE. * WRITTEN BY N. S. SCOTT * Modified by C. Froese Fischer, March 11, 1988 to use * table look-up * LOGICAL SAVE COMMON/FACT/GAM(100) DIMENSION RACA(0:4,0:4,0:4,0:4,0:4,0:4) DATA RACA/15625*1.D-20/ DATA ZERO,ONE,TWO,UNDEF/0.D0,1.D0,2.D0,1.D-20/ * SAVE = .FALSE. IMAX = MAX(I,J,K,L,M,N) IF (IMAX .LE. 4) THEN RAC = RACA(I,J,K,L,M,N) IF (RAC .EQ. UNDEF) THEN SAVE = .TRUE. ELSE RETURN END IF END IF J1 = I+J+M J2 = K+L+M J3 = I+K+N J4 = J+L+N IF (MOD(J1,2) .EQ. 0 .AND. MOD(J2,2) .EQ. 0 .AND. : MOD(J3,2) .EQ. 0 .AND. MOD(J4,2) .EQ. 0 ) THEN J1 = J1/2 J2 = J2/2 J3 = J3/2 J4 = J4/2 IF (MAX(I,J,M) .LE. J1 .AND. MAX(K,L,M) .LE. J2 .AND. : MAX(I,K,N) .LE. J3 .AND. MAX(J,L,N) .LE. J4 ) THEN J5 = (I+J+K+L)/2 J6 = (I+L+M+N)/2 J7 = (J+K+M+N)/2 NUMIN = MAX(J1, J2, J3, J4) + 1 NUMAX = MIN(J5, J6, J7) + 1 RAC = ONE ICOUNT = 0 DO 10 KK = NUMIN+1,NUMAX KI = NUMAX - ICOUNT RAC = ONE - (RAC*(KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)))/ : ((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4)) ICOUNT = ICOUNT+1 10 CONTINUE RAC = RAC*EXP( : (GAM(NUMIN+1) - GAM(NUMIN-J1) - GAM(NUMIN-J2) - : GAM(NUMIN-J3) - GAM(NUMIN-J4) - GAM(J5+2-NUMIN)- : GAM(J6+2-NUMIN)-GAM(J7+2-NUMIN)) + : (GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(J1+2) + : GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2) + : GAM(J3+1-I)+GAM(J3+1-K)+GAM(J3+1-N)-GAM(J3+2) + : GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))/TWO) IF (MOD(J5+NUMIN,2) .EQ. 0) RAC = -RAC ELSE RAC = ZERO END IF ELSE RAC = ZERO END IF IF (SAVE) RACA(I,J,K,L,M,N) = RAC RETURN END * ------------------------------------------------------------------ * H N O R M * ------------------------------------------------------------------ * * Returns the value of the normalization constant for an (nl) * hydrogenic function with nuclear charge ZZ. * * DOUBLE PRECISION FUNCTION HNORM(N,L,ZZ) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS M = L + L + 1 A = N + L B = M T = A D = B M = M - 1 IF (M .EQ. 0) GO TO 2 DO 1 I = 1,M A = A - D1 B = B - D1 T = T*A 1 D = D*B 2 HNORM = DSQRT(ZZ*T)/( N*D) RETURN END * * ------------------------------------------------------------------ * H W F * ------------------------------------------------------------------ * * Returns the value of an unnormalized (nl) hydrogenic function * with nuclear charge ZZ and radius r. * * DOUBLE PRECISION FUNCTION HWF(N,L,ZZ,R) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS K = N-L-1 P = D1 A = D1 B = K C = N+ L X = -D2*ZZ*R/N * * ***** TEST IF UNDERFLOW MAY OCCUR, IF SO SET HWF = 0 * IF ( X .LT. -150.D0 ) GO TO 5 IF (K) 1,2,3 3 DO 4 I = 1,K P = D1 + A/B*P/C*X A = A + D1 B = B - D1 4 C = C - D1 2 HWF = P*DEXP(X/D2)*(-X)**(L+1) RETURN 1 WRITE(6,7) N,L,ZZ,R 7 FORMAT(51H FORBIDDEN COMBINATION OF N AND L IN HWF SUBPROGRAM/ : 4H N = ,I4,6H L = ,I4,6H Z = ,F6.1,6H R = ,F8.4) STOP 5 HWF = D0 RETURN END * * ------------------------------------------------------------------ * I N I T A * ------------------------------------------------------------------ * * Initializes basi*constants of the program including those * which define the average energy of a configuration. * * SUBROUTINE INITA IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /EAV/CCA(10),CCB(35) * * ***** AVERAGE INTERACTIONS FOR EQUIVALENT ELECTRONS * * ***** P - P * CCA(1) = 2.D0/25.D0 * * ***** D - D * CCA(2) = 2.D0/63.D0 CCA(3) = 2.D0/63.D0 * * ***** F - F * CCA(4) = 4.D0/ 195.D0 CCA(5) = 2.D0/ 143.D0 CCA(6) = 100.D0/5577.D0 * * ***** G - G * CCA(7) = 20.D0/ 1309.D0 CCA(8) = 162.D0/ 17017.D0 CCA(9) = 20.D0/ 2431.D0 CCA(10) = 4410.D0/371943.D0 * * * ***** AVERAGE INTERACTIONS FOR NON-EQUIVALENT ELECTRONS * * ***** S - ( S, P, D, F, G ) * CCB(1) = 1.D0/ 2.D0 CCB(2) = 1.D0/ 6.D0 CCB(3) = 1.D0/10.D0 CCB(4) = 1.D0/14.D0 CCB(5) = 1.D0/18.D0 * * ***** P - ( P, D, F, G ) * CCB(6) = 1.D0/ 6.D0 CCB(7) = 1.D0/ 15.D0 CCB(8) = 1.D0/ 15.D0 CCB(9) = 3.D0/ 70.D0 CCB(10) = 3.D0/ 70.D0 CCB(11) = 2.D0/ 63.D0 CCB(12) = 2.D0/ 63.D0 CCB(13) = 5.D0/198.D0 * * ***** D - ( D, F, G ) * CCB(14) = 1.D0/ 10.D0 CCB(15) = 1.D0/ 35.D0 CCB(16) = 1.D0/ 35.D0 CCB(17) = 3.D0/ 70.D0 CCB(18) = 2.D0/105.D0 CCB(19) = 5.D0/231.D0 CCB(20) = 1.D0/ 35.D0 CCB(21) = 10.D0/693.D0 CCB(22) = 5.D0/286.D0 * * ***** F - ( F, G ) * CCB(23) = 1.D0/ 14.D0 CCB(24) = 2.D0/ 105.D0 CCB(25) = 1.D0/ 77.D0 CCB(26) = 50.D0/3003.D0 CCB(27) = 2.D0/ 63.D0 CCB(28) = 1.D0/ 77.D0 CCB(29) = 10.D0/1001.D0 CCB(30) = 35.D0/2574.D0 * * ***** G - ( G ) * CCB(31) = 1.D0/ 18.D0 CCB(32) = 10.D0/ 693.D0 CCB(33) = 9.D0/ 1001.D0 CCB(34) = 10.D0/ 1287.D0 CCB(35) = 245.D0/21879.D0 * * *** Initialize /FACT/ * CALL FACTRL(32) RETURN END * * --------------------------------------------------------------- * I N I T R * --------------------------------------------------------------- * * SUBROUTINE INITR IMPLICIT DOUBLE PRECISION(A-H,O-Z) PARAMETER (NOD=220) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS * * ***** SET THE COMMONLY USED DOUBLE PRECISION CONSTANTS * D0 = 0.D0 D1 = 1.D0 D2 = 2.D0 D3 = 3.D0 D4 = 4.D0 D5 = 1.D0/2.D0 D6 = 6.D0 D8 = 8.D0 D10 = 10.D0 D12 = 12.D0 D16 = 16.D0 D30 = 30.D0 * * ***** SET THE STARTING POINT, STEP SIZE, AND RELATED PARAMETERS * RHO = -4.D0 H = 1./16.D0 H1 = H/1.5 H3 = H/3. CH = H*H/12. EH = DEXP(-H) NO=NOD ND = NO - 2 * * ***** SET THE FINE-STRUCTURE CONSTANT * FINE = 0.25D0/(137.036D0)**2 END * * ------------------------------------------------------------------ * I N T A C T * ------------------------------------------------------------------ * SUBROUTINE INTACT(L,LP,IEQUIV) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON/ENAV/NINTS,KVALUE(15),COEFCT(15) COMMON /EAV/CCA(10),CCB(35) INTEGER ICBPTR(0:4) DATA ICBPTR/1,6,14,23,31/ * * THIS SUBROUTINE GIVES THE INTERACTION ENERGY BETWEEN TWO SHELLS, * ONE WITH ORBITAL ANGULAR MOMENTUM L , THE OTHER WITH ORBITAL * ANGULAR MOMENTUM LP . NOTICE THAT THE FIRST TERM OF THIS * INTERACTION ENERGY IS ALWAYS F0(L,LP) AND THIS IS NOT GIVEN * IN THIS SUBROUTINE. THUS ONLY THE EXTRA TERMS ARE HERE PRODUCED. * FOR EQUIVALENT ELECTRONS (IEQUIV = 1) , THERE WILL BE FK * INTEGRALS ONLY. FOR NON-EQUIVALENT ELECTRONS (IEQUIV = 2) , * THERE WILL BE GK INTEGRALS ONLY. * * THE EXPRESSIONS FOR THE INTERACTION ENERGIES ARE GIVEN BY * R. D. COWAN, THE THEORY OF ATOMIC SPECTRA, EQUATIONS (6.38) * AND (6.39). * I = 0 IF (IEQUIV .EQ. 1) THEN DO 1 K = 2,2*L,2 I = I+1 KVALUE(I) = K IF (L .LE. 4) THEN COEFCT(I) = -CCA((L*(L-1) + K)/2) ELSE COEFCT(I) = -RME(L,L,K)**2/((2*L+1)*(4*L+1)) END IF 1 CONTINUE ELSE DO 2 K = IABS(L-LP),L+LP,2 I = I+1 KVALUE(I) = K IF (L .LE. LP) THEN L1 = L L2 = LP ELSE L1 = LP L2 = L END IF IF ( L2 .LE. 4) THEN COEFCT(I) = -CCB(ICBPTR(L1)+(K+L1-L2)/2+(L1+1)*(L2-L1)) ELSE COEFCT(I) = -RME(L,LP,K)**2/(2*(2*L+1)*(2*LP+1)) END IF 2 CONTINUE END IF NINTS = I RETURN END * * ------------------------------------------------------------------ * L I N E Q N * ------------------------------------------------------------------ * * This routine is a modification of the one in "Computer Methods * for Mathematical Computation" by Forsythe, Malcolm, and Moler * (Prentice Hall, 1975) * SUBROUTINE LINEQN(NDIM,N,A,B) * INTEGER NDIM,N DOUBLE PRECISION A(NDIM,N),B(NDIM) * * SOLVE A SYSTEM OF LINEAR EQUATIONS A*X = B * * INPUT.. * * NDIM = DECLARED ROW DIMENSION OF THE ARRAY CONTAINING A. * N = ORDER OF THE MATRIX * A = COEFFICIENT MATRIX * B = CONSTANT VECTOR * * OUTPUT.. * * B = SOLUTION VECTOR * DOUBLE PRECISION T INTEGER NM1, I, J, K, KP1, KB, KM1, M NM1 = N-1 * * * GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING * DO 35 K = 1,NM1 KP1= K+1 * * FIND PIVOT * M = K DO 15 I = KP1,N IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 15 CONTINUE T = A(M,K) A(M,K) = A(K,K) A(K,K) = T * * SKIP STEP IF PIVOT IS ZERO * IF (T .EQ. 0.0D0) GO TO 35 * * COMPUTE MULTIPLIERS * DO 20 I = KP1,N A(I,K) = -A(I,K)/T 20 CONTINUE * * INTERCHANGE AND ELIMINATE BY COLUMNS * DO 30 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.0D0) GO TO 30 DO 25 I = KP1,N A(I,J) = A(I,J) + A(I,K)*T 25 CONTINUE 30 CONTINUE T = B(M) B(M) = B(K) B(K) = T IF (T .EQ. 0.0D0) GO TO 35 DO 32 I = KP1, N B(I) = B(I) + A(I,K)*T 32 CONTINUE 35 CONTINUE * * BACK SUBSTITUTION * DO 40 K = N,2,-1 IF (A(K,K) .EQ. 0.D0) THEN B(K) = 0.D0 ELSE B(K) = B(K)/A(K,K) END IF T = -B(K) DO 41 I = 1, K-1 B(I) = B(I) + A(I,K)*T 41 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN END * ----------------------------------------------------------------- * L V A L * ----------------------------------------------------------------- * * INTEGER FUNCTION LVAL(SYMBOL) CHARACTER*1 SYMBOL CHARACTER*22 SET DATA SET/'spdfghiklmnSPDFGHIKLMN'/ * LOCATE = INDEX(SET,SYMBOL) IF ( LOCATE .LE. 11) THEN LVAL = LOCATE - 1 ELSE LVAL = LOCATE - 12 ENDIF RETURN END * * * ------------------------------------------------------------------ * P A C K * ------------------------------------------------------------------ * Subroutine written by Bin LIU * * Rules for encoding * 1. All blanks deleted * 2. If Qi=1, omit Qi * 3. If Qi=1 or Qi>=4l+1, omit ALFAi * 4. If i=1 or (Qi=4l+2 and i<>m), insert '.'; else _BETAi. * SUBROUTINE PACK (M, EL, Q, COUPLE, STR) INTEGER FULL,Q(5),CONST CHARACTER*3 EL(5),COUPLE(9),CH3 CHARACTER CH1 CHARACTER*66 STR * * FULL : 4l+2 * CONST : constant for converting lowercase to uppercase * CH* : temporary variables * CONST = ICHAR('a') - ICHAR('A') STR=' ' J = 0 * * ----- begin to encode ----- * DO 100 I=1,M N = Q(I) IF (N .EQ. 0) GO TO 100 K = 3 IF (EL(I)(3:3) .EQ. ' ') K = 2 IF (EL(I)(1:1) .EQ. ' ') THEN EL(I)=EL(I)(2:3)//' ' K = 2 END IF CH1=EL(I)(2:2) IF ((CH1.GE.'A') .AND. (CH1.LE.'Z')) : EL(I)(2:2)=CHAR(ICHAR(CH1)+CONST) FULL=4*LVAL(CH1)+2 * * ----- convert Qi into character ----- * WRITE(CH3,'(I2)') Q(I) STR=STR(1:J)//EL(I)(1:K) J= J + K * * ----- If Qi<>1, add Qi * If Qi<4l+1, add TERMi for the shell ----- * IF (N .NE. 1) THEN IF (N .GT. 9) THEN STR=STR(1:J)//'('//CH3(1:2)//')' J = J + 4 ELSE STR=STR(1:J)//'('//CH3(2:2)//')' J = J + 3 ENDIF IF (N .LT. FULL-1 .AND. M .NE. 1) THEN CH3=COUPLE(I) CH1= CH3(2:2) IF (CH1.GE.'a' .AND. CH1.LE.'z') : CH3(2:2) = CHAR(ICHAR(CH1)-CONST) STR=STR(1:J)//CH3 J= J + 3 ENDIF ENDIF * * ----- If i=1 or Qi=4l+2 and i<>m, * insert '.'; else _RESULTANTi. ----- * 50 IF ((I.NE.1 .AND. N.NE.FULL ) : .OR. I.EQ.M ) THEN CH3=COUPLE(M+I-1) CH1 = CH3(2:2) IF (CH1.GE.'a' .AND. CH1.LE.'z') : CH3(2:2) = CHAR(ICHAR(CH1)-CONST) K = 2 IF (M .EQ. 1) K = 3 STR=STR(1:J)//'_'//CH3(1:K) J = J + K + 1 ENDIF IF (I .NE. M .AND. N.NE.0 ) THEN J = J + 1 STR(J:J)='.' ENDIF 100 CONTINUE * *>>>>> Because of a compiler error on the SUN, the following is * needed to have the string printed correctly. STR = STR(1:J) RETURN END * * -------------------------------------------------------------- * R E F O R M * -------------------------------------------------------------- * * SUBROUTINE REFORM(STR1,STR2) CHARACTER*40 STR1,STR2,BLANK DATA BLANK/' '/ * 1 I = 0 STR2 = BLANK IS = 0 2 JS = INDEX(STR1(IS+1:),'(') IF (JS .NE. 0) THEN IF (JS .GT. 5) GO TO 10 I = I+5 STR2(I-JS+1:I) = STR1(IS+1:IS+JS) IS = IS + JS JS = INDEX(STR1(IS+1:),')') IF (JS .EQ. 0 .OR. JS .GT. 3) GO TO 10 I = I+3 STR2(I-JS+1:I) = STR1(IS+1:IS+JS) IS = IS + JS GO TO 2 END IF RETURN 10 PRINT *,' Error in ',STR1,': Re-enter' READ '(A)',STR1 GO TO 1 END * * ------------------------------------------------------------------ * R K * ------------------------------------------------------------------ * * k * Evaluates R (i, j; ii, jj) * * DOUBLE PRECISION FUNCTION RK(I,J,II,JJ,K,REL) IMPLICIT DOUBLE PRECISION(A-H,O-Z) LOGICAL REL COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS CALL YKF(I,II,K,REL) RK = QUADS(J,JJ,1) IF (MASS .GT. 0) THEN IF (MASS .EQ. 1) THEN IF (K .EQ. 1) RK = RK - RMASS*GRAD(I,II)*GRAD(J,JJ) ELSE RK = RK*(D1 + RMASS/D2) IF (K .EQ. 1) RK = RK + Z*RMASS/D2*( : QUADR(I,II,1)*QUADR(J,JJ,-2)+QUADR(I,II,-2)*QUADR(J,JJ,1)) END IF END IF RETURN END * * ------------------------------------------------------------------ * R M E * ------------------------------------------------------------------ * * DOUBLE PRECISION FUNCTION RME(L,LP,K) * IMPLICIT REAL *8(A-H,O-Z) * COMMON/FACT/GAM(100) * *--- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP) - SEE FANO * AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81 * * IF (MIN0(L,LP) .EQ. 0) THEN RME = 1.D0 ELSE IF ( K .EQ. 0) THEN RME = 2*L+1 RME = DSQRT(RME) ELSE I2G=L+LP+K IG=I2G/2 IF (I2G - 2*IG .NE. 0) THEN RME = 0.D0 ELSE I1=IG-L I2=IG-LP I3=IG-K QUSQRT=(2*L+1)*(2*LP+1) RME=DSQRT(QUSQRT)*DEXP((GAM(2*I1+1)+GAM(2*I2+1)+GAM(2*I3+1)- : GAM(I2G+2))/2.D0 +GAM(IG+1)-GAM(I1+1)-GAM(I2+1)-GAM(I3+1)) END IF END IF RETURN END * * ------------------------------------------------------------------ * S N * ------------------------------------------------------------------ * * 3 k * Evaluates the integral of (1/r) P (r) P (r) Z (i, j; r) with * i j * respect to r. * DOUBLE PRECISION FUNCTION SN(I,J,II,JJ,K) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS CALL ZK(J,JJ,K) SN = QUADS(I,II,3)*FINE RETURN END * * ------------------------------------------------------------------ * S Y M M E Q A N D S Y M M S L * ------------------------------------------------------------------ * * This routine is a modification of the one in "Computer Methods * for Mathematical Computation" by Forsythe, Malcolm, and Moler * (Prentice Hall, 1975) to solve a singular system of equations. * SUBROUTINE SYMMEQ(NDIM,N,A,X) * DOUBLE PRECISION A(NDIM,N),X(NDIM) * * SOLVE A SYSTEM OF LINEAR EQUATIONS A*X = 0 * * INPUT.. * * NDIM = DECLARED ROW DIMENSION OF THE ARRAY CONTAINING A. * N = ORDER OF THE MATRIX * A = COEFFICIENT MATRIX * B = CONSTANT VECTOR * * OUTPUT.. * * X = SOLUTION VECTOR with X(1) unchanged. * DOUBLE PRECISION T INTEGER NM1, I, J, K, KP1, KB, KM1, M NM1 = N-1 * * * L U FACTORIZATION WITHOUT PIVOTING * DO 35 K = N,3,-1 KP1= K-1 T = A(K,K) IF (T .EQ. 0.0D0) GO TO 35 * * COMPUTE MULTIPLIERS * DO 20 I = KP1,2,-1 A(I,K) = -A(I,K)/T 20 CONTINUE * * INTERCHANGE AND ELIMINATE BY COLUMNS * DO 30 J = KP1,2,-1 T = A(K,J) IF (T .EQ. 0.0D0) GO TO 30 DO 25 I = KP1,2,-1 A(I,J) = A(I,J) + A(I,K)*T 25 CONTINUE 30 CONTINUE 35 CONTINUE * * At this point it is assumed that the LU factorization * has already been performed. * ENTRY SYMMSL(NDIM,N,A,X) * DO 36 I = 2,N X(I) = - A(I,1) 36 CONTINUE DO 50 K=N,3,-1 T=X(K) IF (T.EQ.0.0D0) GO TO 50 DO 40 I=K-1,2,-1 X(I)=X(I)+A(I,K)*T 40 CONTINUE 50 CONTINUE * * BACK SUBSTITUTION * DO 80 K =2,N-1 IF (A(K,K) .EQ. 0.D0) THEN X(K) = 0.D0 ELSE X(K) = X(K)/A(K,K) END IF T = -X(K) DO 70 I =K+1,N X(I) = X(I) + A(I,K)*T 70 CONTINUE 80 CONTINUE X(N) = X(N)/A(N,N) RETURN END * * --------------------------------------------------------------- * T I N V I T * --------------------------------------------------------------- * * SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z, : IERR,RV1,RV2,RV3,RV4,RV6) * INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M), : RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,MACHEP DOUBLE PRECISION DSQRT,DABS,DFLOAT INTEGER IND(M) * * THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- * NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. * HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). * * THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL * SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, * USING INVERSE ITERATION. * * ON INPUT: * * NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL * ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM * DIMENSION STATEMENT; * * N IS THE ORDER OF THE MATRIX; * * D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX; * * E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX * IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY; * * E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, * WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. * E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN * THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM * OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN * 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0 * IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, * TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, * THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE; * * M IS THE NUMBER OF SPECIFIED EIGENVALUES; * * W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER; * * IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES * ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- * 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM * THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. * * ON OUTPUT: * * ALL INPUT ARRAYS ARE UNALTERED; * * Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. * ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO; * * IERR IS SET TO * ZERO FOR NORMAL RETURN, * -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH * EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS; * * RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. * * QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, * APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY * * ------------------------------------------------------------------ * * :::::::::: MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING * THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. * MACHEP = 16.0D0**(-13) FOR LONG FORM ARITHMETIC * ON S360 :::::::::: DATA MACHEP/1.D-12/ * IERR = 0 IF (M .EQ. 0) GO TO 1001 TAG = 0 ORDER = 1.0D0 - E2(1) Q = 0 * :::::::::: ESTABLISH AND PROCESS NEXT SUBMATRIX :::::::::: 100 P = Q + 1 * DO 120 Q = P, N IF (Q .EQ. N) GO TO 140 IF (E2(Q+1) .EQ. 0.0D0) GO TO 140 120 CONTINUE * :::::::::: FIND VECTORS BY INVERSE ITERATION :::::::::: 140 TAG = TAG + 1 S = 0 * DO 920 R = 1, M IF (IND(R) .NE. TAG) GO TO 920 ITS = 1 X1 = W(R) IF (S .NE. 0) GO TO 510 * :::::::::: CHECK FOR ISOLATED ROOT :::::::::: XU = 1.0D0 IF (P .NE. Q) GO TO 490 RV6(P) = 1.0D0 GO TO 870 490 NORM = DABS(D(P)) IP = P + 1 * DO 500 I = IP, Q 500 NORM = NORM + DABS(D(I)) + DABS(E(I)) * :::::::::: EPS2 IS THE CRITERION FOR GROUPING, * EPS3 REPLACES ZERO PIVOTS AND EQUAL * ROOTS ARE MODIFIED BY EPS3, * EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW :::::::::: EPS2 = 1.0D-3 * NORM EPS3 = MACHEP * NORM UK = DFLOAT(Q-P+1) EPS4 = UK * EPS3 UK = EPS4 / DSQRT(UK) S = P 505 GROUP = 0 GO TO 520 * :::::::::: LOOK FOR CLOSE OR COINCIDENT ROOTS :::::::::: 510 IF (DABS(X1-X0) .GE. EPS2) GO TO 505 GROUP = GROUP + 1 IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3 * :::::::::: ELIMINATION WITH INTERCHANGES AND * INITIALIZATION OF VECTOR :::::::::: 520 V = 0.0D0 * DO 580 I = P, Q RV6(I) = UK IF (I .EQ. P) GO TO 560 IF (DABS(E(I)) .LT. DABS(U)) GO TO 540 * :::::::::: WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF * E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY :::::::::: XU = U / E(I) RV4(I) = XU RV1(I-1) = E(I) RV2(I-1) = D(I) - X1 RV3(I-1) = 0.0D0 IF (I .NE. Q) RV3(I-1) = E(I+1) U = V - XU * RV2(I-1) V = -XU * RV3(I-1) GO TO 580 540 XU = E(I) / U RV4(I) = XU RV1(I-1) = U RV2(I-1) = V RV3(I-1) = 0.0D0 560 U = D(I) - X1 - XU * V IF (I .NE. Q) V = E(I+1) 580 CONTINUE * IF (U .EQ. 0.0D0) U = EPS3 RV1(Q) = U RV2(Q) = 0.0D0 RV3(Q) = 0.0D0 * :::::::::: BACK SUBSTITUTION * FOR I=Q STEP -1 UNTIL P DO -- :::::::::: 600 DO 620 II = P, Q I = P + Q - II RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) V = U U = RV6(I) 620 CONTINUE * :::::::::: ORTHOGONALIZE WITH RESPECT TO PREVIOUS * MEMBERS OF GROUP :::::::::: IF (GROUP .EQ. 0) GO TO 700 J = R * DO 680 JJ = 1, GROUP 630 J = J - 1 IF (IND(J) .NE. TAG) GO TO 630 XU = 0.0D0 * DO 640 I = P, Q 640 XU = XU + RV6(I) * Z(I,J) * DO 660 I = P, Q 660 RV6(I) = RV6(I) - XU * Z(I,J) * 680 CONTINUE * 700 NORM = 0.0D0 * DO 720 I = P, Q 720 NORM = NORM + DABS(RV6(I)) * IF (NORM .GE. 1.0D0) GO TO 840 * :::::::::: FORWARD SUBSTITUTION :::::::::: IF (ITS .EQ. 5) GO TO 830 IF (NORM .NE. 0.0D0) GO TO 740 RV6(S) = EPS4 S = S + 1 IF (S .GT. Q) S = P GO TO 780 740 XU = EPS4 / NORM * DO 760 I = P, Q 760 RV6(I) = RV6(I) * XU * :::::::::: ELIMINATION OPERATIONS ON NEXT VECTOR * ITERATE :::::::::: 780 DO 820 I = IP, Q U = RV6(I) * :::::::::: IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE * WAS PERFORMED EARLIER IN THE * TRIANGULARIZATION PROCESS :::::::::: IF (RV1(I-1) .NE. E(I)) GO TO 800 U = RV6(I-1) RV6(I-1) = RV6(I) 800 RV6(I) = U - RV4(I) * RV6(I-1) 820 CONTINUE * ITS = ITS + 1 GO TO 600 * :::::::::: SET ERROR -- NON-CONVERGED EIGENVECTOR :::::::::: 830 IERR = -R XU = 0.0D0 GO TO 870 * :::::::::: NORMALIZE SO THAT SUM OF SQUARES IS * 1 AND EXPAND TO FULL ORDER :::::::::: 840 U = 0.0D0 * DO 860 I = P, Q 860 U = U + RV6(I)**2 * XU = 1.0D0 / DSQRT(U) * 870 DO 880 I = 1, N 880 Z(I,R) = 0.0D0 * DO 900 I = P, Q 900 Z(I,R) = RV6(I) * XU * X0 = X1 920 CONTINUE * IF (Q .LT. N) GO TO 100 1001 RETURN * :::::::::: LAST CARD OF TINVIT :::::::::: END * * ---------------------------------------------------------------- * T Q L 2 * ---------------------------------------------------------------- * * SUBROUTINE TQL2(NM,N,D,E,Z,IERR) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION MACHEP DIMENSION D(N),E(N),Z(NM,N) MACHEP=1.387878878078144568D-17 IERR = 0 IF (N .EQ. 1) GO TO 1001 DO 100 I = 2, N 100 E(I-1) = E(I) F = 0.0 B = 0.0 E(N) = 0.0 DO 240 L = 1, N J = 0 H =MACHEP*(ABS(D(L)) + ABS(E(L))) IF (B .LT. H) B = H DO 110 M = L, N IF (ABS(E(M)) .LE. B) GO TO 120 110 CONTINUE 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 P = (D(L+1) - D(L)) / (2.0 * E(L)) R = SQRT(P*P+1.0) H = D(L) - E(L) / (P + SIGN(R,P)) DO 140 I = L, N 140 D(I) = D(I) - H F = F + H P = D(M) C = 1.0 S = 0.0 MML = M - L DO 200 II = 1, MML I = M - II G = C * E(I) H = C * P IF (ABS(P) .LT. ABS(E(I))) GO TO 150 C = E(I) / P R = SQRT(C*C+1.0) E(I+1) = S * P * R S = C / R C = 1.0 / R GO TO 160 150 C = P / E(I) R = SQRT(C*C+1.0) E(I+1) = S * E(I) * R S = 1.0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE 200 CONTINUE E(L) = S * P D(L) = C * P IF (ABS(E(L)) .GT. B) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE GO TO 1001 1000 IERR = L 1001 RETURN END * * -------------------------------------------------------------- * T R B A K 1 * -------------------------------------------------------------- * * SUBROUTINE TRBAK1(NM,N,A,E,M,Z) * INTEGER I,J,K,L,M,N,NM DOUBLE PRECISION A(NM,N),E(N),Z(NM,M) DOUBLE PRECISION S * * THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1, * NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. * HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). * * THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC * MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING * SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1. * * ON INPUT: * * NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL * ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM * DIMENSION STATEMENT; * * N IS THE ORDER OF THE MATRIX; * * A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- * FORMATIONS USED IN THE REDUCTION BY TRED1 * IN ITS STRICT LOWER TRIANGLE; * * E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL * MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY; * * M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED; * * Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED * IN ITS FIRST M COLUMNS. * * ON OUTPUT: * * Z CONTAINS THE TRANSFORMED EIGENVECTORS * IN ITS FIRST M COLUMNS. * * NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS. * * QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, * APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY * * ------------------------------------------------------------------ * IF (M .EQ. 0) GO TO 200 IF (N .EQ. 1) GO TO 200 * DO 140 I = 2, N L = I - 1 IF (E(I) .EQ. 0.0D0) GO TO 140 * DO 130 J = 1, M S = 0.0D0 * DO 110 K = 1, L 110 S = S + A(I,K) * Z(K,J) * :::::::::: DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1. * DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW :::::::::: S = (S / A(I,L)) / E(I) * DO 120 K = 1, L 120 Z(K,J) = Z(K,J) + S * A(I,K) * 130 CONTINUE * 140 CONTINUE * 200 RETURN * :::::::::: LAST CARD OF TRBAK1 :::::::::: END * * -------------------------------------------------------------- * T R E D 1 * -------------------------------------------------------------- * * SUBROUTINE TRED1(NM,N,A,D,E,E2) * INTEGER I,J,K,L,N,II,NM,JP1 DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N) DOUBLE PRECISION F,G,H,SCALE DOUBLE PRECISION DSQRT,DABS,DSIGN * * THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, * NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. * HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). * * THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX * TO A SYMMETRIC TRIDIAGONAL MATRIX USING * ORTHOGONAL SIMILARITY TRANSFORMATIONS. * * ON INPUT: * * NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL * ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM * DIMENSION STATEMENT; * * N IS THE ORDER OF THE MATRIX; * * A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE * LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. * * ON OUTPUT: * * A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- * FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER * TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED; * * D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX; * * E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL * MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO; * * E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. * E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. * * QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, * APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY * * ------------------------------------------------------------------ * DO 100 I = 1, N 100 D(I) = A(I,I) * :::::::::: FOR I=N STEP -1 UNTIL 1 DO -- :::::::::: DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0D0 SCALE = 0.0D0 IF (L .LT. 1) GO TO 130 * :::::::::: SCALE ROW (ALGOL TOL THEN NOT NEEDED) :::::::::: DO 120 K = 1, L 120 SCALE = SCALE + DABS(A(I,K)) * IF (SCALE .NE. 0.0D0) GO TO 140 130 E(I) = 0.0D0 E2(I) = 0.0D0 GO TO 290 * 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE H = H + A(I,K) * A(I,K) 150 CONTINUE * E2(I) = SCALE * SCALE * H F = A(I,L) G = -DSIGN(DSQRT(H),F) E(I) = SCALE * G H = H - F * G A(I,L) = F - G IF (L .EQ. 1) GO TO 270 F = 0.0D0 * DO 240 J = 1, L G = 0.0D0 * :::::::::: FORM ELEMENT OF A*U :::::::::: DO 180 K = 1, J 180 G = G + A(J,K) * A(I,K) * JP1 = J + 1 IF (L .LT. JP1) GO TO 220 * DO 200 K = JP1, L 200 G = G + A(K,J) * A(I,K) * :::::::::: FORM ELEMENT OF P :::::::::: 220 E(J) = G / H F = F + E(J) * A(I,J) 240 CONTINUE * H = F / (H + H) * :::::::::: FORM REDUCED A :::::::::: DO 260 J = 1, L F = A(I,J) G = E(J) - H * F E(J) = G * DO 260 K = 1, J A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 260 CONTINUE * 270 DO 280 K = 1, L 280 A(I,K) = SCALE * A(I,K) * 290 H = D(I) D(I) = A(I,I) A(I,I) = H 300 CONTINUE * RETURN * :::::::::: LAST CARD OF TRED1 :::::::::: END * * ---------------------------------------------------------------- * T R E D 2 * ---------------------------------------------------------------- * * SUBROUTINE TRED2(NM,N,A,D,E,Z) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION A(NM,N),D(N),E(N),Z(NM,N) DO 100 I = 1, N DO 100 J = 1, I Z(I,J) = A(I,J) 100 CONTINUE IF (N .EQ. 1) GO TO 320 DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0 SCALE = 0.0 IF (L .LT. 2) GO TO 130 DO 120 K = 1, L 120 SCALE = SCALE + ABS(Z(I,K)) IF (SCALE .NE. 0.0) GO TO 140 130 E(I) = Z(I,L) GO TO 290 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE F = Z(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0 DO 240 J = 1, L Z(J,I) = Z(I,J) / (SCALE * H) G = 0.0 DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) JP1 = J + 1 IF (L .LT. JP1) GO TO 220 DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE HH = F / (H + H) DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 260 CONTINUE DO 280 K = 1, L 280 Z(I,K) = SCALE * Z(I,K) 290 D(I) = H 300 CONTINUE 320 D(1) = 0.0 E(1) = 0.0 DO 500 I = 1, N L = I - 1 IF (D(I) .EQ. 0.0) GO TO 380 DO 360 J = 1, L G = 0.0 DO 340 K = 1, L 340 G = G + Z(I,K) * Z(K,J) DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE 380 D(I) = Z(I,I) Z(I,I) = 1.0 IF (L .LT. 1) GO TO 500 DO 400 J = 1, L Z(I,J) = 0.0 Z(J,I) = 0.0 400 CONTINUE 500 CONTINUE RETURN END * * ------------------------------------------------------------------ * V K * ------------------------------------------------------------------ * * k * Evaluates V (i,j) as defined by Blume and Watson (1962). * DOUBLE PRECISION FUNCTION VK(I,J,II,JJ,K) IMPLICIT DOUBLE PRECISION(A-H,O-Z) COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID : ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS CALL DYK(I,II,K) VK = QUADS(J,JJ,2)*FINE RETURN END IF (B .LT. H) B = H DO 110 M = L, N IF (ABS(E(M)) .LE. B) GO TO 120 110 CONTINUE 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 P = (D(L+1) - D(Latsp/src/COMP.f010064400002010000036000000154560631202346100131150ustar00cffcsf00000400000020* ------------------------------------------------------------------ * * COMP -- A PROGRAM FOR PRINTING DOMINANT CONTRIBUTIONS * * C O P Y R I G H T -- 1994 * * by C. Froese Fischer * Vanderbilt University * Nashville, TN 37235 USA * * July, 1984 * * Computer Physics Communication, Vol. 64, 399-405 (1991) *----------------------------------------------------------------------- * PROGRAM COMP IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(NOD=220,NWD=30,NWD2=2*NWD,NCD=100,NCD2=2*NCD) INTEGER Q(5),JV(NCD2),JL(NCD2),IP(NCD2) CHARACTER*1 ASTER,CH1,CH2 CHARACTER*3 FIN1 CHARACTER*3 EL(NWD),COUPLE(9),FINT(NCD2) CHARACTER*6 ATOM,TERM,ALABEL CHARACTER*24 CFILE, NAME CHARACTER*66 CONFIG(NCD2), LAB1 COMMON /STATE/LENGTH(NCD2),NCFG(2),NCF(2),IST(2) DIMENSION ET(NCD2),COEF(NCD2,NCD2) PARAMETER (IREAD=5,IWRITE=6) DATA ASTER/'*'/ * IU = 7 DO 100 ICASE = 1,1 * * ***** DETERMINE INFORMATION ABOUT FILES * CSUN iarg = iargc() CSUN if ( iarg .eq. 0) then WRITE(0,*) 'Enter name of .c file' READ(IREAD,'(A)') NAME CSUN else CSUN call getarg(1,NAME) CSUN end if jend = index(NAME,' ') CFILE = NAME(1:JEND-1)//'.c' OPEN(UNIT=7,FILE=CFILE,STATUS='OLD') M = 1 WRITE(0,*) ' What tolerance? :' READ(IREAD,*) TOL * * ***** READ THE CONFIGURATIONS * READ(IU,10) ATOM,ALABEL,ET(1) 10 FORMAT(3X,2A6,F16.8/) 15 READ(IU,14,END=18) (EL(K),Q(K),K=1,5),COEF(M,1) 14 FORMAT(5(1X,A3,1X,I2,1X),F10.8) READ(IU,'(9(5X,A3))',END=18) (COUPLE(J),J=1,9) NOCC = 0 16 IF (EL(NOCC+1) .NE. ' ' ) THEN NOCC = NOCC+1 IF (NOCC .LT. (5)) GO TO 16 END IF IF (NOCC .EQ. 0) GO TO 18 CALL PACK(NOCC,EL,Q,COUPLE,LAB1) * * 1. Separate the final term * J = INDEX(LAB1,' ')-1 CH1 = LAB1(J:J) IF (CH1 .GE. '0' .AND. CH1 .LE. '9') THEN J = J-4 ELSE J = J-3 ENDIF FIN1 = LAB1(J+2:J+3) LAB1(J+1:J+4) = ' ' * * 2. Delete set subscriP2 * * CH1 = LAB1(J:J) * IF (CH1.GE.'0' .AND. CH1.LE.'9') LAB1(J:J) = ' ' * * 3. If after removing the final term, there are no other * intermediate couplings prefaced by '_' and the last coupling * is the same as the final term, then the coupling for the final * term is omitted . * IF (INDEX(LAB1,'_') .EQ. 0) THEN CH2 = LAB1(J-2:J-1) IF (CH2 .EQ. FIN1) LAB1(J-2:J-1) = ' ' ENDIF CONFIG(M) = LAB1 K = 45 17 IF (CONFIG(M)(K:K) .EQ. ' ') THEN K = K-1 GO TO 17 END IF LENGTH(M) = K FINT(M) = FIN1 M = M+1 IF (M.GT.(NCD2)) THEN WRITE(0,'(A,I4)') : ' TOO MANY CONFIGURATIONS: MAXIMUM IS ', (NCD2)-1 END IF GO TO 15 18 NCF(ICASE)= M-1 CLOSE(UNIT=7) 100 CONTINUE WRITE(0,'(A/5X,A/5X,A/5X,A/A)') ' Compositions from:', : '1 name.c','2 name.l','3 name.j',' Enter selection' READ(IREAD,*) ICASE IF (ICASE .EQ. 1) THEN NCFG(1) = NCF(1) IP(1) = 1 JL(1) = 1 IST(1) = 1 JV(1) = 0 CALL OUTPUT(1,JV,JL,CONFIG,FINT,COEF,IP,TOL,ET) ELSE IF (ICASE .EQ. 2) THEN CFILE = NAME(1:JEND-1)//'.l' ELSE CFILE = NAME(1:JEND-1)//'.j' END IF * * **** If LS format, read sets of coefficients * IS = 1 DO 200 ICASE = 1,1 IL = NCF(ICASE) OPEN(UNIT=7,FILE=CFILE,STATUS='OLD') READ(7,'(A6,7X,F6.1,5X,I4,9X,I4)') ATOM,Z,NEL,NCFG(ICASE) 65 READ(7,'(//8X,I4,10X,I4)',END=190) JVV,MFOUND DO 63 III = 1,MFOUND READ(7,64) JL(IS),ET(IS),(COEF(I,IS),I=1,NCFG(ICASE)) 64 FORMAT(/I6,F16.8/(7F10.7)) IF (ICASE .EQ. 2) JL(IS) = JL(IS) + NCF(1) JV(IS) = JVV IS = IS+1 63 CONTINUE GO TO 65 190 IST(ICASE) = IS-1 200 CONTINUE IS = IS-1 CALL SORT(IS,ET,IP) CALL OUTPUT(IS,JV,JL,CONFIG,FINT,COEF,IP,TOL,ET) END IF END * * ------------------------------------------------------------------ * OUTPUT * ------------------------------------------------------------------ * SUBROUTINE OUTPUT(IS,JV,JL,CONFIG,FINT,COEF,IP,TOL,ET) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(NOD=220,NWD=30,NCD=100,NCD2=2*NCD) PARAMETER (IREAD=5,IWRITE=6) DIMENSION ET(*) COMMON /STATE/LENGTH(NCD2),NCFG(2),NCF(2),IST(2) CHARACTER*66 CONFIG(*) CHARACTER*3 FINT(*) INTEGER INDEX(NCD2),JV(NCD2),JL(NCD2),IP(*) DIMENSION COEF(NCD2,NCD2) LOGICAL FIRST,SECOND DO 100 II = 1,IS JS = IP(II) JSL = JL(JS) ICASE = 1 IF (JSL .GT. NCF(1)) ICASE = 2 K = LENGTH(JSL) WRITE(IWRITE,'(//1X,A,2X,A,2X,F4.1,F14.8)') : CONFIG(JSL)(1:K),FINT(JSL),JV(JS)/2.,ET(II) DO 1 I = 1,NCFG(ICASE) INDEX(I) = I 1 CONTINUE DO 2 I = 1,NCFG(ICASE) JP = I DO 3 J = I+1,NCFG(ICASE) IF (ABS(COEF(J,JS)) .GT. ABS(COEF(JP,JS))) JP = J 3 CONTINUE TEMP = COEF(I,JS) COEF(I,JS) = COEF(JP,JS) COEF(JP,JS) = TEMP ITEMP = INDEX(I) INDEX(I) = INDEX(JP) INDEX(JP) = ITEMP 2 CONTINUE IB = 0 IF (JS .GT. IST(1)) IB = NCF(1) FIRST = .TRUE. SECOND = .FALSE. DO 10 I = 1,NCFG(ICASE) J = INDEX(I) + IB K = LENGTH(J) IF (ABS(COEF(I,JS)) .GT. TOL) THEN IF (FIRST) THEN WRITE(IWRITE,'(1X,F12.7,2X,A,2X,A)') : COEF(I,JS),CONFIG(J)(1:K),FINT(J) FIRST = .FALSE. SECOND = .TRUE. ELSE IF (SECOND) THEN WRITE(IWRITE,'(1X,F12.7,2X,A,2X,A)') : COEF(I,JS),CONFIG(J)(1:K),FINT(J) SECOND = .FALSE. ELSE WRITE(IWRITE,'(1X,F12.7,2X,A,2X,A)') : COEF(I,JS),CONFIG(J)(1:K),FINT(J) SECOND = .TRUE. END IF END IF 10 CONTINUE 100 CONTINUE END * * ------------------------------------------------------------------ * SORT * -----