C-*- Fortran -*-
C
C molecule, from 1D ring
C total energy + correlation
C default: MP2
C
C -----> integrals in-core <------
C
C Configuration interaction including dressing of the CI matrix
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C ORTHO - programs for ab-initio calculations in localized orbitals
C Copyright (C) 2008 Peter Reinhardt (Univ. Paris VI, France)
C
C This program is free software: you can redistribute it and/or modify
C it under the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
C along with this program. If not, see .
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C DELCD Debug
C DELCI print Coulomb and Exchange Integrals
C DELCO calculate Fock operator from ONEINT, HCOU, and HEXC
C
C..DELCU UNFORMATTED READING O
C DELCL long output, all determinants
C DELCH shift the diagonal in DAVID
C..DELCF WE HAVE A ROUTINE FLU
C..DELC4 USE THE ROUTINES HPSR
C
C..DELCY DALTON ORDERING OF P-
C DELCM construct and dump diagonalize explicitely the Hamilton matrix
C
C..FILE 'common_flow.h'
C..FILE 'common_rsd.h'
C..FILE 'common_readbuf.h'
C..FILE 'nbuldef.h'
C..FILE 'blockl.h'
C..FILE 'etable.h'
C..FILE 'common_twoi.h'
C..FILE 'common_syst.h'
C..FILE 'common_detlst.h'
C..FILE 'common_consta.h'
C..FILE 'common_intu.h'
C..FILE 'common_civec.h'
C..FILE 'common_nact.h'
C..FILE 'common_vectco.h'
C..FILE 'common_basis.h'
C
C..FILE 'common_freeze.h'
C
PROGRAM ICMP
C
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /VECTCO/ CI(NBASM,NBASM),IOCCS(NBASM),IOCC(NBASM)
C.. INCLUDE 'common_vectco.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /CFREEZE/ IORBFZ(NBASM),IORBMP(NBASM)
C.. INCLUDE 'common_freeze.h'
PARAMETER (NE123M=600000)
COMMON /SCSC/ ETABLE(NE123M)
DIMENSION RDIAG(NDETMX)
C.. INCLUDE 'etable.h'
C
CHARACTER*8 PNAME
CHARACTER*15 CHFRZ(3)
DATA CHFRZ /' frozen ',' participating',' deleted '/
C
PNAME='ICMP MOL'
INCLUDE 'compiler_stamp'
WRITE(6,*) ' $Id: icmp.r,v 1.38 2008/04/29 09:10:30 reinh Exp $ '
X=CPTIME(3)
CALL DATING(PNAME,1)
C two-electron integrals
IUNIT4=53
C contracted and sorted two-electron integrals
IUNITZ=54
IUNITV=26
IUNITO=31
S2=SQRT(2.D0)
C
WRITE(6,*) ' ----------------------------------------------'
WRITE(6,*)
WRITE(6,*) ' I C M P - 1 molecule; from 1D ring systems'
WRITE(6,*) ' correlation by MP2 and others'
WRITE(6,*)
WRITE(6,*) ' ----------------------------------------------'
WRITE(6,*)
C
CALL RDINP
C
LMP2CO=.TRUE.
IF (LPERT) THEN
WRITE(6,*) ' MP2 PERTURBATION CORRECTIONS '
IF (LEPSN) WRITE(6,*) ' EPSTEIN-NESBET PERTURBATIONS '
END IF
IF (LMP2C) THEN
WRITE(6,*) ' Canonical MP2 '
LCIMP=.TRUE.
END IF
IF (LEXSCI) THEN
WRITE(6,*)
WRITE(6,*) ' we will do a selection via the exchange integral'
WRITE(6,*)
END IF
IF (LPERLOC) THEN
LMP2C=.TRUE.
LCIMP=.TRUE.
END IF
IF (LSCSMP) THEN
WRITE(6,*)
WRITE(6,*)
$ ' Spin-scaled MP2 of Stefan Grimme JCP 118 (2003) 9095'
WRITE(6,*)
END IF
IF (LCIMP) THEN
WRITE(6,*) ' diagonal approximation to the CI'
c$$$ IF (LCEPA0) THEN
c$$$ WRITE(6,*) ' CEPA-0 gives Epstein-Nesbet 2nd order'
c$$$ LEPSN=.TRUE.
c$$$ END IF
END IF
C
IF (LMP3) THEN
WRITE(6,*)
WRITE(6,*) ' third-order Moeller-Plesset perturbation '
$ ,'theory via determinants'
WRITE(6,*)
END IF
C
IF (LEN3) THEN
WRITE(6,*)
WRITE(6,*) ' third-order Epstein-Nesbet perturbation '
$ ,'theory via determinants'
WRITE(6,*)
END IF
IF (LEN2C) THEN
WRITE(6,*)
$ ' Epstein-Nesbet with Dressing and infinite summation in F'
END IF
IF (LLCCD) WRITE(6,*) ' Linearized Coupled-Cluster Corrections '
IF (LCISD) WRITE(6,*) ' CI of SINGLES and DOUBLES '
IF (LCEPA0) WRITE(6,*) ' CEPA-0 via dressing (LCCD, DMBPT-inf)'
IF (LKUTZ) WRITE(6,*) ' LCC(S)D'
IF (LACPF) WRITE(6,*) ' ACPF via dressing'
IF (LAQCC) WRITE(6,*) ' AQCC via dressing'
IF (LAQCCV) WRITE(6,*) ' AQCC-V via dressing'
IF (LCEPA2) WRITE(6,*) ' CEPA-2 via dressing'
IF (LCEPA3) WRITE(6,*) ' CEPA-3 via dressing '
IF (LSCSC) WRITE(6,*) ' size-consistent self-consistent CI'
C
C for all these we need all bielectronic integrals
C
IF (LLCCD .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LCISD .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LCEPA0.AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LKUTZ .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LACPF .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LAQCC .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LAQCCV.AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LCEPA2.AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LCEPA3.AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LSCSC .AND..NOT.LCIMP) LMP2CO=.FALSE.
IF (LMP3) LMP2CO=.FALSE.
IF (LEN3) LMP2CO=.FALSE.
C
IF (LEN2C) LMP2CO=.TRUE.
C
IF (LCIS) WRITE(6,*) ' CI MATRIX for SINGLES ONLY'
IF (LCID) WRITE(6,*) ' CI MATRIX for DOUBLES ONLY'
IF (LDELCU) THEN
WRITE(6,*) ' READING UNFORMATTED INTEGRALS, MAX. BUFFER LENGTH '
$ ,IWBULL
ELSE
WRITE(6,*) ' READING FORMATTED INTEGRALS'
END IF
WRITE(6,9115) THRINT,IPRINT
9115 FORMAT(' THRESHOLD FOR BIELECTRONIC INTEGRALS IS:',E11.4,/
$ ,' THE PRINT LEVEL IS SET TO ',I3)
CL WRITE(6,*) ' ADDITIONAL INFORMATION CONCERNING DETERMINANTS '
CD WRITE(6,*) ' DEBUG VERSION - LOTS OF OUTPUT'
C
IF (LMP2CO) THEN
WRITE(6,*)
WRITE(6,*) ' WE NEED ONLY INTEGRALS OF THE TYPE (OV|OV) '
WRITE(6,*)
END IF
C
IF (LSELEC) THEN
WRITE(6,*)
WRITE(6,*) ' SELECTING DETERMINANTS BY MP2 '
WRITE(6,*) ' THRESHOLD IS ',THRMP2
WRITE(6,*)
ELSE
WRITE(6,*)
WRITE(6,*) ' taking into account all possible determinants '
WRITE(6,*)
END IF
IF (LNATOR) THEN
WRITE(6,*)
WRITE(6,*) ' CALCULATING NATURAL ORBITALS'
WRITE(6,*)
END IF
IF (LEXSCI) THEN
WRITE(6,*)
WRITE(6,*) ' Selecting determinants via the exchange integral '
WRITE(6,*) ' Threshold is ',TRSEXY
WRITE(6,*)
END IF
IF (LTOTAL) THEN
WRITE(6,*)
WRITE(6,*) ' We will write total energies instead of'
$ ,' correlation energies'
WRITE(6,*)
END IF
C
C print levels:
C 0: default, only necessary information printed
C 2: coulomb & exchange integrals printed
C 5: functions printed
C 10:
C
WRITE(6,*)
C
C Konvention: 1, 2, ... NCELL
C
C read ftn26
C read information on system
C
C
IUNITR=26
OPEN(UNIT=IUNITR,FILE='SYSTEM.ORTHO',STATUS='OLD',
- FORM='FORMATTED',ERR=901)
READ(IUNITR,*) NATOM
WRITE(6,*)
C
C MOLCAS, DALTON: first all s, then all p, then all d ...
C so read (sort has been done by GENINPUT) given basis set
C
NSHL=0
NBAS=1
LMAX=0
DO IAT=1,NATOM
READ(IUNITR,*) IDUM,NSHLAT
DO ISH=1,NSHLAT
READ(IUNITR,*) ITYPE,NPRIM
LMAX=MAX(LMAX,ITYPE+1)
NBAS=NBAS+ITYPE+ITYPE+1
DO III=1,NPRIM
READ(IUNITR,*) XDUM
END DO
END DO
END DO
NBAS=NBAS-1
C
WRITE(6,*)
WRITE(6,*) ' READ INFORMATION ON SYSTEM '
WRITE(6,*) ' NATOMS ',NATOM
WRITE(6,*) ' NBAS ',NBAS
WRITE(6,*)
IF (NBAS.GT.NBASM) THEN
WRITE(6,*) 'NBAS, MAXIMUM: ',NBAS,NBASM
STOP 'INCREASE NBASM IN param.h AND RECOMPILE'
END IF
C
C read vector
C
WRITE(6,*)
WRITE(6,*) ' READING VECTOR FROM UNIT',IUNITO
OPEN(UNIT=IUNITO,FILE='VECTOR',FORM='FORMATTED',STATUS='OLD',ERR
$ =902)
READ(IUNITO,*) ((CI(I,J),I=1,NBAS),J=1,NBAS)
READ(IUNITO,*) (IOCC(I),I=1,NBAS)
READ(IUNITO,*) (IOCCS(I),I=1,NBAS)
CLOSE(IUNITO)
C
NOCC=0
DO I=1,NBAS
IF (IOCC(I).EQ.IOCCS(I)) NOCC=NOCC+1
END DO
C
NVIRT=NBAS-NOCC
WRITE(6,*)
WRITE(6,*) ' NOCC ',NOCC
WRITE(6,*) ' NVIRT ',NVIRT
WRITE(6,*)
IOFFZ=NOCC+NVIRT*(2+NOCC+NVIRT*(2+NOCC*2))
C
C a Bond CI - we can set the options after having determined NOCC
C
IF (LCILOC) THEN
WRITE(6,*)
IF (IBOND1.EQ.IBOND2) THEN
WRITE(6,*) ' Bond CI concerning intrabond ',IBOND1
ELSE
WRITE(6,*) ' Bond CI concerning interbond ',IBOND1,IBOND2
LCID=.TRUE.
END IF
WRITE(6,*)
LRESTO=.TRUE.
LFRZ=.TRUE.
INDX=0
DO I=1,NOCC
IF (I.EQ.IBOND1.OR.I.EQ.IBOND2) THEN
IORBFZ(I)=2
ELSE
IORBFZ(I)=1
END IF
END DO
END IF
C
IUNITF=14
WRITE(6,*) ' READING OVERLAP MATRIX FROM UNIT',IUNITF
OPEN(UNIT=IUNITF,FILE='OVERLAP',STATUS='OLD',FORM='FORMATTED',ERR
$ =903)
WRITE(6,*)
DO I=1,NBAS
DO J=1,NBAS
HCOU(I,J)=0.D0
END DO
END DO
8007 CONTINUE
READ(IUNITF,*,IOSTAT=KK) I,J,XDUM
IF (KK.NE.0) GO TO 8008
HCOU(I,J)=XDUM
HCOU(J,I)=XDUM
GO TO 8007
8008 CONTINUE
CLOSE(IUNITF)
C
IF (IPRINT.EQ.5) CALL PFUNC(CI,NBAS)
C
C read Fock matrix
C
IUNITF=23
OPEN(UNIT=IUNITF,FILE='FOCK',FORM='FORMATTED',STATUS='OLD',ERR
$ =904)
READ(IUNITF,*) IDUM1
WRITE(6,*) ' READING FOCK MATRIX FROM UNIT',IUNITF
WRITE(6,*)
READ(IUNITF,*) ((F(I,J),I=1,NBAS),J=1,NBAS)
READ(IUNITF,*) EDUM,EN,E1,E2
CLOSE(IUNITF)
WRITE(6,*) ' E0 E1 E2 ',EN,E1,E2
C in the case of frozen orbitals we have to save EN
ENO=EN
C
C F in MOs
C
CALL TRANSF(F)
WRITE(6,*)
WRITE(6,*) ' TRANSFORMED FOCK MATRIX'
FMX=0.D0
DO I=1,NOCC
DO J=NOCC+1,NBAS
FF=ABS(F(I,J))
IF (FF.GT.FMX) FMX=FF
END DO
END DO
WRITE(6,8102) FMX
8102 FORMAT(' LARGEST ELEMENT BETWEEN OCC/VIRT: ',E12.6,/)
WRITE(6,*)' -----------------------------------------------'
WRITE(6,*)
C
C one-electron matrix elements
C
C on HAMILTO is E-N + E_kin
C
IUNIT=12
OPEN(UNIT=IUNIT,FILE='HAMILTO',STATUS='OLD',ERR=995,
- FORM='FORMATTED')
220 CONTINUE
READ(IUNIT,*,IOSTAT=KK) I,J,HH
IF (KK.NE.0) GO TO 221
HONE(I,J)=HONE(I,J)+HH
IF (I.NE.J) HONE(J,I)=HONE(J,I)+HH
GO TO 220
221 CONTINUE
CLOSE (IUNIT)
C
CALL TRANSF(HONE)
C
C
C we introduce orbital deleting/freezing
C
C IORBFZ(NBASM), if 0, orbital is frozen, if 1 orbital participates
C IORBMP(NBASM), orbital mapping, important for READ53
C
DO I=1,NBAS
ORBEN(I)=F(I,I)
WRITE(6,*) ' ORBEN: ',I,ORBEN(I),CHFRZ(IORBFZ(I))
END DO
IF (LFRZ) THEN
CALL FREEZE
ELSE
DO I=1,NBAS
IORBMP(I)=I
IORBFZ(I)=2
END DO
END IF
IF (IPRINT.EQ.5) THEN
DO I=1,NBAS
DO J=1,I
IF (ABS(F(I,J)).GT.1.D-9)
- WRITE(6,*) ' PHOGG ', I,J,F(I,J)
END DO
END DO
END IF
DO I=1,NBAS
ORBEN(I)=F(I,I)
IF (IPRINT.GE.5) WRITE(6,*) ' ORBEN: ',I,ORBEN(I)
END DO
C
C count integrals
C
NBC=NBAS
NINTEG=0
DO I=1,NBAS
DO J=I,NBC
DO K=I,NBC
DO L=K,NBC
IF (K.EQ.I) THEN
IF (L.GE.J) NINTEG=NINTEG+1
ELSE
NINTEG=NINTEG+1
END IF
END DO
END DO
END DO
END DO
NXX=NBAS*(NBAS+1)/2
NXX=NXX*(NXX+1)/2
C
WRITE(6,*)
WRITE(6,*)
$ ' THE ABSOLUTE MAXIMUM NUMBER OF BIELECTRONIC INTEGRALS IS '
$ ,NINTEG,NXX
IUNIT4=53
CALL READ53(IUNIT4)
WRITE(6,*)
CALL TIMING('R2I ')
C
C recalculate the total energy
C
CALL TOTCAL(E1,E2)
C
C dimension of e-tables, if necessary
C
IF (LCEPA2.OR.LCEPA3.OR.LSCSC) THEN
C
C the e's
C table ETABLE(NE123)
C
C |---E1---|---E2---|---E3(oov)---|---E3(ovv)---|
C pointer
C 1 NE1 NE12 NE12A NE12B
C
C NE12B we can calculate in advance, if NE123 < NE12A, we will not dress
C
NBC=NBAS
NE1=NBAS
NE12=NE1+NBAS*(2*NBC+1)
NE12A=NE12+NOCC*(2*NOCC+1)*(2*NVIRT+1)
NE12B=NE12A+NOCC*(2*NVIRT+1)*(2*NVIRT+1)
C
IF (NE12B.GT.NE123M.AND.LSCSC) THEN
WRITE(6,*)
WRITE(6,*) ' WE WOULD NEED ',NE12B,' ENTRIES FOR THE DRESSING, '
$ ,'BUT HAVE ONLY ',NE123M
WRITE(6,*) ' WE WILL N O T DO THE (SC)^2 '
LSCSC =.FALSE.
END IF
IF (NE12.GT.NE123M) THEN
WRITE(6,*)
WRITE(6,*) ' WE WOULD NEED ',NE12,' ENTRIES FOR THE DRESSING, '
$ ,'BUT HAVE ONLY ',NE123M
WRITE(6,*) ' WE WILL N O T DO THE CEPA-2 or CEPA-3 '
LCEPA2 =.FALSE.
LCEPA3 =.FALSE.
END IF
IF (LCEPA2.OR.LCEPA3.OR.LSCSC) THEN
WRITE(6,*) ' DIMENSION OF THE E TABLES:'
WRITE(6,*)
WRITE(6,*) ' SIZE OF E1: ',NE1
WRITE(6,*) ' SIZE OF E2: ',NE12-NE1
IF (LSCSC) THEN
WRITE(6,*) ' SIZE OF E3(oov): ',NE12A-NE12
WRITE(6,*) ' SIZE OF E3(ovv): ',NE12B-NE12A
WRITE(6,*) ' IN TOTAL WE NEED:',NE12B,' PLACES FOR THE E''s'
ELSE
WRITE(6,*) ' IN TOTAL WE NEED:',NE12,' PLACES FOR THE E''s'
END IF
WRITE(6,*) ' ALLOCATED: ',NE123M
WRITE(6,*)
WRITE(6,*)
END IF
END IF
C
CALL TIMING('PREP')
C
C create the list of excited determinants, calculate diagonal and interaction
C with the reference
C
CALL MAKRSD
CALL TIMING('MAKD')
CALL INTRAC(IUNITZ)
CALL TIMING('DETG')
c$$$
c$$$ CALL VERIFI
c$$$ STOP ' VERIFI '
CALL FLUSH(6)
IF (LPERT) THEN
C Epstein Nesbet
CALL GREATC
CALL TIMING('PERT')
C
IF (LCIMP) THEN
IF (LCISD) THEN
IMODE=1
CALL APPROX(IMODE)
IF (.NOT.LRESTO) THEN
IMODE=11
CALL APPROX(IMODE)
END IF
CALL TIMING('CISD')
END IF
C
IF (LACPF) THEN
IMODE=7
CALL APPROX(IMODE)
CALL TIMING('ACPF')
END IF
C
IF (LCEPA0) THEN
IMODE=2
CALL APPROX(IMODE)
CALL TIMING('CEP0')
END IF
C
IF (LAQCC) THEN
IMODE=9
CALL APPROX(IMODE)
CALL TIMING('AQCC')
END IF
C
IF (LAQCCV) THEN
IMODE=10
CALL APPROX(IMODE)
CALL TIMING('AQCV')
END IF
C
IF (LCEPA2) THEN
IMODE=3
CALL APPROX(IMODE)
CALL TIMING('CEP2')
END IF
C
IF (LCEPA3) THEN
IMODE=4
CALL APPROX(IMODE)
CALL TIMING('CEP3')
END IF
C
IF (LSCSC) THEN
IMODE=5
CALL APPROX(IMODE)
CALL TIMING('SCSC')
END IF
C
IF (LMP2EG) THEN
IMODE=12
CALL APPROX(IMODE)
CALL TIMING('MP2E')
END IF
CALL TIMING('APPR')
END IF
C
END IF
CALL FLUSH(6)
C
C
IF (LMP3) THEN
CALL CALMP3
CALL TIMING('MP3 ')
END IF
IF (LEN3.AND..NOT.LCIMP) THEN
CALL CALEN3
CALL TIMING('EN3 ')
CALL EN23S
CALL TIMING('EN3S')
END IF
C can MP2
C
IF (LMP2C) THEN
C if we came with LPERLOC then we have to save the amplitudes first
IF (LPERLOC) THEN
CALL VNORM(VECT,1)
OPEN ( UNIT=59,FILE='ENVECT.SAV',FORM='UNFORMATTED',STATUS
$ ='UNKNOWN')
WRITE(59) (VECT(I),I=1,NDET2)
CLOSE(59)
CALL MP2VEC
OPEN ( UNIT=59,FILE='MPVECT.SAV',FORM='UNFORMATTED',STATUS
$ ='UNKNOWN')
WRITE(59) (VECT(I),I=1,NDET2)
CLOSE(59)
END IF
IMODE=8
C we have to save the diagonal to file, replace it by
C the simple diagonal, and restore it afterwards
OPEN(UNIT=59,FILE='DMP2C.TMP',FORM='UNFORMATTED',STATUS='UNKNOWN'
$)
C folded 1 (fixf $Revision: 1.3 $)
WRITE(59) (DIAG(I),I=1,NDET2)
CLOSE(59)
DO IDET=1,NDET2
INDI=ID0(1,IDET)
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
INDL=ID0(4,IDET)
IF (INDJ.EQ.0) THEN
DIAG(IDET)=0.D0
ELSE
I=ABS(INDI)
J=ABS(INDJ)
K=ABS(INDK)
L=ABS(INDL)
DDD=DIAG(IDET)
DIAG(IDET)=F(K,K)+F(L,L)-F(I,I)-F(J,J)
END IF
END DO
C
CALL LCCD(IMODE)
C
C restore the diagonal of the Hamilton matrix
OPEN(UNIT=59,FILE='DMP2C.TMP',FORM='UNFORMATTED',STATUS='OLD')
READ(59) (DIAG(I),I=1,NDET2)
CLOSE(59,STATUS='DELETE')
C
C for the LPERLOC option we add the saved amplitudes to the MP2C
C amplitudes, and evaluate the correlation energy. We have to put the
C MP2C amplitudes in intermediate normalization, and as well the dressed
C EN2 one.
C
IF (LPERLOC) THEN
CALL VNORM(VECT,1)
OPEN (UNIT=59,FILE='MPVECT.SAV',FORM='UNFORMATTED',STATUS
$ ='OLD')
READ(59) (HVECT(I),I=1,NDET2)
CLOSE(59,STATUS='DELETE')
C we form MP2C-MP2L
DO IDET=1,NDET2
VECT(IDET)=VECT(IDET)-HVECT(IDET)
END DO
C and MP2C-MP2L + EN2L(dressed)
OPEN (UNIT=59,FILE='ENVECT.SAV',FORM='UNFORMATTED',STATUS
$ ='OLD')
READ(59) (HVECT(I),I=1,NDET2)
CLOSE(59,STATUS='DELETE')
DO IDET=1,NDET2
VECT(IDET)=VECT(IDET)+HVECT(IDET)
END DO
C calculate the correlation energy
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,9124) 'PERLOC',EDUM
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,/
$ ,' ',45('='),//)
IF (LRESTO) CALL WCOMPL
END IF
CALL TIMING('MP2C')
END IF
C
C can MP2
C
IF (LEN2C) THEN
IF (LCISD) IMODE=1
IF (LCEPA0) IMODE=2
IF (LCEPA2) IMODE=3
IF (LCEPA3) IMODE=4
IF (LSCSC) IMODE=5
IF (LACPF) IMODE=7
IF (LAQCC) IMODE=9
IF (LAQCCV) IMODE=10
C Epstein-Nesbet with infinite Fock-matrix summation and dressing
CALL LCCD(IMODE)
CALL TIMING('EN2C')
END IF
C
C methods without approximation
C
IF (.NOT.LCIMP.AND..NOT.LEN2C) THEN
C
C LCCD
C
IF (LLCCD) THEN
IMODE=2
CALL LCCD(IMODE)
CALL TIMING('LCCD')
END IF
C
C the ICSD
C
IF (LCISD) THEN
IMODE=1
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('ICSD')
END IF
C
C the CEPA-0
C
IF (LCEPA0) THEN
IMODE=2
C CALL ICSD(IMODE)
CALL LCCD(IMODE)
CALL TIMING('CEP0')
END IF
C
IF (LKUTZ) THEN
IMODE=6
C CALL ICSD(IMODE)
CALL LCCD(IMODE)
CALL TIMING('KUTZ')
END IF
C
C the ACPF
C
IF (LACPF) THEN
IMODE=7
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('ACPF')
END IF
C
C the AQCC
C
IF (LAQCC) THEN
IMODE=9
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('AQCC')
END IF
C
C the AQCC-V
C
IF (LAQCCV) THEN
IMODE=10
CALL ICSD(IMODE)
CALL LCCD(IMODE)
CALL TIMING('AQCV')
END IF
C
C the CEPA-2
C
IF (LCEPA2) THEN
IMODE=3
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('CEP2')
END IF
C
C the CEPA-3
C
IF (LCEPA3) THEN
IMODE=4
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('CEP3')
END IF
C
C the (SC)^2
C
IF (LSCSC) THEN
IMODE=5
CALL ICSD(IMODE)
C CALL LCCD(IMODE)
CALL TIMING('SCSC')
END IF
C
C end of IF (.NOT.LCIMP)
END IF
C
IF (LNATOR) THEN
CALL NATORB
CALL TIMING('NATO')
END IF
C
C remove the VVVV2 file
OPEN(UNIT=55,FILE='VVVV2')
CLOSE(UNIT=55,STATUS='DELETE')
WRITE(6,*)
X=CPTIME(4)
CALL DATING(PNAME,2)
STOP
901 CONTINUE
WRITE(6,*) ' NO FILE FOUND ... '
STOP
902 CONTINUE
WRITE(6,*) ' NO FILE FOUND ... '
STOP
903 CONTINUE
WRITE(6,*) ' NO FILE FOUND ... '
STOP
904 CONTINUE
WRITE(6,*) ' NO FILE FOUND ... '
STOP
C
995 CONTINUE
WRITE(6,*) ' NO FILE FOUND ... '
STOP ' PLEASE SUPPLY FILE! '
END
C
SUBROUTINE TRANSF(A)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /VECTCO/ CI(NBASM,NBASM),IOCCS(NBASM),IOCC(NBASM)
C.. INCLUDE 'common_vectco.h'
DIMENSION AJKLM(NBASM,NBASM)
DIMENSION A(NBASM,NBASM)
C
DO J=1,NBAS
DO I=1,NBAS
AJKLM(I,J)=0.D0
END DO
END DO
C
DO J=1,NBAS
DO K=1,NBAS
BB=0.D0
DO L=1,NBAS
BB=BB+CI(L,J)*A(K,L)
END DO
AJKLM(K,J)=AJKLM(K,J)+BB
END DO
END DO
C
DO J=1,NBAS
DO I=1,NBAS
A(I,J)=0.D0
END DO
END DO
C
DO I=1,NBAS
C only J=I..NBAS, copying is cheaper
DO J=I,NBAS
SSS=0.D0
DO K=1,NBAS
SSS=SSS+AJKLM(K,J)*CI(K,I)
END DO
A(I,J)=A(I,J)+SSS
END DO
END DO
C
C copy A(I,J)=A(J,I)
C
DO I=1,NBAS
DO J=I+1,NBAS
A(J,I)=A(I,J)
END DO
END DO
RETURN
END
C
SUBROUTINE PFUNC(CI,NBP)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
DIMENSION CI(NBASM,NBASM)
DO IVEC=1,NBP
WRITE(6,*) ' function index ',IVEC
WRITE(6,'(5X,4E15.8)') (CI(J,IVEC),J=1,NBAS)
END DO
RETURN
END
C
FUNCTION HFIND(I1,J1,K1,L1,ICLASS)
C here we look in classes 1-11
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
LOGICAL LUP,LI,LJ,LK,LL
C
INDMN=ISTRTC(ICLASS)
INDMX=IFINC(ICLASS)
INDNUM=INDMX-INDMN+1
IF (INDNUM.EQ.0) THEN
HFIND=0.D0
RETURN
END IF
I=I1
J=J1
K=K1
L=L1
IF (I.GT.J) THEN
IDUM=I
I=J
J=IDUM
END IF
IF (K.GT.L) THEN
IDUM=K
K=L
L=IDUM
END IF
IF (I.GT.K) THEN
IDUM=I
I=K
K=IDUM
IDUM=J
J=L
L=IDUM
END IF
IF (I.EQ.K.AND.J.GT.L) THEN
IDUM=J
J=L
L=IDUM
END IF
C
IND=(INDMX+INDMN)/2
INC=(INDNUM+1)/4+2
C
100 CONTINUE
C WRITE(6,*) '395: ',ICLASS,INDNUM,IND,INC,(IH0(JJJ,IND),JJJ=1,4),I,J,K,L
IF (IH0(1,IND).LT.I) THEN
LUP=.TRUE.
ELSE IF (IH0(1,IND).GT.I) THEN
LUP=.FALSE.
ELSE IF (IH0(1,IND).EQ.I) THEN
IF (IH0(2,IND).LT.J) THEN
LUP=.TRUE.
ELSE IF (IH0(2,IND).GT.J) THEN
LUP=.FALSE.
ELSE IF (IH0(2,IND).EQ.J) THEN
IF (IH0(3,IND).LT.K) THEN
LUP=.TRUE.
ELSE IF (IH0(3,IND).GT.K) THEN
LUP=.FALSE.
ELSE IF (IH0(3,IND).EQ.K) THEN
IF (IH0(4,IND).LT.L) THEN
LUP=.TRUE.
ELSE IF (IH0(4,IND).GT.L) THEN
LUP=.FALSE.
ELSE IF (IH0(4,IND).EQ.L) THEN
HFIND=H0(IND)
RETURN
END IF
END IF
END IF
END IF
IF (LUP) THEN
IND=MIN(IND+INC,INDMX)
INC=(INC+1)/2
ELSE
IND=MAX(IND-INC,INDMN)
INC=(INC+1)/2
END IF
C
IF (INC.EQ.1) THEN
LI=IH0(1,IND).EQ.I
LJ=IH0(2,IND).EQ.J
LK=IH0(3,IND).EQ.K
LL=IH0(4,IND).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND=H0(IND)
RETURN
END IF
IF (IND.LT.INDMX) THEN
IND1=IND+1
LI=IH0(1,IND1).EQ.I
LJ=IH0(2,IND1).EQ.J
LK=IH0(3,IND1).EQ.K
LL=IH0(4,IND1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND=H0(IND1)
RETURN
END IF
END IF
IF (IND.GT.INDMN) THEN
IND1=IND-1
LI=IH0(1,IND1).EQ.I
LJ=IH0(2,IND1).EQ.J
LK=IH0(3,IND1).EQ.K
LL=IH0(4,IND1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND=H0(IND1)
RETURN
END IF
END IF
C WRITE(6,*) ' ICLASS: ',ICLASS,' WE HAVE NO INTEGRAL ...',I,J,K,L
HFIND=0.D0
RETURN
END IF
GO TO 100
END
C
FUNCTION HFIND12(I1,J1,K1,L1)
C here we look in classes 12+NOCC+1,12+NBAS
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
LOGICAL LUP,LI,LJ,LK,LL
C
I=I1
J=J1
K=K1
L=L1
IF (I.GT.J) THEN
IDUM=I
I=J
J=IDUM
END IF
IF (K.GT.L) THEN
IDUM=K
K=L
L=IDUM
END IF
IF (I.GT.K) THEN
IDUM=I
I=K
K=IDUM
IDUM=J
J=L
L=IDUM
END IF
IF (I.EQ.K.AND.J.GT.L) THEN
IDUM=J
J=L
L=IDUM
END IF
C
ICLASS=12
C
INDMX=IFINC(ICLASS)
INDMN=ISTRTC(ICLASS)
IND=(INDMX+INDMN)/2
INC=(INDMX-INDMN)/4+2
C
100 CONTINUE
C WRITE(6,*) '395: ',ICLASS,INDNUM,IND,INC,(IH0(JJJ,IND),JJJ=1,4),I,J,K,L
IF (IH0(1,IND).LT.I) THEN
LUP=.TRUE.
ELSE IF (IH0(1,IND).GT.I) THEN
LUP=.FALSE.
ELSE IF (IH0(1,IND).EQ.I) THEN
IF (IH0(2,IND).LT.J) THEN
LUP=.TRUE.
ELSE IF (IH0(2,IND).GT.J) THEN
LUP=.FALSE.
ELSE IF (IH0(2,IND).EQ.J) THEN
IF (IH0(3,IND).LT.K) THEN
LUP=.TRUE.
ELSE IF (IH0(3,IND).GT.K) THEN
LUP=.FALSE.
ELSE IF (IH0(3,IND).EQ.K) THEN
IF (IH0(4,IND).LT.L) THEN
LUP=.TRUE.
ELSE IF (IH0(4,IND).GT.L) THEN
LUP=.FALSE.
ELSE IF (IH0(4,IND).EQ.L) THEN
HFIND12=H0(IND)
RETURN
END IF
END IF
END IF
END IF
IF (LUP) THEN
IND=MIN(IND+INC,INDMX)
INC=(INC+1)/2
ELSE
IND=MAX(IND-INC,INDMN)
INC=(INC+1)/2
END IF
C
IF (INC.EQ.1) THEN
LI=IH0(1,IND).EQ.I
LJ=IH0(2,IND).EQ.J
LK=IH0(3,IND).EQ.K
LL=IH0(4,IND).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND12=H0(IND)
RETURN
END IF
IF (IND.LT.INDMX) THEN
IND1=IND+1
LI=IH0(1,IND1).EQ.I
LJ=IH0(2,IND1).EQ.J
LK=IH0(3,IND1).EQ.K
LL=IH0(4,IND1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND12=H0(IND1)
RETURN
END IF
END IF
IF (IND.GT.INDMN) THEN
IND1=IND-1
LI=IH0(1,IND1).EQ.I
LJ=IH0(2,IND1).EQ.J
LK=IH0(3,IND1).EQ.K
LL=IH0(4,IND1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
HFIND12=H0(IND1)
RETURN
END IF
END IF
C WRITE(6,*) ' ICLASS: ',ICLASS,' WE HAVE NO INTEGRAL ...',I,J,K,L
HFIND12=0.D0
RETURN
END IF
GO TO 100
END
SUBROUTINE HRANGE(I1,J1,K1,L1,HHH,NJET,HV,ID,JD,KD,LD
$ ,IPS,ITMX,LBLKL)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
DIMENSION HV(ITMX,LBLKL),ID(ITMX,LBLKL),JD(ITMX,LBLKL),
- KD(ITMX,LBLKL),LD(ITMX,LBLKL),IPS(ITMX)
C
IF (I1.EQ.J1.AND.K1.EQ.L1) THEN
KK=K1
II=I1
HCOU(II,KK)=HHH
HCOU(KK,II)=HHH
IF (IPRINT.EQ.5) THEN
WRITE(6,9911) KK,II,HHH
WRITE(6,9911) II,KK,HHH
END IF
END IF
IF (I1.EQ.K1.AND.J1.EQ.L1) THEN
JJ=J1
II=I1
HEXC(II,JJ)=HHH
HEXC(JJ,II)=HHH
IF (IPRINT.EQ.5) THEN
WRITE(6,9912) II,JJ,HHH
WRITE(6,9912) JJ,II,HHH
END IF
END IF
9911 FORMAT(' COULOMB: ',I4,I6,F20.12)
9912 FORMAT(' EXCHANGE: ',I4,I6,F20.12)
IF (I1.NE.0.AND.J1.NE.0.AND.K1.NE.0.AND.L1.NE.0) THEN
IF (ABS(HHH).GT.THRINT) THEN
NUMINT=NUMINT+1
C
C determine type of integral
C
ITYPE=IGETTY(I1,J1,K1,L1)
C
IF (LMP2CO.AND.(ITYPE.NE.3.AND.ITYPE.NE.9)) THEN
NJET=NJET+1
GO TO 1200
END IF
C
ISTRTC(ITYPE)=ISTRTC(ITYPE)+1
C
IPS(ITYPE)=IPS(ITYPE)+1
IF (IPS(ITYPE).EQ.LBLKL+1) THEN
IPS(ITYPE)=1
WRITE(ITYPE+55) (ID(ITYPE,JJ1),JJ1=1,LBLKL),
- (JD(ITYPE,JJ2),JJ2=1,LBLKL),
- (KD(ITYPE,JJ3),JJ3=1,LBLKL),
- (LD(ITYPE,JJ4),JJ4=1,LBLKL),
- (HV(ITYPE,JJ5),JJ5=1,LBLKL)
END IF
IIII=IPS(ITYPE)
ID(ITYPE,IIII)=I1
JD(ITYPE,IIII)=J1
KD(ITYPE,IIII)=K1
LD(ITYPE,IIII)=L1
HV(ITYPE,IIII)=HHH
c$$$ IF (ITYPE.EQ.9) WRITE(6,8001) ITYPE,IIII,I1,J1,K1,L1
8001 FORMAT(
- ' ITYPE: ',I3,' INUM: ',I4,' INDICES :',4I4)
1200 CONTINUE
ELSE
NJET=NJET+1
END IF
END IF
RETURN
END
C
SUBROUTINE INTSRT(IH0,H0,NUMINT)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
DIMENSION H0(NUMINT),IH0(4,NUMINT)
ISRT=0
C
C check lexical order of integrals
C
DO I=1,NUMINT-1
IF (IH0(1,I).GT.IH0(1,I+1)) THEN
ISRT=1
ELSE IF (IH0(1,I).EQ.IH0(1,I+1)) THEN
IF (IH0(2,I).GT.IH0(2,I+1)) THEN
ISRT=1
ELSE IF (IH0(2,I).EQ.IH0(2,I+1)) THEN
IF (IH0(3,I).GT.IH0(3,I+1)) THEN
ISRT=1
ELSE IF (IH0(3,I).EQ.IH0(3,I+1)) THEN
IF (IH0(4,I).GT.IH0(4,I+1)) THEN
ISRT=1
ELSE IF (IH0(4,I).EQ.IH0(4,I+1)) THEN
WRITE(6,'(2I7,3I4,I8,3I4)') (IH0(J,I),J=1,4),(IH0(K,I+1),K=1
$ ,4)
STOP 'IDENTICAL INDICES FOR DIFFERENT INTEGRALS ENCOUNTERED'
END IF
END IF
END IF
END IF
END DO
CALL TIMING('CHCK')
IF (ISRT.EQ.1) THEN
C
C MAXIMALLY POSSIBLE INDEX
C
WRITE(6,*) ' INTEGRALS HAVE TO BE SORTED '
IMX=NBAS+1
CALL HPSORT(NUMINT,H0,IH0)
CALL TIMING('SORT')
ELSE
WRITE(6,*) ' INTEGRALS ARE WELL-ORDERED'
END IF
RETURN
END
SUBROUTINE TOTCAL(E1,E2)
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
IF (LFRZ) THEN
WRITE(6,*)
WRITE(6,*) ' ENERGIES AFTER ORBITAL FREEZING '
WRITE(6,*)
END IF
WRITE(6,*)
EONE=0.D0
DO I=1,NOCC
EONE=EONE+HONE(I,I)
END DO
EONE=EONE*2.D0
WRITE(6,*) ' RECALCULATED ONE-ELECTRON ENERGY:',EONE
WRITE(6,*)
ETWO=0.D0
DO I=1,NOCC
DO J=1,NOCC
ETWO=ETWO+2.D0*HCOU(I,J)-HEXC(I,J)
END DO
END DO
ETOT=EN+EONE+ETWO
C
C store the HF energy in Common
EHF=ETOT
C
WRITE(6,*)
WRITE(6,*) ' RECALCULATED TOTAL ENERGY ',ETOT
WRITE(6,*) ' RECALCULATED ONE-ELECTRON ENERGY ',EONE
WRITE(6,*) ' RECALCULATED TWO-ELECTRON ENERGY ',ETWO
IF (LFRZ) THEN
WRITE(6,*) ' EFFECTIVE NUCLEAR REPULSION ',EN
ELSE
WRITE(6,*) ' NUCLEAR REPULSION ',EN
END IF
WRITE(6,*)
WRITE(6,*) ' READ TOTAL ENERGY ',E1+E2+ENO
WRITE(6,*) ' READ ONE-ELECTRON ENERGY ',E1
WRITE(6,*) ' READ TWO-ELECTRON ENERGY ',E2
WRITE(6,*) ' READ NUCLEAR ENERGY ',ENO
WRITE(6,*)
WRITE(6,*) ' DIFFERENCES '
IF (.NOT.LFRZ) THEN
WRITE(6,*) ' ONE EL. : ',EONE-E1
WRITE(6,*) ' TWO EL. : ',ETWO-E2
END IF
WRITE(6,*) ' TOTAL : ',ETOT-E1-E2-ENO
WRITE(6,*)
CALL TIMING('ETOT')
C
RETURN
C
END
C
SUBROUTINE GREATC
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
C perturbation
WRITE(6,*)
WRITE(6,*) ' ---- MP2, again ... ----------'
WRITE(6,*)
DO IDET=1,NDET2
IF (ID0(2,IDET).NE.0) THEN
I=ABS(ID0(1,IDET))
J=ABS(ID0(2,IDET))
K=ABS(ID0(3,IDET))
L=ABS(ID0(4,IDET))
EDEN=ORBEN(K)+ORBEN(L)-ORBEN(I)-ORBEN(J)
EDEN=-EDEN
VECT(IDET)=BVECT(IDET)/EDEN
ELSE
VECT(IDET)=0.D0
END IF
END DO
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,*)
WRITE(6,9324) 'MP2L ',EDUM
9324 FORMAT(' ',A6,' - ENERGY : ',F20.12,/,' ',45('='),//)
C
LRS=.FALSE.
LRD=.TRUE.
LSS=.FALSE.
LSD=.FALSE.
LDD=.TRUE.
VECT(IREFN)=1.D0
IF (LPHP) CALL PHPCAL(PHP)
C
IF (LEPSN) THEN
WRITE(6,*)
WRITE(6,*) ' -------- and spin-adapted Epstein-Nesbet ------'
WRITE(6,*)
WRITE(6,*) ' ONE SECOND: we try the plain Epstein-Nesbet first'
WRITE(6,*)
DO IDET=1,NDET2
IF (ID0(2,IDET).NE.0) THEN
VECT(IDET)=-BVECT(IDET)/DIAG(IDET)
ELSE
VECT(IDET)=0.D0
END IF
END DO
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,*)
WRITE(6,9124) 'EN 2 ',EDUM
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,/
$ ,' ',45('='),//)
C
VECT(IREFN)=1.D0
IF (LPHP) CALL PHPCAL(PHP)
WRITE(6,*)
$ ' and our spin-adapted interaction-reduced Epstein-Nesbet'
C
CALL ENSPIN
END IF
C
RETURN
END
C
SUBROUTINE LCCD(IMODE)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
CHARACTER*6 CHEXT
2 CONTINUE
C
IF (IMODE.EQ.2.OR.IMODE.EQ.8.OR.LCID) THEN
LSS=.FALSE.
LSD=.FALSE.
LDD=.TRUE.
ELSE
LSS=.TRUE.
LSD=.TRUE.
LDD=.TRUE.
END IF
C
IF (IMODE.EQ.1) THEN
CHEXT= 'CISD '
ELSE IF (IMODE.EQ.2) THEN
CHEXT= 'CEPA-0'
ELSE IF (IMODE.EQ.3) THEN
CHEXT= 'CEPA-2'
ELSE IF (IMODE.EQ.4) THEN
CHEXT= 'CEPA-3'
ELSE IF (IMODE.EQ.5) THEN
CHEXT= 'SCSC '
ELSE IF (IMODE.EQ.6) THEN
CHEXT= 'LCCSD '
ELSE IF (IMODE.EQ.7) THEN
CHEXT= 'ACPF '
ELSE IF (IMODE.EQ.8) THEN
CHEXT= 'MP2C '
ELSE IF (IMODE.EQ.9) THEN
CHEXT= 'AQCC '
ELSE IF (IMODE.EQ.10) THEN
CHEXT= 'AQCC-V'
END IF
IF (LEN2C) THEN
WRITE(6,*)
WRITE(6,*)
$ ' + + + + + + + + + + + + + + + + + + + + + + + + + + '
WRITE(6,*)
$ ' dressed Epstein-Nesbet with infinite summation in F '
WRITE(6,*)
WRITE(6,*)
$ ' dressed Epstein-Nesbet with infinite summation in F '
WRITE(6,*)
$ ' + + + + + + + + + + + + + + + + + + + + + + + + + + '
WRITE(6,*)
END IF
WRITE(6,*) ' WE TRY THE ',CHEXT
$ ,' with CONJUGATE GRADIENT METHODS '
C
WRITE(6,*)
WRITE(6,*) ' S-S S-D D-D'
WRITE(6,*) ' ',LSS,' ',LSD,' ',LDD
WRITE(6,*)
C
IF (LVECR1) THEN
C
C the LCCD starting vector will be read from file
C
IUNIT=89
OPEN(UNIT=IUNIT,FILE='LCCD_START',FORM='FORMATTED',STATUS='OLD'
$ ,ERR=1)
DO IDET=1,NDET2
READ(IUNIT,*,ERR=1) J,VECT(J)
HVECT(IDET)=0.D0
END DO
WRITE(6,*)
WRITE(6,*) ' READ STARTING VECTOR SUCCESSFULLY '
WRITE(6,*)
WRITE(6,*) ' COEFFICIENT IN THE STARTING VECTOR: ',VECT(IREFN)
CLOSE(IUNIT)
GO TO 3
1 CONTINUE
WRITE(6,*) ' ERROR IN OPENING FILE OR '
WRITE(6,*) ' ERROR DURING READ '
WRITE(6,*)
$ ' WE WILL CONTINUE WITH THE MP2 VECTOR as STARTING VECTOR '
LVECR1=.FALSE.
CLOSE(IUNIT)
CALL MP2VEC
3 CONTINUE
ELSE
CALL MP2VEC
C
END IF
C
C the right-hand side
IF (LCID.OR.IMODE.EQ.8.OR.IMODE.EQ.2.OR.LEN2C) THEN
DO I=1,NDET2
IF (ID0(2,I).EQ.0) THEN
HVECT(I)=0.D0
ELSE
HVECT(I)=-BVECT(I)
END IF
END DO
ELSE
DO I=1,NDET2
HVECT(I)=-BVECT(I)
END DO
END IF
C
C SOLVE THE SYSTEM OF LINEAR EQUATIONS
C
C we will not dress for IMODE=2,6,8 (LCCD,LCC(S)D,MP2C)
C
IF (IMODE.EQ.2.OR.IMODE.EQ.6.OR.IMODE.EQ.8) THEN
ITMAX=ITLCCD
TOL=TOLCCD
CALL LINCGX(NDET2,HVECT,VECT,TOL,ITMAX,ITER,ERR,IMODE)
ELSE
C we dress non-dynamically for IMODE=1,3,4,5,7,9,10
ITOL=3
ITMAX=ITLCCD
TOL=TOLCCD
C
CALL FLUSH(6)
C
C this would be the elegant way if it worked correctly
C CALL LINCGD(NDET2,HVECT,VECT,TOL,ITMAX,ITER,ERR,IMODE)
C the alternative: solve, dress, solve, dress, ...
C Store the diagonal
OPEN(UNIT=77,FILE='DIAG.TMQ',FORM='FORMATTED',STATUS='UNKNOWN')
WRITE(77,*) (DIAG(I),I=1,NDET2)
C
ITTT=0
TOLL=1.D-2
EC0=0.D0
1131 CONTINUE
CALL LINCGX(NDET2,HVECT,VECT,TOLL,ITMAX,ITER,ERR,6)
CALL ECORRC(NDET2,VECT,0,EC1)
REWIND(77)
READ(77,*) (DIAG(I),I=1,NDET2)
CALL EPVL(EC1,VECT,DIAG,IMODE)
DEC=ABS(EC0-EC1)
IF (DEC.GT.TOL) THEN
EC0=EC1
ITTT=ITTT+1
TOLL=MAX(TOLL*.1D0,TOL)
WRITE(6,9116) ITTT,EC0,DEC,TOLL
9116 FORMAT(' MACRO ITERATION No:',I4,' ECORR: ',F20.12,' DELTA: '
$ ,E12.3,' TOLL=',E10.2)
GO TO 1131
END IF
REWIND(77)
READ(77,*) (DIAG(I),I=1,NDET2)
CLOSE(77,STATUS='DELETE')
END IF
WRITE(6,*)
WRITE(6,*) ' REMAPPING OF COEFFICIENTS '
WRITE(6,*)
C
CALL VNORM(VECT,1)
WRITE(6,*) ' THE RESULT OF OUR EXERCISE: (interm. normalization)'
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GE.THRPRI)
- WRITE(6,'(I7,I8,3I5,F20.12)') IDET,(ID0(J,IDET),J=1,4)
$ ,VECT(IDET)
END DO
C
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,9124) CHEXT,EDUM
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,/
$ ,' ',45('='),//)
C
C we write the LCCD vector as starting vector for the CI
IUNIT=89
OPEN(IUNIT,FILE='LCCD_START',STATUS='UNKNOWN',FORM='FORMATTED')
DO IDET=1,NDET2
WRITE(IUNIT,*) IDET,VECT(IDET)
END DO
CLOSE(IUNIT)
WRITE(6,*) ' THE LCCD VECTOR IS ON FILE '
C
IF (LPHP) CALL PHPCAL(PHP)
IF (LQMC) CALL OUTQMC(CHEXT)
C
IF (LRESTO.AND..NOT.LPERLOC) CALL WCOMPL
C
RETURN
END
C
SUBROUTINE ICSD(IMODE)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
CHARACTER*6 CHEXT
C
C IMODE=1: CISD
C IMODE=2: CEPA-0
C IMODE=3: CEPA-1
C IMODE=4: CEPA-2
C IMODE=5: SCSC
C IMODE=7: ACPF
C
IF (IMODE.EQ.1) THEN
CHEXT='CISD '
ELSE IF (IMODE.EQ.2) THEN
CHEXT= 'CEPA-0'
ELSE IF (IMODE.EQ.3) THEN
CHEXT= 'CEPA-2'
ELSE IF (IMODE.EQ.4) THEN
CHEXT= 'CEPA-3'
ELSE IF (IMODE.EQ.5) THEN
CHEXT= '(SC)^2'
ELSE IF (IMODE.EQ.6) THEN
CHEXT= 'LCCSD '
ELSE IF (IMODE.EQ.7) THEN
CHEXT= 'ACPF '
ELSE IF (IMODE.EQ.9) THEN
CHEXT= 'AQCC '
ELSE IF (IMODE.EQ.10) THEN
CHEXT= 'AQCC-V'
END IF
WRITE(6,*)
WRITE(6,*) ' we try the ',CHEXT,' via dressing of the CISD matrix'
WRITE(6,*)
IF (LCIS) THEN
WRITE(6,*) ' YOU ASKED FOR A SINGLES-CI ONLY'
LRD=.FALSE.
LSD=.FALSE.
LDD=.FALSE.
END IF
IF (LCID) THEN
WRITE(6,*) ' YOU ASKED FOR A DOUBLES-CI ONLY'
LRS=.FALSE.
LSS=.FALSE.
LSD=.FALSE.
END IF
WRITE(6,*)
LRR=.TRUE.
LRS=.TRUE.
LRD=.TRUE.
LSS=.TRUE.
LSD=.TRUE.
LDD=.TRUE.
IF (IMODE.EQ.2) THEN
LRS=.FALSE.
LSS=.FALSE.
LSD=.FALSE.
END IF
IF (LCIS) THEN
WRITE(6,*) ' YOU ASKED FOR A SINGLES-CI ONLY'
LRD=.FALSE.
LSD=.FALSE.
LDD=.FALSE.
END IF
IF (LCID) THEN
WRITE(6,*) ' YOU ASKED FOR A DOUBLES-CI ONLY'
LRS=.FALSE.
LSS=.FALSE.
LSD=.FALSE.
END IF
WRITE(6,*)
WRITE(6,*) ' R-R R-S R-D S-S S-D D-D'
WRITE(6,*) ' ',LRR,' ',LRS,' ',LRD,' ',LSS,' ',LSD
$ ,' ',LDD
WRITE(6,*)
C
IF (LVECR2) THEN
C
C the CI starting vector will be read from file
C
IUNIT=89
OPEN(UNIT=IUNIT,FILE='CI_START',FORM='FORMATTED',STATUS='OLD'
$ ,ERR=1)
DO IDET=1,NDET2
READ(IUNIT,*,ERR=1) J,VECT(J)
HVECT(IDET)=0.D0
END DO
WRITE(6,*)
WRITE(6,*) ' READ STARTING VECTOR SUCCESSFULLY '
WRITE(6,*)
WRITE(6,*)
$ ' COEFFICIENT OF THE REFERENCE IN THE STARTING VECTOR: '
$ ,VECT(IREFN)
CLOSE(IUNIT)
C renormalize intermediate
EML=VECT(IREFN)
DO IDET=1,NDET2
VECT(IDET)=VECT(IDET)/EML
END DO
C
GO TO 3
1 CONTINUE
WRITE(6,*) ' ERROR IN OPENING FILE OR '
WRITE(6,*) ' ERROR DURING READ '
WRITE(6,*)
$ ' WE WILL CONTINUE WITH THE MP2 VECTOR as STARTING VECTOR '
CLOSE(IUNIT)
CALL MP2VEC
3 CONTINUE
ELSE
CALL MP2VEC
END IF
CALL ECORRC(NDET2,VECT,1,EDUM)
WRITE(6,*)
WRITE(6,*)
C
C that is the starting vector, now the diagonalization
C
IF (LCIS) THEN
C set the coefficients of the doubles to zero
DO IDET=1,NDET2
INDJ=ID0(2,IDET)
IF (INDJ.NE.0) VECT(IDET)=0.D0
END DO
END IF
IF (LCID) THEN
C set the coefficients of the singles to zero
DO IDET=1,NDET2
INDJ=ID0(2,IDET)
IF (INDJ.EQ.0.AND.IDET.NE.IREFN) VECT(IDET)=0.D0
END DO
END IF
C
ITMAX=NITDAV
TOL=TOLCI
WRITE(6,*)
WRITE(6,*) ' THE DAVIDSON PROCEDURE, taken from CASDI'
WRITE(6,*)
$ ' ------------------------------------------------'
WRITE(6,*)
C
CALL DAVID(NDET2,HVECT,VECT,TOL,ITMAX,ITER,ERR,IMODE)
C
IF (VECT(IREFN).EQ.0.D0) THEN
WRITE(6,*)
WRITE(6,*) ' REFERENCE HAS ZERO WEIGHT .... '
WRITE(6,*) ' THIS SEEMS A VERY LOW WEIGHT OF THE REFERENCE '
WRITE(6,*)
RETURN
END IF
C
IF (IMODE.EQ.1) THEN
C save the coefficient of the reference for the Davidson correction
ECD=VECT(IREFN)
ECD=ECD*ECD
ECD2=ECD/(2.D0*ECD-1.D0)
ECD=1.D0/ECD
END IF
CALL VNORM(VECT,2)
C
WRITE(6,*)
WRITE(6,*) ' THE RESULT OF OUR EXERCISE AS normalized COEFFICIENTS
$: '
C folded 1 (fixf $Revision: 1.3 $)
WRITE(6,*)
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GE.THRPRI)
- WRITE(6,'(I7,I8,3I5,F20.12)') IDET,(ID0(J,IDET),J=1,4)
$ ,VECT(IDET)
END DO
C
C intermediate normalization
C
CALL VNORM(VECT,1)
C we write the CI vector as starting vector for another CI
IUNIT=89
OPEN(IUNIT,FILE='CI_START',STATUS='UNKNOWN',FORM='FORMATTED')
DO IDET=1,NDET2
WRITE(IUNIT,'(I8,F20.12)') IDET,VECT(IDET)
END DO
CLOSE(IUNIT)
WRITE(6,*)
WRITE(6,*) ' THE CI VECTOR IS ON FILE '
WRITE(6,*)
C
IF (LQMC) CALL OUTQMC(CHEXT)
C
IF (IMODE.EQ.1) THEN
WRITE(6,*) ' CONFIGURATION INTERACTION OF SINGLES AND DOUBLES: '
WRITE(6,*)
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,*)
WRITE(6,9124) CHEXT,EDUM
C
DO IDET=1,NDET2
VECT(IDET)=VECT(IDET)*ECD
END DO
WRITE(6,9134) ECD
9134 FORMAT(/,' AND ADDING THE DAVIDSON CORRECTION 1/c_0^2: (FACTOR '
$ ,F15.12,')',/
$ ,' (P.E.M.Siegbahn, Chem.Phys.Lett. 55 (1978) 386)' ,/)
C WRITE(6,*)
C $ ' (S.R.Langhoff, E.R.Davidson, Int.J.Quant.Chem. 8 (1974) 61)'
CALL ECORRC(NDET2,VECT,0,EDUM)
WRITE(6,9124) 'DAV-1 ',EDUM
WRITE(6,*)
C
DO IDET=1,NDET2
VECT(IDET)=VECT(IDET)*ECD2/ECD
END DO
WRITE(6,9135) ECD2
9135 FORMAT(/,' OR THE CORRECTED '
$ ,'CORRECTION c_0^2/(2c_0^2 - 1): (FACTOR ',F15.12,')',/
$ ,' (E.R.Davidson, D.W.Silver, Chem.Phys.Lett 52 (1977) 403
$)',/)
C folded 1 (fixf $Revision: 1.3 $)
CALL ECORRC(NDET2,VECT,0,EDUM)
WRITE(6,9124) 'DAV-2 ',EDUM
WRITE(6,*)
ELSE
WRITE(6,*)
CALL ECORRC(NDET2,VECT,5,EDUM)
WRITE(6,9124) CHEXT,EDUM
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,/
$ ,' ',45('='),//)
END IF
C
IF (LPHP) CALL PHPCAL(PHP)
IF (LRESTO) CALL WCOMPL
RETURN
END
C
SUBROUTINE MAKRSD
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
LOGICAL LI,LJ,LIJ,LBOND
WRITE(6,*)
C
C determinants:
C 2 lists, first list: INDI,INDJ,INDK,INDL, INDI.LE.INDJ, INDK.LE.INDL
C INDI,INDJ occ., INDK,INDL virt.
C Spins are added as sign
C the list is sorted lexically including the sign
C
C singles have 1 zero as occ and virt, resp.
C the reference are 4 zeroes
C
C we treat the reference separately
C
C first: all possible ijab
C
NOV=NOCC+1
C
C the reference
C
INDX=0
IZERO=0
CALL FILDET(IZERO,IZERO,IZERO,IZERO,ID0,INDX)
IF (LRDET) THEN
WRITE(6,*)
WRITE(6,*) ' constructing list of determinants from a list '
WRITE(6,*)
OPEN(UNIT=67,FILE='PRIMDET.LST',FORM='FORMATTED',STATUS='OLD',ERR
$ =9901)
100 CONTINUE
READ(67,*,IOSTAT=KK) I,J
IF (KK.NE.0) GO TO 200
IF (J.EQ.0) THEN
DO IA=NOV,NBAS
CALL FILDET(I,IZERO,IA,IZERO,ID0,INDX)
END DO
ELSE
DO IA=NOV,NBAS
DO IB=IA,NBAS
CALL FILDET(I,J,IA,IB,ID0,INDX)
END DO
END DO
END IF
GO TO 100
200 CONTINUE
CLOSE(67)
ELSE
C the singles
NREFUS=0
NDTAKS=0
DO I=1,NOCC
DO IA=NOV,NBAS
IF (LEXSCI) THEN
IF (HEXC(I,IA).GT.TRSEXY) THEN
c$$$ WRITE(6,*) ' single excitation ',I,' -> ',IA,' taken: K='
c$$$ $ ,HEXC(I,IA)
CALL FILDET(I,IZERO,IA,IZERO,ID0,INDX)
NDTAKS=NDTAKS+1
ELSE
NREFUS=NREFUS+1
END IF
ELSE
CALL FILDET(I,IZERO,IA,IZERO,ID0,INDX)
END IF
END DO
END DO
C the doubles
DO I=1,NOCC
DO J=I,NOCC
LBOND=LCILOC.AND.I.EQ.J.AND.IBOND1.NE.IBOND2
WRITE(6,*) I,J,IBOND1,IBOND2,LBOND
DO IA=NOV,NBAS
DO IB=IA,NBAS
C
C estimate the energy contribution from MP2 term
C (ia|jb)*(2(ia|jb)-(ib|ja))/(F_i + F_j - F_a - F_b)
C
C if its over a threshold, then add the determinant
C
C for I=J or IA=IB we are in class 3
C otherwise we are in class 9
C
IF (I.EQ.J.OR.IA.EQ.IB) THEN
ICLASS=3
ELSE
ICLASS=9
END IF
C
H1=HFIND(I,IA,J,IB,ICLASS)
H2=HFIND(I,IB,J,IA,ICLASS)
EDEN=ORBEN(I)+ORBEN(J)-ORBEN(IA)-ORBEN(IB)
TERM=(H1*H1+H2*H2-H1*H2)/EDEN
C
IF (LSELEC) THEN
IF (ABS(TERM).GT.THRMP2) THEN
IF (.NOT.LBOND) CALL FILDET(I,J,IA,IB,ID0,INDX)
ELSE
IF (LEXSCI) THEN
C
C we test the six possibilities ia ib ja jb ij ab
C
T1=HEXC(I,IA)
T2=HEXC(J,IA)
T3=HEXC(I,IB)
T4=HEXC(J,IB)
T5=HEXC(I,J)
T6=HEXC(IA,IB)
TT=MIN(T1,T2)
TT=MIN(T3,TT)
TT=MIN(T4,TT)
TT=MIN(T5,TT)
TT=MIN(T6,TT)
IF (TT.GT.TRSEXY) THEN
c$$$ WRITE(6,*) ' double excitation ',I,J,' -> ',IA,IB
c$$$ $ ,' taken: ia ib ja jb ij ab = '
c$$$ WRITE(6,'(6F12.6)') T1,T2,T3,T4,T5,T6
IF (.NOT.LBOND) THEN
CALL FILDET(I,J,IA,IB,ID0,INDX)
NDTAKD=NDTAKD+1
ELSE
NREFUD=NREFUD+1
END IF
END IF
ELSE
NREFUD=NREFUD+1
END IF
END IF
ELSE
IF (.NOT.LBOND) CALL FILDET(I,J,IA,IB,ID0,INDX)
END IF
C
END DO
END DO
END DO
END DO
END IF
NDET1=INDX
WRITE(6,*) ' FOUND ',NDET1
$ ,' PRIMARY DETERMINANTS FOR THE REFERENCE CELL'
WRITE(6,*)
C
IF (LEXSCI) THEN
NDTOT=NDET1+NREFUS+NREFUD
WRITE(6,*) ' ACCEPTED ',NDTAKS,NDTAKD,' determinants '
WRITE(6,*) ' REFUSED ',NREFUS,NREFUD,' determinants '
WRITE(6,*) ' generated and tested in total ',NDTOT
$ ,' determinants '
END IF
C
NDET2=NDET1
CALL LEXSRT(ID0,NDET2)
C
C now we loop over the determinants and add all possible spin
c -combinations
C
NDIM=0
IDET2=NDET1+1
DO IDET=1,NDET1
IF (IDET2.GT.NDETMX-6) THEN
WRITE(6,*) ' WE HAVE NEARLY ALL OF ',NDETMX,' PLACES FILLED '
STOP ' NDETMX TOO SMALL '
END IF
I1=ID0(1,IDET)
J1=ID0(2,IDET)
K1=ID0(3,IDET)
L1=ID0(4,IDET)
IDTYP=ID0(5,IDET)
ISIG=SIGN(1,IDTYP)
IF (IDTYP.EQ.-15) THEN
IDTYP=-5
ISIG=-25
END IF
IDTYP=ABS(IDTYP)
C iiaa
IF (IDTYP.EQ.2) THEN
NDIM=NDIM+1
ID0(2,IDET)=-I1
ID0(4,IDET)=-K1
C iiab
ELSE IF (IDTYP.EQ.3) THEN
NDIM=NDIM+1
ID0(2,IDET)=-I1
ID0(4,IDET)=-L1
ID0(1,IDET2)= I1
ID0(2,IDET2)=-I1
ID0(3,IDET2)=-K1
ID0(4,IDET2)= L1
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
C
C ijaa
C
ELSE IF (IDTYP.EQ.4) THEN
NDIM=NDIM+1
ID0(2,IDET)=-J1
ID0(4,IDET)=-K1
ID0(1,IDET2)=-I1
ID0(2,IDET2)= J1
ID0(3,IDET2)= K1
ID0(4,IDET2)=-K1
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
C ijab
ELSE IF (IDTYP.EQ.5) THEN
NDIM=NDIM+2
ID0(1,IDET2)=-I1
ID0(2,IDET2)=-J1
ID0(3,IDET2)=-K1
ID0(4,IDET2)=-L1
ID0(5,IDET2)=ISIG
IF (ISIG.EQ.-25) THEN
ISIG=-1
ELSE
IDET2=IDET2+1
ID0(1,IDET2)= I1
ID0(2,IDET2)=-J1
ID0(3,IDET2)= K1
ID0(4,IDET2)=-L1
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
ID0(1,IDET2)=-I1
ID0(2,IDET2)= J1
ID0(3,IDET2)= K1
ID0(4,IDET2)=-L1
ID0(5,IDET2)=ISIG
END IF
IDET2=IDET2+1
ID0(1,IDET2)=-I1
ID0(2,IDET2)= J1
ID0(3,IDET2)=-K1
ID0(4,IDET2)= L1
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
ID0(1,IDET2)= I1
ID0(2,IDET2)=-J1
ID0(3,IDET2)=-K1
ID0(4,IDET2)= L1
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
ELSE IF (IDTYP.EQ.6) THEN
C i0a0
NDIM=NDIM+1
ID0(1,IDET2)=-I1
ID0(2,IDET2)= 0
ID0(3,IDET2)= -K1
ID0(4,IDET2)= 0
ID0(5,IDET2)=ISIG
IDET2=IDET2+1
END IF
END DO
C
NDET2=IDET2-1
NDIM=NDET2
WRITE(6,*)
WRITE(6,*) ' GENERATED ',NDET2,' SPIN DETERMINANTS '
C
C the first list of determinants has been fabricated
C sort the list lexically
C
CALL LEXSRT(ID0,NDET2)
C
IF (IPRINT.GE.6) THEN
WRITE(6,*)
WRITE(6,*) ' THE LIST OF DETERMINANTS '
WRITE(6,'(I4,I8,3I5,I8)')(I,(ID0(J,I),J=1,5),I=1,NDET2)
WRITE(6,*)
END IF
C
NDIM=NDET2
WRITE(6,*) ' THE DIMENSION OF THE HAMILTON MATRIX WILL BE ',
- NDIM,' X ',NDIM
WRITE(6,*)
C
C look for the reference
DO IDET=1,NDET2
INDI=ID0(1,IDET)
IF (INDI.EQ.0) THEN
WRITE(6,*) ' THE REFERENCE IS AT POSITION ',IDET
IREFN=IDET
END IF
END DO
C
C STOP 'MAKRSD'
C
RETURN
9901 CONTINUE
WRITE(6,*) ' no file found, please provide '
STOP ' file missing '
END
C
SUBROUTINE FILDET(I,J,K,L,ID0,INDX)
INCLUDE 'param.h'
DIMENSION ID0(5,*)
LOGICAL LIJ,LKL
C
INDX=INDX+1
IF (INDX.GT.NDETMX) STOP ' TOO MANY DETERMINANTS '
C WRITE(6,*) ' FILDET: ',INDX,I,J,K,L
C
C 0000 reference
C i0a0 singles
C ijab doubles
IF (J.EQ.0) THEN
C might be the reference or a single excitation
IF (I.EQ.0) THEN
C the reference
ID0(1,INDX)=0
ID0(2,INDX)=0
ID0(3,INDX)=0
ID0(4,INDX)=0
ID0(5,INDX)=7
ELSE
IF (K.EQ.0) STOP ' FILDET: J AND K are ZERO!'
IF (L.NE.0) STOP ' FOR A SINGLE EXCITATION L=0 NEEDED'
ID0(1,INDX)=I
ID0(2,INDX)=0
ID0(3,INDX)=K
ID0(4,INDX)=0
ID0(5,INDX)=6
END IF
ELSE
LIJ=I.EQ.J
LKL=K.EQ.L
IF (LIJ) THEN
IF (LKL) THEN
IDTYP=2
ELSE
IDTYP=3
END IF
ELSE
IF (LKL) THEN
IDTYP=4
ELSE
IDTYP=5
END IF
END IF
C
ID0(1,INDX)=I
ID0(2,INDX)=J
ID0(3,INDX)=K
ID0(4,INDX)=L
ID0(5,INDX)=IDTYP
END IF
C
RETURN
END
C
SUBROUTINE LEXSRT(ID0,N)
INTEGER ID0(5,N)
INTEGER IRA(5)
LOGICAL LCOMP4,LACT
C
C SORT BY ID0
C
IF (N.LT.2) GO TO 200
L=N/2+1
IR=N
10 CONTINUE
IF(L.GT.1)THEN
L=L-1
DO III=1,5
IRA(III)=ID0(III,L)
END DO
ELSE
DO III=1,5
IRA(III)=ID0(III,IR)
ID0(III,IR)=ID0(III,1)
END DO
IR=IR-1
IF (IR.EQ.1) THEN
DO III=1,5
ID0(III,1)=IRA(III)
END DO
GO TO 200
END IF
END IF
I=L
J=L+L
20 IF(J.LE.IR)THEN
IF (J.LT.IR)THEN
LACT=LCOMP4(ID0(1,J),ID0(1,J+1))
IF (LACT) THEN
J=J+1
END IF
END IF
LACT=LCOMP4(IRA,ID0(1,J))
IF(LACT)THEN
DO III=1,5
ID0(III,I)=ID0(III,J)
END DO
I=J
J=J+J
ELSE
J=IR+1
END IF
GOTO 20
END IF
DO III=1,5
ID0(III,I)=IRA(III)
END DO
GOTO 10
C
200 CONTINUE
RETURN
END
C
FUNCTION LCOMP4(IARR,JARR)
LOGICAL LCOMP4
INTEGER IARR(5),JARR(5)
C
IF (IARR(1).LT.JARR(1)) THEN
LCOMP4=.TRUE.
ELSE IF (IARR(1).GT.JARR(1)) THEN
LCOMP4=.FALSE.
ELSE
IF (IARR(2).LT.JARR(2)) THEN
LCOMP4=.TRUE.
ELSE IF (IARR(2).GT.JARR(2)) THEN
LCOMP4=.FALSE.
ELSE
IF (IARR(3).LT.JARR(3)) THEN
LCOMP4=.TRUE.
ELSE IF (IARR(3).GT.JARR(3)) THEN
LCOMP4=.FALSE.
ELSE
IF (IARR(4).LT.JARR(4)) THEN
LCOMP4=.TRUE.
ELSE IF (IARR(4).GT.JARR(4)) THEN
LCOMP4=.FALSE.
ELSE
STOP ' EQUAL DETERMINANTS ENCOUNTERED! '
END IF
END IF
END IF
END IF
RETURN
END
C
FUNCTION SNRM(N,SX)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER N,ITOL,I,ISAMAX
DIMENSION SX(N)
SNRM=0.
DO I=1,N
SNRM=SNRM+SX(I)**2
END DO
SNRM=SQRT(SNRM)
RETURN
END
C
SUBROUTINE ATIMES(N,X,R,IMODE)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
DIMENSION X(*),R(*)
IF (N.NE.NDET2) STOP ' ATIMES: N and NDET2 are different'
DO I=1,N
R(I)=0.D0
END DO
C
IF (LEN2C) THEN
CALL FDD(X,R)
ELSE
IF (IMODE.NE.8) THEN
IF (LSS) CALL HAMSS(X,R)
IF (LSD) CALL HAMSD(X,R)
IF (LDD) CALL HAMDD(X,R)
ELSE
CALL FDD(X,R)
END IF
END IF
9910 FORMAT(I10,2E20.12,E24.12)
RETURN
END
C
SUBROUTINE ASOLVE(N,B,X)
INCLUDE 'param.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION B(*),X(*)
IF (N.NE.NDIM) STOP ' ASOLVE: N .NE. NDIM !!!'
DO I=1,NDIM
IF (ABS(DIAG(I)).GT.1.D-9) THEN
X(I)=B(I)/DIAG(I)
ELSE
X(I)=0.D0
END IF
END DO
RETURN
END
C
SUBROUTINE HAMDD(X,R)
C
C here we construct the product H*Vector for the doubles
C
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
PARAMETER (ITMX=12,LBLKL=256)
COMMON /READBF/ HV(ITMX,LBLKL),ID(ITMX,LBLKL),JD(ITMX,LBLKL),
- KD(ITMX,LBLKL),LD(ITMX,LBLKL),IPS(ITMX)
C.. INCLUDE 'common_readbuf.h'
LOGICAL LI,LJ,LA,LB,LIJ,LIA,LIB,LJA,LJB,LAB
LOGICAL LREAD
DIMENSION X(*),R(*)
DIMENSION XX(NDETMX)
DIMENSION ISPIN(4,6)
C
C we fabricate a non-spin-adapted vector
C
C the vector R has been initialized before
C
NBC=NBAS
NOV=NOCC+1
C
C performes the construction matrix times vector
C ITR=0 matrix
C ITR=1 transpose
C H is hermitian, ITR has thus no effect
C
C all integrals with at least 2 equal indices in core
C
NDET21=NDET2+1
DO 1 IDET=1,NDET2
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
C here we skip the singles and the reference
IF (I2.EQ.0) GO TO 1
C
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
LIA=LI.EQV.LA
LIB=LI.EQV.LB
LJA=LJ.EQV.LA
LJB=LJ.EQV.LB
LAB=LA.EQV.LB
IF (LAB.NEQV.LIJ) STOP 'LOOP over IDET: ERROR in SPIN COUNTING'
INDI=ABS(I1)
INDJ=ABS(I2)
INDK=ABS(I3)
INDL=ABS(I4)
I=INDI
IF (I.NE.INDI) STOP
$ ' HAMDD: WE HAVE AN INCONSISTENCY IN I AND INDI'
J=INDJ
K=INDK
L=INDL
C
C we might have the same determinant in LIST 2
C
C the diagonal
IVZ=1
HHH=DIAG(IDET)
CL CALL PCASE(0,IDET,IDET,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,IDET,IVZ)
C
C ijab -> IjAb (if LIA), IjaB (if LIB)
C
I1R=-I1
I2R=I2
IF (I1R.NE.I2R) THEN
IF (LIA) THEN
I3R=-I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HEXC(I,K)
CL CALL PCASE(37,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LIB) THEN
I3R=I3
I4R=-I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HEXC(I,L)
CL CALL PCASE(38,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
C
C ijab -> iJAb (if LJA), iJaB (if LJB)
C
IF (I1R.NE.I2R) THEN
IF (LJA) THEN
I1R=I1
I2R=-I2
I3R=-I3
I4R=I4
IVZ=1
IVZ1=1
IVZ2=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HEXC(J,K)
CL CALL PCASE(39,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LJB) THEN
I1R=I1
I2R=-I2
I3R=I3
I4R=-I4
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HEXC(J,L)
CL CALL PCASE(40,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
C
C change 1 Index, same spin
C
C change first index
C
C loop over all occupied, includes INDJJ
C
DO II=1,NOCC
INDII=II
INDJJ=INDII
JJ=II
IF (INDI.NE.INDII) THEN
I1R=SIGN(INDII,I1)
I2R=I2
IF (I1R.NE.I2R) THEN
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(INDI,II)
HHH=HHH-HFIND(INDI,INDII,INDK,INDK,4)-HFIND(INDI,INDII,INDL
$ ,INDL,4)+HFIND(INDI,INDII,INDJ,INDJ,1)
IF (LIJ) HHH=HHH-HFIND(INDI,INDJ,INDII,INDJ,1)
IF (LIA) HHH=HHH+HFIND(INDI,INDK,INDII,INDK,3)
IF (LIB) HHH=HHH+HFIND(INDI,INDL,INDII,INDL,3)
CL CALL PCASE(1,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
C we change the spin and one of the equal spins in the virtuals
C (grace a Daniel Maynau)
C
I11R=-SIGN(INDII,I1)
IF (I11R.NE.I2) THEN
IF (INDK.NE.INDL) THEN
IF (LIA) THEN
I1R=I11R
I2R=I2
I3R=-I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDK,INDII,INDK,3)
CL CALL PCASE(2,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LIB) THEN
I1R=I11R
I2R=I2
I3R=I3
I4R=-I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(INDI,INDL,INDII,INDL,3)
CL CALL PCASE(3,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END IF
C
C change second index
C
C we are still in the loop over INDII, but have INDJJ=INDII
C
IF (INDJJ.NE.INDJ) THEN
I1R=I1
I2R=SIGN(INDJJ,I2)
IF (I2R.NE.I1R) THEN
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(J,JJ)
INDJJJ=INDJJ
INDAA=INDK
INDBB=INDL
HHH=HHH-HFIND(J,INDJJJ,INDAA,INDAA,4)-HFIND(J,INDJJJ,INDBB
$ ,INDBB,4)+HFIND(I,I,INDJ,INDJJ,1)
IF (LIJ) HHH=HHH-HFIND(I,INDJ,I,INDJJ,1)
IF (LJA) HHH=HHH+HFIND(J,INDAA,INDJJJ,INDAA,3)
IF (LJB) HHH=HHH+HFIND(J,INDBB,INDJJJ,INDBB,3)
CL CALL PCASE(4,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
C we change also the spin and one of the virtual spins
C
I22R=-SIGN(INDJJ,I2)
IF (I22R.NE.I1) THEN
IF (INDK.NE.INDL) THEN
INDJJJ=INDJJ
INDKK=INDK
INDLL=INDL
C CALL TURN4(INDJJ,INDK,INDL,IVJ,INDJJJ,INDKK,INDLL)
IF (LJA) THEN
I1R=I1
I2R=I22R
I3R=-I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(J,INDKK,INDJJJ,INDKK,3)
CL CALL PCASE(5,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LJB) THEN
I1R=I1
I2R=I22R
I3R=I3
I4R=-I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(J,INDLL,INDJJJ,INDLL,3)
CL CALL PCASE(6,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
END IF
END IF
END IF
END DO
C
C change third index
C
C calculate the integral < ijab | H | ijcb >
C
C H= F_ac + (bb|ac) - (ii|ac) - (jj|ac)
C - (ba|bc) Spin b = Spin a
C + (ia|ic) Spin i = Spin a
C + (ja|jc) Spin j = Spin a
C
C again we have one large loop over all virtuals
C KCELL: IVKK relativ zu IVK
C LCELL: IVLL relativ zu IVL
DO KK=NOV,NBAS
INDKK=KK
LL=KK
INDLL=INDKK
IF (INDKK.NE.INDK) THEN
I3R=SIGN(INDKK,I3)
I4R=I4
IF (I3R.NE.I4R) THEN
I1R=I1
I2R=I2
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(K,KK)
INDKKK=INDKK
INDLLL=INDL
INDJJ=INDJ
C CALL TURN4(INDKK,INDL,INDJ,IVK,INDKKK,INDLLL,INDJJ)
HHH=HHH-HFIND(I,I,INDK,INDKK,4)-HFIND(K,INDKKK,INDJJ,INDJJ,4)
- +HFIND(K,INDKKK,INDLLL,INDLLL,6)
IF (LIA) HHH=HHH+HFIND(I,INDK,I,INDKK,3)
IF (LJA) HHH=HHH+HFIND(K,INDJJ,INDKKK,INDJJ,3)
IF (LAB) HHH=HHH-HFIND(K,INDLLL,INDKKK,INDLLL,6)
CL CALL PCASE(7,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C we change the spin and the spins of the appropriate occupied
I33R=-SIGN(INDKK,I3)
IF (I33R.NE.I4) THEN
IF (INDI.NE.INDJ) THEN
IF (LIA) THEN
I1R=-I1
I2R=I2
I3R=I33R
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDKK,INDI,INDK,3)
CL CALL PCASE(8,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LJA) THEN
I1R=I1
I2R=-I2
I3R=I33R
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDKKK=INDKK
INDKKX=INDK
INDXX=INDJ
C CALL TURN4(INDKK,INDK,INDJ,IVJ,INDKKK,INDKKX,INDXX)
HHH=-HFIND(J,INDKKK,J,INDKKX,3)
CL CALL PCASE(9,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END IF
C
C change fourth index
C
C same loop, but INDLL=INDKK
C
IF (INDLL.NE.INDL) THEN
I3R=I3
I4R=SIGN(INDLL,I4)
IF (I3R.NE.I4R) THEN
I1R=I1
I2R=I2
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(L,LL)
INDLLL=INDLL
INDKKK=INDK
INDJJ=INDJ
C CALL TURN4(INDLL,INDK,INDJ,IVL,INDLLL,INDKKK,INDJJ)
HHH=HHH-HFIND(I,I,INDL,INDLL,4)-HFIND(L,INDLLL,INDJJ,INDJJ,4)
- +HFIND(L,INDLLL,INDKKK,INDKKK,6)
IF (LIB) HHH=HHH+HFIND(I,INDL,I,INDLL,3)
IF (LJB) HHH=HHH+HFIND(L,INDJJ,INDLLL,INDJJ,3)
IF (LAB) HHH=HHH-HFIND(L,INDKKK,INDLLL,INDKKK,6)
CL CALL PCASE(10,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
C change index (and spin of one occupied)
C
I44R=-SIGN(INDLL,I4)
IF (I44R.NE.I3) THEN
IF (INDI.NE.INDJ) THEN
IF (LIB) THEN
I1R=-I1
I2R=I2
I3R=I3
I4R=I44R
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(INDI,INDLL,INDI,INDL,3)
CL CALL PCASE(11,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LJB) THEN
I1R=I1
I2R=-I2
I3R=I3
I4R=I44R
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDKKK=INDK
INDLLL=INDLL
INDLLX=INDL
C CALL TURN4(INDK,INDLL,INDL,IVJ,INDKKK,INDLLL,INDLLX)
HHH=HFIND(J,INDLLL,J,INDLLX,3)
CL CALL PCASE(12,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END IF
C
END DO
C
C now we change 1 index and the spins
C spin has to be different - and indices
C
IF (.NOT.LIJ) THEN
C it is not necessary, that K.ne.L
IF (INDI.NE.INDJ) THEN
C iJ -> Ij
I1R=-I1
I2R=-I2
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C K_ij
HHH=HEXC(I,J)
CL CALL PCASE(13,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
DO JJ=1,NOCC
INDJJ=JJ
IF (INDJJ.NE.INDI.AND.INDJJ.NE.INDJ) THEN
C
C iJ -> jK
C
C in this case we have = (ij|kj)
C
I1R=-I2
I2R=SIGN(INDJJ,I2)
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDJ,INDJ,INDJJ,1)
CL CALL PCASE(14,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
C iJ -> kI
C
I1R=SIGN(INDJJ,I1)
I2R=-I1
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (ij|ki)
HHH=HFIND(INDJ,INDI,INDI,INDJJ,1)
CL CALL PCASE(15,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END IF
C
C now the virtuals
C
IF (INDK.NE.INDL) THEN
C
C kL -> Kl, a < b always
C
I1R=I1
I2R=I2
I3R=-I3
I4R=-I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HEXC(K,L)
CL CALL PCASE(16,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
DO KK=NOV,NBAS
INDKK=KK
IF (INDKK.NE.INDK.AND.INDKK.NE.INDL) THEN
C
C kL -> lM
C
I1R=I1
I2R=I2
I3R=-I4
I4R=SIGN(INDKK,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (kl|lm)
INDKKK=INDKK
INDLL=INDL
INDMM=INDL
C CALL TURN4(INDKK,INDL,INDL,IVK,INDKKK,INDLL,INDMM)
HHH=HFIND(K,INDLL,INDLL,INDKKK,6)
CL CALL PCASE(17,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
C kL -> mK
C
I1R=I1
I2R=I2
I3R=SIGN(INDKK,I3)
I4R=-I3
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (kl|km)
INDKKK=INDKK
INDLL=INDL
INDMM=INDL
C CALL TURN4(INDKK,INDL,INDL,IVK,INDKKK,INDLL,INDMM)
HHH=HFIND(K,INDLL,K,INDKKK,6)
CL CALL PCASE(18,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
END IF
END DO
END IF
C
C we have here also the changes to pairs, we are still in the loop IF (LIJ)
C but we exclude ij -> jj
C
IF (INDI.NE.INDJ) THEN
C
C pair of occupied ij -> kK
C for equal absolute indices we have the positive first
C
DO II=1,NOCC
INDII=II
IF (INDII.NE.INDI.AND.INDII.NE.INDJ) THEN
I1R=INDII
I2R=-INDII
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (ik|jk)
HHH=HFIND(INDI,INDII,INDJ,INDII,1)
CL CALL PCASE(19,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
ELSE
C INDI.EQ.INDJ
C
C inverse iI -> kL
C we include iI -> jJ
C
DO II=1,NOCC
INDII=II
IF (INDII.NE.INDI) THEN
DO JJ=1,NOCC
INDJJ=JJ
IF (INDJJ.NE.INDI) THEN
I1R=INDII
I2R=-INDJJ
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (ik|jk)
HHH=HFIND(INDI,INDII,INDI,INDJJ,1)
CL CALL PCASE(20,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END IF
END DO
END IF
C
IF (INDK.NE.INDL) THEN
C pair of virtuals ab -> cC
DO KK=NOV,NBAS
INDKK=KK
IF (INDKK.NE.INDK.AND.INDKK.NE.INDL) THEN
I1R=I1
I2R=I2
I3R=INDKK
I4R=-INDKK
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
C (km|lm)
INDXXX=INDK
INDLL=INDL
INDKKK=INDKK
C CALL TURN4(INDK,INDL,INDKK,IVK,INDXXX,INDLL,INDKKK)
HHH=HFIND(K,INDKKK,INDLL,INDKKK,6)
CL CALL PCASE(21,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
C inverse aA -> bC
C here we admit aA -> cC
ELSE
DO KK=NOV,NBAS
INDKK=KK
IF (INDKK.NE.INDK) THEN
DO LL=NOV,NBAS
INDLL=LL
IF (INDLL.NE.INDK) THEN
I1R=I1
I2R=I2
I3R=INDKK
I4R=-INDLL
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDXXX=INDK
INDLLL=INDLL
INDKKK=INDKK
C CALL TURN4(INDK,INDLL,INDKK,IVK,INDXXX,INDLLL,INDKKK)
HHH=HFIND(K,INDKKK,K,INDLLL,6)
CL CALL PCASE(22,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END IF
END DO
END IF
C
C end of the search for possible pairs
C
END IF
C
C end of the loop over determinants
C
1 CONTINUE
C
C for 2 differences we have 2 possibilities:
C I) we have all integrals in core (another loop over the determinants)
C II) we read the file of the bielectronic integrals and update the
C determinants involved with each integral read
C
C the common part needing classes 1 - 11
C we loop again ...
DO 2 IDET=1,NDET2
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
C again, we skip the singles and the reference
IF (I2.EQ.0) GO TO 2
C
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
LIA=LI.EQV.LA
LIB=LI.EQV.LB
LJA=LJ.EQV.LA
LJB=LJ.EQV.LB
LAB=LA.EQV.LB
INDI=ABS(I1)
INDJ=ABS(I2)
INDK=ABS(I3)
INDL=ABS(I4)
I=INDI
IF (I.NE.INDI) STOP
$ ' HAMDD: WE HAVE AN INCONSISTENCY IN I AND INDI '
J=INDJ
K=INDK
L=INDL
C we have NO pair index (this is true only for oo -> oo and vv -> vv)
C these we had already in the first loop
IF (INDI.NE.INDJ) THEN
C change 2 occupied
DO II=1,NOCC
INDII=II
C we neither create pairs nor we delete pairs ..
IF (INDII.NE.INDI.AND.INDII.NE.INDJ) THEN
C
C change 2 occupied (integrals (oo|oo) )
C
DO JJ=1,NOCC
INDJJ=JJ
IF (INDJJ.NE.INDI.AND.INDJJ.NE.INDJ) THEN
IF (INDII.LT.INDJJ) THEN
C equal spins for kl
IF (LIJ) THEN
I1R=SIGN(INDII,I1)
I2R=SIGN(INDJJ,I2)
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDII,INDJ,INDJJ,7)-HFIND(INDI,INDJJ
$ ,INDJ,INDII,7)
CL CALL PCASE(23,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
ELSE
C we have 2 possibilities of spins
C the first one
I1R=SIGN(INDII,I1)
I2R=SIGN(INDJJ,I2)
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDII,INDJ,INDJJ,7)
CL CALL PCASE(24,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C the other one
I1R=SIGN(INDII,I2)
I2R=SIGN(INDJJ,I1)
I3R=I3
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDJJ,INDJ,INDII,7)
CL CALL PCASE(25,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END DO
END IF
END DO
END IF
C
C if (INDK.NE.INDL) is the only part where we need the integrals VVVV
C
C
C here we can have paired indices, but we will not create the same index
C
C change 1 occupied, 1 virtual
C
C
DO II=1,NOCC
INDII=II
DO KK=NOV,NBAS
INDKK=KK
C
C 4 possibilities : I -> II, K -> KK
C J -> II, K -> KK
C I -> II, L -> KK
C J -> II, L -> KK
C
C in general: I,K same spin: (ov|ov) - (oo|vv)
C (left | right)
C diff spin: -(oo|vv)
C
C if we have to exchange the order of I1, I2, I3, I4 we have a minus ..
C
C the possibility of a spin change must be included
C (e.g. ijab -> iKaC)
C always (ov|ov) and (old|new)
C 1)
IF (INDII.NE.INDI.AND.INDKK.NE.INDK) THEN
IF (.NOT.LIJ.OR.(INDII.NE.INDJ.AND.INDKK.NE.INDL)) THEN
I1R=SIGN(INDII,I1)
I2R=I2
I3R=SIGN(INDKK,I3)
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(INDI,INDII,INDK,INDKK,10)
IF (LIA) HHH=HHH+HFIND(INDI,INDK,INDII,INDKK,9)
CL CALL PCASE(29,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
C also the spins are changed
C spin i = spin k is needed here
C
IF (LIA) THEN
IF (LIJ.OR.(INDKK.NE.INDL.AND.INDII.NE.INDJ)) THEN
I1R=-SIGN(INDII,I1)
I2R=I2
I3R=-SIGN(INDKK,I3)
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(INDI,INDK,INDII,INDKK,9)
CL CALL PCASE(30,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
C 2) J -> II, K -> KK
IF (INDII.NE.INDJ.AND.INDKK.NE.INDK) THEN
IF (.NOT.LIJ.OR.(INDII.NE.INDI.AND.INDKK.NE.INDL)) THEN
I1R=I1
I2R=SIGN(INDII,I2)
I3R=SIGN(INDKK,I3)
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDIX=INDII
INDKX=INDK
INDKKK=INDKK
C CALL TURN4(INDII,INDK,INDKK,IVJ,INDIX,INDKX,INDKKK)
HHH=-HFIND(J,INDIX,INDKX,INDKKK,10)
IF (LJA) HHH=HHH+HFIND(J,INDKX,INDIX,INDKKK,9)
CL CALL PCASE(31,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
IF (LJA) THEN
IF (LIJ.OR.(INDII.NE.INDI.AND.INDKK.NE.INDL)) THEN
C the spins are also changed
I1R=I1
I2R=-SIGN(INDII,I2)
I3R=-SIGN(INDKK,I3)
I4R=I4
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDIX=INDII
INDKX=INDK
INDKKK=INDKK
C CALL TURN4(INDII,INDK,INDKK,IVJ,INDIX,INDKX,INDKKK)
HHH=-HFIND(J,INDKX,INDIX,INDKKK,9)
CL CALL PCASE(32,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
C 3) I -> II, L -> KK
IF (INDII.NE.INDI.AND.INDKK.NE.INDL) THEN
IF (.NOT.LIJ.OR.(INDII.NE.INDJ.AND.INDKK.NE.INDK)) THEN
I1R=SIGN(INDII,I1)
I2R=I2
I3R=I3
I4R=SIGN(INDKK,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(INDI,INDII,INDL,INDKK,10)
IF (LIB) HHH=HHH+HFIND(INDI,INDL,INDII,INDKK,9)
CL CALL PCASE(33,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C change spin
C spin i = spin l needed
IF (LIB) THEN
IF (LIJ.OR.(INDII.NE.INDJ.AND.INDKK.NE.INDK)) THEN
C the spins are also changed
I1R=-SIGN(INDII,I1)
I2R=I2
I3R=I3
I4R=-SIGN(INDKK,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-HFIND(I,INDL,INDII,INDKK,9)
CL CALL PCASE(34,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
C 4)
IF (INDII.NE.INDJ.AND.INDKK.NE.INDL) THEN
IF (.NOT.LIJ.OR.(INDII.NE.INDI.AND.INDKK.NE.INDK)) THEN
I1R=I1
I2R=SIGN(INDII,I2)
I3R=I3
I4R=SIGN(INDKK,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDIX=INDII
INDKKK=INDKK
INDLL=INDL
C CALL TURN4(INDII,INDKK,INDL,IVJ,INDIX,INDKKK,INDLL)
HHH=-HFIND(J,INDIX,INDLL,INDKKK,10)
IF (LJB) HHH=HHH+HFIND(J,INDLL,INDIX,INDKKK,9)
CL CALL PCASE(35,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C change spin
C spin j = spin l needed
IF (LJB) THEN
IF (LIJ.OR.(INDII.NE.INDI.AND.INDKK.NE.INDK)) THEN
C the spins are also changed
I1R=I1
I2R=-SIGN(INDII,I2)
I3R=I3
I4R=-SIGN(INDKK,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
INDIX=INDII
INDLLL=INDL
INDKKK=INDKK
C CALL TURN4(INDII,INDL,INDKK,IVJ,INDIX,INDLLL,INDKKK)
HHH=HFIND(J,INDLLL,INDIX,INDKKK,9)
CL CALL PCASE(36,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END DO
END DO
C end loop over determinants
2 CONTINUE
CALL TIMING('DD X')
C
C now the part in-core or out-of-core
IF (LCORE) THEN
C a third loop
DO 3 IDET=1,NDET2
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
C again, we skip the singles and the reference
IF (I2.NE.0) THEN
C
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
LIA=LI.EQV.LA
LIB=LI.EQV.LB
LJA=LJ.EQV.LA
LJB=LJ.EQV.LB
LAB=LA.EQV.LB
I=ABS(I1)
J=ABS(I2)
K=ABS(I3)
L=ABS(I4)
C
IF (K.NE.L) THEN
C
C change 2 virtuals (integrals (vv|vv) )
C
DO KK=NOV,NBAS
IF (KK.NE.K.AND.KK.NE.L) THEN
DO LL=NOV,NBAS
IF (LL.NE.K.AND.LL.NE.L) THEN
IF (LL.GT.KK) THEN
C same spin
IF (LIJ) THEN
I1R=I1
I2R=I2
I3R=SIGN(KK,I3)
I4R=SIGN(LL,I4)
C IVZ=1
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HH1= HFIND12(K,KK,L,LL)
HH2= HFIND12(K,LL,L,KK)
HHH=HH1-HH2
CL CALL PCASE(26,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C we have 2 spin combinations
ELSE
C the first:
I1R=I1
I2R=I2
I3R=SIGN(KK,I3)
I4R=SIGN(LL,I4)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND12(K,KK,L,LL)
CL CALL PCASE(27,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C the second
I1R=I1
I2R=I2
I3R=SIGN(KK,I4)
I4R=SIGN(LL,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND12(K,LL,L,KK)
CL CALL PCASE(28,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END IF
END DO
END IF
END DO
END IF
END IF
3 CONTINUE
ELSE
C we have the integrals VVVV on disk
OPEN (UNIT=55,FILE='VVVV2',STATUS='OLD',FORM='UNFORMATTED')
112 CONTINUE
C the arrays ID, JD, KD, LD and HV are for 12 classes,we need only one
C class here
READ(55) (ID(1,JJ1),JJ1=1,LBLKL),
- (JD(1,JJ2),JJ2=1,LBLKL),
- (KD(1,JJ3),JJ3=1,LBLKL),
- (LD(1,JJ4),JJ4=1,LBLKL),
- (HV(1,JJ5),JJ5=1,LBLKL)
IF (ID(1,LBLKL).EQ.-1) THEN
INUMR=JD(1,LBLKL)
LREAD=.FALSE.
ELSE
INUMR=LBLKL
LREAD=.TRUE.
END IF
DO IIINT=1,INUMR
HHH=HV(1,IIINT)
K =ID(1,IIINT)
L =JD(1,IIINT)
KK =KD(1,IIINT)
LL =LD(1,IIINT)
C
C which determinants are coupled by this integral ?
C we have to loop over all possible occupied orbitals
C
C spins ++++, ----, +-+-, +--+, -++-, -+-+
C
ISPIN(1,1)=1
ISPIN(2,1)=1
ISPIN(3,1)=1
ISPIN(4,1)=1
ISPIN(1,2)=-1
ISPIN(2,2)=-1
ISPIN(3,2)=-1
ISPIN(4,2)=-1
ISPIN(1,3)= 1
ISPIN(2,3)=-1
ISPIN(3,3)= 1
ISPIN(4,3)=-1
ISPIN(1,4)= 1
ISPIN(2,4)=-1
ISPIN(3,4)=-1
ISPIN(4,4)= 1
ISPIN(1,5)=-1
ISPIN(2,5)= 1
ISPIN(3,5)= 1
ISPIN(4,5)=-1
ISPIN(1,6)=-1
ISPIN(2,6)= 1
ISPIN(3,6)=-1
ISPIN(4,6)= 1
C..FILE 'spintyp.h'
C integral (ab|cd) with a
C +
DO ITYP=5,6
C
IVZ=1
I1L= I*ISPIN(1,ITYP)
I2L= J*ISPIN(2,ITYP)
I3L= K*ISPIN(3,ITYP)
I4L= LL*ISPIN(4,ITYP)
I1R= I*ISPIN(1,ITYP)
I2R= J*ISPIN(2,ITYP)
I3R= L*ISPIN(3,ITYP)
I4R= KK*ISPIN(4,ITYP)
CALL ODET(I1L,I2L,I3L,I4L,IVZ)
CALL LOKI(I1L,I2L,I3L,I4L,INDXLL,IVZ)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXRR,IVZ)
INDXL=MAX(INDXLL,INDXRR)
INDXR=MIN(INDXLL,INDXRR)
c$$$ CALL PCASE(54,INDXL,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,INDXL,INDXR,IVZ)
C
IVZ=1
I1L= I*ISPIN(1,ITYP)
I2L= J*ISPIN(2,ITYP)
I3L= K*ISPIN(3,ITYP)
I4L= KK*ISPIN(4,ITYP)
I1R= I*ISPIN(1,ITYP)
I2R= J*ISPIN(2,ITYP)
I3R= L*ISPIN(3,ITYP)
I4R= LL*ISPIN(4,ITYP)
CALL ODET(I1L,I2L,I3L,I4L,IVZ)
CALL LOKI(I1L,I2L,I3L,I4L,INDXLL,IVZ)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXRR,IVZ)
INDXL=MAX(INDXLL,INDXRR)
INDXR=MIN(INDXLL,INDXRR)
c$$$ CALL PCASE(55,INDXL,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,INDXL,INDXR,IVZ)
C.. INCLUDE 'spintyp.h'
END DO
DO J=I+1,NOCC
C
C here we may have same spins or different spins
C
C different spins: 8 cases
C (iJ,Ij) X (aC,Ac) and (iJ,Ij) X (aD,Ad), thus 8 cases
C
C same spins: 4 cases
C
C
C
C
C
C spins ++++, ----, +-+-, +--+, -++-, -+-+
C orbitals ijac ijad
C
DO ITYP=1,6
C
IVZ=1
I1L= I*ISPIN(1,ITYP)
I2L= J*ISPIN(2,ITYP)
I3L= K*ISPIN(3,ITYP)
I4L= LL*ISPIN(4,ITYP)
I1R= I*ISPIN(1,ITYP)
I2R= J*ISPIN(2,ITYP)
I3R= L*ISPIN(3,ITYP)
I4R= KK*ISPIN(4,ITYP)
CALL ODET(I1L,I2L,I3L,I4L,IVZ)
CALL LOKI(I1L,I2L,I3L,I4L,INDXLL,IVZ)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXRR,IVZ)
INDXL=MAX(INDXLL,INDXRR)
INDXR=MIN(INDXLL,INDXRR)
c$$$ CALL PCASE(54,INDXL,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,INDXL,INDXR,IVZ)
C
IVZ=1
I1L= I*ISPIN(1,ITYP)
I2L= J*ISPIN(2,ITYP)
I3L= K*ISPIN(3,ITYP)
I4L= KK*ISPIN(4,ITYP)
I1R= I*ISPIN(1,ITYP)
I2R= J*ISPIN(2,ITYP)
I3R= L*ISPIN(3,ITYP)
I4R= LL*ISPIN(4,ITYP)
CALL ODET(I1L,I2L,I3L,I4L,IVZ)
CALL LOKI(I1L,I2L,I3L,I4L,INDXLL,IVZ)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXRR,IVZ)
INDXL=MAX(INDXLL,INDXRR)
INDXR=MIN(INDXLL,INDXRR)
c$$$ CALL PCASE(55,INDXL,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,INDXL,INDXR,IVZ)
C.. INCLUDE 'spintyp.h'
END DO
END DO
END DO
C
END DO
IF (LREAD) GO TO 112
CLOSE (55)
END IF
C
9910 FORMAT(I10,2E20.12,E24.12)
C
C
RETURN
END
C
SUBROUTINE UPD(R,X,H,I,I1,IZ)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
DIMENSION X(*),R(*)
LOGICAL LLEF,LRIG
H1=IZ*H
IF (I.EQ.I1) THEN
R(I1)=R(I1)+H1*X(I)
ELSE
R(I1)=R(I1)+H1*X(I)
R(I) =R(I) +H1*X(I1)
END IF
RETURN
END
C
SUBROUTINE UPDS(R,X,H,I,I1,IZ)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
DIMENSION X(*),R(*)
LOGICAL LLEF,LRIG
C
IF (I.EQ.0.OR.I1.EQ.0) STOP ' I or I1 = 0 !!'
H1=IZ*H
R(I1)=R(I1)+H1*X(I)
R(I) =R(I) +H1*X(I1)
C
RETURN
END
C
SUBROUTINE LOKI(I,J,K,L,INDXR,IVZ)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
LOGICAL LI,LJ,LK,LL,LUP
NTOBIG=NDET2+1
C
C look for determinant specified by I,J,K,L
C the sign of the determinant is NOT altered, and
C we take the sign of IVZ as input ONLY
C
C this is essentially the function HFIND
C
NUMI=(NDET2+1)/2
IND=NUMI
INC=IND/2+1
100 CONTINUE
C WRITE(6,*) '395: ',NUMINT,IND,INC,(ID0(JJJ,IND),JJJ=1,4),I,J,K,L
IF (ID0(1,IND).LT.I) THEN
LUP=.TRUE.
ELSE IF (ID0(1,IND).GT.I) THEN
LUP=.FALSE.
ELSE IF (ID0(1,IND).EQ.I) THEN
IF (ID0(2,IND).LT.J) THEN
LUP=.TRUE.
ELSE IF (ID0(2,IND).GT.J) THEN
LUP=.FALSE.
ELSE IF (ID0(2,IND).EQ.J) THEN
IF (ID0(3,IND).LT.K) THEN
LUP=.TRUE.
ELSE IF (ID0(3,IND).GT.K) THEN
LUP=.FALSE.
ELSE IF (ID0(3,IND).EQ.K) THEN
IF (ID0(4,IND).LT.L) THEN
LUP=.TRUE.
ELSE IF (ID0(4,IND).GT.L) THEN
LUP=.FALSE.
ELSE IF (ID0(4,IND).EQ.L) THEN
INDXR=IND
C we will not change the sign
C IVZ=IVZ
RETURN
END IF
END IF
END IF
END IF
C
IF (LUP) THEN
IND=MIN(IND+INC,NDET2)
INC=(INC+1)/2
ELSE
IND=MAX(IND-INC,1)
INC=(INC+1)/2
END IF
IF (INC.EQ.1) THEN
LI=ID0(1,IND).EQ.I
LJ=ID0(2,IND).EQ.J
LK=ID0(3,IND).EQ.K
LL=ID0(4,IND).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
INDXR=IND
RETURN
END IF
IF (IND.LT.NDET2) THEN
LI=ID0(1,IND+1).EQ.I
LJ=ID0(2,IND+1).EQ.J
LK=ID0(3,IND+1).EQ.K
LL=ID0(4,IND+1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
INDXR=IND+1
RETURN
END IF
END IF
IF (IND.GT.1) THEN
LI=ID0(1,IND-1).EQ.I
LJ=ID0(2,IND-1).EQ.J
LK=ID0(3,IND-1).EQ.K
LL=ID0(4,IND-1).EQ.L
IF (LI.AND.LJ.AND.LK.AND.LL) THEN
INDXR=IND-1
RETURN
END IF
END IF
INDXR=NTOBIG
RETURN
END IF
GO TO 100
END
C
SUBROUTINE UPDD(HMAT,H1,I,I1)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
CL WRITE(6,9901) ' I ',I,I1,H1,
CL - (ID0(J,I),J=1,4),(ID0(K,I1),K=1,4)
9901 FORMAT(' UPDD: ',A3,' ',I4,' <-> ',I4,E12.4,I8,3I4,I8,3I4)
RETURN
END
C
SUBROUTINE UPDDS(HMAT,H1,I,I1)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
CL WRITE(6,9901) ' I ',I,I1,H1,
CL - (ID0(J,I),J=1,4),(ID0(K,I1),K=1,4)
9901 FORMAT(' UPDDS: ',A3,' ',I4,' <-> ',I4,E12.4,I8,3I4,I8,3I4)
RETURN
END
SUBROUTINE ECORRC(N,X,IMODE,E)
INCLUDE 'param.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
DIMENSION X(*)
LOGICAL LIJ,LKL
IF (N.NE.NDIM) STOP ' ECORRC: N.NE.NDIM'
IF (N.NE.NDIM) STOP ' ECORRC: N.NE.NDIM'
C
C IMODE=0: write ECORR with format 9945 (medium)
C IMODE=1: write ECORR with format 9946 (short)
C IMODE=5: write ECORR with decomposition ii->kk, ...
C others: no output at all, just calculate ECORR
C
E1=0.D0
E2=0.D0
E1C1=0.D0
E1C2=0.D0
E1C3=0.D0
E1C4=0.D0
E2C1=0.D0
E2C2=0.D0
E2C3=0.D0
E2C4=0.D0
DO IDET=1,NDIM
INDI=ABS(ID0(1,IDET))
INDJ=ABS(ID0(2,IDET))
INDK=ABS(ID0(3,IDET))
INDL=ABS(ID0(4,IDET))
LIJ=INDI.EQ.INDJ
LKL=INDK.EQ.INDL
IW=SIGN(1,ID0(5,IDET))
IF (IW.EQ.-1) THEN
XW=2.D0
ELSE
XW=1.D0
END IF
IF (ABS(ID0(5,IDET)).GT.10) XW=1.D0
C WRITE(6,9901) INDI,INDJ,INDK,INDL,X(IDET),BVECT(IDET)
IF (INDJ.LE.NOCC.AND.INDJ.GT.0) THEN
CONTR=X(IDET)*BVECT(IDET)*XW
C WRITE(6,*) ' CONTRIBUTION: ',IDET,CONTR
E1=E1+CONTR
IF (LIJ) THEN
IF (LKL) THEN
E1C1=E1C1+CONTR
ELSE
E1C2=E1C2+CONTR
END IF
ELSE
IF (LKL) THEN
E1C3=E1C3+CONTR
ELSE
E1C4=E1C4+CONTR
END IF
END IF
ELSE
CONTR=X(IDET)*BVECT(IDET)*XW
E2=E2+CONTR
IF (LIJ) THEN
IF (LKL) THEN
E2C1=E2C1+CONTR
ELSE
E2C2=E2C2+CONTR
END IF
ELSE
IF (LKL) THEN
E2C3=E2C3+CONTR
ELSE
E2C4=E2C4+CONTR
END IF
END IF
END IF
END DO
9901 FORMAT(' ECORRC ',4I4,2F20.12)
C
C the correlation energy
C
ECORR=E1+.5D0*E2
IF (IMODE.EQ.1) THEN
WRITE(6,9945) ECORR
ELSE IF (IMODE.EQ.0) THEN
WRITE(6,9946) ECORR
ELSE IF (IMODE.EQ.5) THEN
EC1=E1C1+.5D0*E2C1
EC2=E1C2+.5D0*E2C2
EC3=E1C3+.5D0*E2C3
EC4=E1C4+.5D0*E2C4
WRITE(6,9913) ECORR,EC1,EC2,EC3,EC4,ECORR
END IF
9946 FORMAT(' ECORR: ',F20.12)
9945 FORMAT(' WE FIND AS CORRELATION ENERGY :',F25.10)
9913 FORMAT(//,' CORRELATION ENERGY: ',F20.12,//,
- ' CONTRIBUTIONS II -> KK ',F20.12,/,
- ' CONTRIBUTIONS II -> KL ',F20.12,/,
- ' CONTRIBUTIONS IJ -> KK ',F20.12,/,
- ' CONTRIBUTIONS IJ -> KL ',F20.12,/,
- 28X,'----------------------',/,13X,'SUM',10X,F20.12,/)
C
CALL FLUSH(6)
IF (LTOTAL) THEN
E=ECORR+EHF
ELSE
E=ECORR
END IF
RETURN
END
C
SUBROUTINE EVASOL(ITER,ERR,X,ECORR)
INCLUDE 'param.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /LBCEN/ ENERG
DIMENSION X(*)
LOGICAL LIJ,LKL
IF (ITER.EQ.0) THEN
ENERG=0.D0
CALL TIMING('IT 0')
END IF
IF (ITER.EQ.1) CALL TIMING('IT 1')
C
N=NDET2
E1=0.D0
E2=0.D0
E1C1=0.D0
E1C2=0.D0
E1C3=0.D0
E1C4=0.D0
E2C1=0.D0
E2C2=0.D0
E2C3=0.D0
E2C4=0.D0
DO IDET=1,NDIM
INDI=ABS(ID0(1,IDET))
INDJ=ABS(ID0(2,IDET))
INDK=ABS(ID0(3,IDET))
INDL=ABS(ID0(4,IDET))
LIJ=INDI.EQ.INDJ
LKL=INDK.EQ.INDL
IW=SIGN(1,ID0(5,IDET))
IF (IW.EQ.-1) THEN
XW=2.D0
ELSE
XW=1.D0
END IF
IF (ABS(ID0(5,IDET)).GT.10) XW=1.D0
C WRITE(6,9901) INDI,INDJ,INDK,INDL,X(IDET),BVECT(IDET)
IF (INDJ.LE.NOCC.AND.INDJ.GT.0) THEN
CONTR=X(IDET)*BVECT(IDET)*XW
E1=E1+CONTR
IF (LIJ) THEN
IF (LKL) THEN
E1C1=E1C1+CONTR
ELSE
E1C2=E1C2+CONTR
END IF
ELSE
IF (LKL) THEN
E1C3=E1C3+CONTR
ELSE
E1C4=E1C4+CONTR
END IF
END IF
ELSE
CONTR=X(IDET)*BVECT(IDET)*XW
E2=E2+CONTR
IF (LIJ) THEN
IF (LKL) THEN
E2C1=E2C1+CONTR
ELSE
E2C2=E2C2+CONTR
END IF
ELSE
IF (LKL) THEN
E2C3=E2C3+CONTR
ELSE
E2C4=E2C4+CONTR
END IF
END IF
END IF
END DO
9901 FORMAT(' ECORRC ',4I4,2F20.12)
C
C the correlation energy
C
ECORR=E1+.5D0*E2
C WRITE(6,9946) ITER,ECORR,ECORR-ENERG
9946 FORMAT(' ITER: ',I6,' ECORR: ',F20.12,' CHANGE: ',E12.2)
CALL FLUSH(6)
ERR=ABS(ENERG-ECORR)
ENERG=ECORR
RETURN
END
C
SUBROUTINE CHKDET
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C
C we try to find the determinants in our lists
C
DO IDET=1,NDET2
INDI=ID0(1,IDET)
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
INDL=ID0(4,IDET)
IVZ=1
CALL LOKI(INDI,INDJ,INDK,INDL,INDXR,IVZ)
IF (INDXR.NE.IDET) THEN
WRITE(6,*) ' DETERMINANT No',IDET,' NOT FOUND'
WRITE(6,*) ' FOUND INSTEAD ',INDXR,' :',(ID0(J,INDXR),J=1,4)
END IF
END DO
9101 FORMAT(I5,I7,3I4,I7)
9102 FORMAT(' LKI2: ',I5,I7,I4,5I7)
RETURN
END
C
SUBROUTINE ENSPIN
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
DIMENSION DDD(6),VVV(6),H(6,6),COEFF(6)
C
DO I=1,6
DO J=1,6
H(I,J)=0.D0
END DO
END DO
C
C S2=SQRT(2.D0)
C
E1=0.D0
E2=0.D0
E3=0.D0
E4=0.D0
DO IDET=1,NDET2
ITYPE=ID0(5,IDET)
IW=SIGN(1,ITYPE)
IF (IW.EQ.-1) THEN
XW=2.D0
ELSE
XW=1.D0
END IF
C
IF (ITYPE.EQ.-15) THEN
ITYPE=5
XW=1.D0
ELSE IF (ITYPE.EQ.-25) THEN
ITYPE=1
END IF
C
ITYPE=ABS(ITYPE)-1
IF (ITYPE.NE.0) THEN
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
INDI=ABS(I1)
INDJ=ABS(I2)
INDK=ABS(I3)
INDL=ABS(I4)
IF (ITYPE.EQ.1) THEN
E1=E1+XW*BVECT(IDET)*BVECT(IDET)/DIAG(IDET)
ELSE IF (ITYPE.EQ.2) THEN
I1R=INDI
I2R=-INDI
I3R=INDK
I4R=-INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(1)=BVECT(INDXR)/S2
DDD(1)=DIAG(INDXR)*.5D0
I1R=INDI
I2R=-INDI
I3R=-INDK
I4R=INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(2)=BVECT(INDXR)/S2
DDD(2)=DIAG(INDXR)*.5D0
XNOM=VVV(1)+VVV(2)
XNOM=XW*XNOM*XNOM
K=INDK
L=INDL
XDEN=DDD(1)+DDD(2)+HEXC(K,L)
E2=E2+XNOM/XDEN
ELSE IF (ITYPE.EQ.3) THEN
I1R=INDI
I2R=-INDJ
I3R=INDK
I4R=-INDK
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(1)=BVECT(INDXR)/S2
DDD(1)=DIAG(INDXR)*.5D0
I1R=-INDI
I2R=INDJ
I3R=INDK
I4R=-INDK
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(2)=BVECT(INDXR)/S2
DDD(2)=DIAG(INDXR)*.5D0
XNOM=VVV(1)+VVV(2)
XNOM=XW*XNOM*XNOM
I=INDI
J=INDJ
XDEN=DDD(1)+DDD(2)+HEXC(I,J)
E3=E3+XNOM/XDEN
ELSE IF (ITYPE.EQ.4) THEN
I1R=INDI
I2R=INDJ
I3R=INDK
I4R=INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(1)=BVECT(INDXR)
DDD(1)=DIAG(INDXR)
I1R=-INDI
I2R=-INDJ
I3R=-INDK
I4R=-INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(2)=BVECT(INDXR)
DDD(2)=DIAG(INDXR)
I1R=INDI
I2R=-INDJ
I3R=INDK
I4R=-INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(3)=BVECT(INDXR)
DDD(3)=DIAG(INDXR)
I1R=-INDI
I2R=INDJ
I3R=-INDK
I4R=INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(4)=BVECT(INDXR)
DDD(4)=DIAG(INDXR)
I1R=INDI
I2R=-INDJ
I3R=-INDK
I4R=INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(5)=BVECT(INDXR)
DDD(5)=DIAG(INDXR)
I1R=-INDI
I2R=INDJ
I3R=INDK
I4R=-INDL
IVZ=1
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
VVV(6)=BVECT(INDXR)
DDD(6)=DIAG(INDXR)
C
XNRM=0.D0
DO III=1,6
COEFF(III)=VVV(III)
XNRM=XNRM+COEFF(III)*COEFF(III)
END DO
IF (XNRM.NE.0.D0) THEN
XNRM=SQRT(XNRM)
DO III=1,6
COEFF(III)=COEFF(III)/XNRM
H(III,III)=DDD(III)
END DO
I=INDI
J=INDJ
K=INDK
L=INDL
c$$$ H(1,2)=0.D0
H(1,3)=HEXC(J,L)
H(1,4)=HEXC(I,K)
H(2,3)=H(1,4)
H(2,4)=H(1,3)
H(1,5)=-HEXC(J,K)
H(1,6)=-HEXC(I,L)
H(2,5)=H(1,6)
H(2,6)=H(1,5)
H(3,5)=HEXC(K,L)
H(3,6)=HEXC(I,J)
H(4,5)=H(3,6)
H(4,6)=H(3,5)
DO III=1,6
DO JJJ=1,III-1
H(III,JJJ)=H(JJJ,III)
END DO
END DO
XNOM=0.D0
XDEN=0.D0
DO III=1,6
XX=COEFF(III)
XNOM=XNOM+XX*VVV(III)
XD1=0.D0
DO JJJ=1,6
XD1=XD1+COEFF(JJJ)*H(III,JJJ)
END DO
XDEN=XDEN+XX*XD1
END DO
XNOM=XW*XNOM*XNOM
E4=E4+XNOM/XDEN
END IF
END IF
END IF
END DO
E1=-E1
E2=-E2
E3=-E3
E4=-E4
EEN2=E1+E2+E3+E4
WRITE(6,9914) EEN2,E1,E2,E3,E4,EEN2
9914 FORMAT(//
$ ,' CORRELATION ENERGY (SPIN-ADAPTED EPSTEIN-NESBET): ',/
$ ,12X,' total ',F20.12,//,' CONTRIBUTIONS II -> KK ',F20
$ .12,/,' CONTRIBUTIONS II -> KL ',F20.12,/
$ ,' CONTRIBUTIONS IJ -> KK ',F20.12,/
$ ,' CONTRIBUTIONS IJ -> KL ',F20.12,/,28X
$ ,'----------------------',/,13X,'SUM',10X,F20.12,/)
WRITE(6,*)
IF (LTOTAL) THEN
WRITE(6,9124) 'EN 2S ',EEN2+EHF
ELSE
WRITE(6,9124) 'EN 2S ',EEN2
END IF
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,/,' ',45('='),//)
RETURN
END
C
SUBROUTINE INTRAC(IUNITZ)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
LOGICAL LI,LJ,LK,LL,LIJ
C
C we have no spin-adapted determinants
C
C right-hand side and diagonal are fabricated in one loop
C
C check the list of determinants fabricated
IF (IPRINT.EQ.7) THEN
CALL CHKDET
CALL TIMING('CDET')
END IF
C
EMP2=0.D0
DO IDET=1,NDET2
INDI=ID0(1,IDET)
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
INDL=ID0(4,IDET)
IF (INDJ.EQ.0) THEN
IF (INDI.EQ.0) THEN
C the reference
DIAG(IDET)=0.D0
BVECT(IDET)=0.D0
ELSE
C we have INDI and INDK
INDI=ABS(INDI)
INDK=ABS(INDK)
I=INDI
K=INDK
D1=ORBEN(K)-ORBEN(I)
DIAG(IDET)=D1-HCOU(I,K)+HEXC(I,K)
BVECT(IDET)=F(I,K)
END IF
ELSE
LI=INDI.LE.0
LJ=INDJ.LE.0
LK=INDK.LE.0
LL=INDL.LE.0
LIJ=LI.EQV.LJ
INDI=ABS(INDI)
INDJ=ABS(INDJ)
INDK=ABS(INDK)
INDL=ABS(INDL)
I=INDI
J=INDJ
K=INDK
L=INDL
EI=ORBEN(I)
EJ=ORBEN(J)
EK=ORBEN(K)
EL=ORBEN(L)
EDEN=EI+EJ-EK-EL
DDD=F(K,K)+F(L,L)-F(I,I)-F(J,J)
- +HCOU(I,J)+HCOU(K,L)-HCOU(I,K)
- -HCOU(I,L)-HCOU(J,K)-HCOU(J,L)
IF (LIJ) THEN
DDD=DDD+HEXC(I,L)+HEXC(J,K)-HEXC(I,J)-HEXC(K,L)
DDD=DDD+HEXC(I,K)+HEXC(J,L)
ELSE
IF (LI.EQV.LK) THEN
DDD=DDD+HEXC(I,K)+HEXC(J,L)
ELSE
DDD=DDD+HEXC(I,L)+HEXC(J,K)
END IF
END IF
C IF (IDET.EQ.10) WRITE(6,*) ' IDET 10',I,J,K,L,DDD
C IF (IDET.EQ.13) WRITE(6,*) ' IDET 13',I,J,K,L,DDD
DIAG(IDET)=DDD
C
C the same spins have to be collected ...
C
IF (INDI.EQ.INDJ.OR.INDK.EQ.INDL) THEN
ICLASS=3
ELSE
ICLASS=9
END IF
IF (LIJ) THEN
BVECT(IDET)=HFIND(INDI,INDK,INDJ,INDL,ICLASS)-HFIND(INDI,INDL
$ ,INDJ,INDK,ICLASS)
ELSE
IF (LI.EQV.LK) THEN
BVECT(IDET)=HFIND(INDI,INDK,INDJ,INDL,ICLASS)
ELSE
BVECT(IDET)=HFIND(INDI,INDL,INDJ,INDK,ICLASS)
END IF
END IF
C
IW=SIGN(1,ID0(5,IDET))
IF (IW.EQ.-1) THEN
IF (ID0(5,IDET).LE.-15) THEN
XW=1.D0
ELSE
XW=2.D0
END IF
ELSE
XW=1.D0
END IF
ECONT=BVECT(IDET)*XW*BVECT(IDET)/EDEN
C
EMP2=EMP2+ECONT
END IF
END DO
C
WRITE(6,*)
WRITE(6,*) ' THE DIAGONAL OF THE HAMILTON MATRIX IS READY, '
WRITE(6,*) ' AS WELL AS THE INTERACTIONS WITH THE REFERENCE, '
WRITE(6,*) ' DIMENSION IS ',NDET2
WRITE(6,9946) EMP2
9946 FORMAT(/, ' RECALCULATED MP2 - ENERGY ',F20.12,/)
C
RETURN
END
C
SUBROUTINE HAMSS(X,R)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
LOGICAL LI,LA
DIMENSION X(*),R(*)
IZERO=0
NOV=NOCC+1
NDET21=NDET2+1
C
DO IDET=1,NDET2
I2=ID0(2,IDET)
IF (I2.EQ.0) THEN
I1=ID0(1,IDET)
IF (I1.NE.0) THEN
C the diagonal
HHH=DIAG(IDET)
INDXR=IDET
INDX1=NDET21
INDX2=NDET21
IVZ=1
CL CALL PCASE(89,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
C
LI=I1.LT.0
INDI=ABS(I1)
I=INDI
I3=ID0(3,IDET)
LA=I3.LT.0
IF (LI.NEQV.LA) STOP ' SPIN ERROR IN HAMSS '
INDK=ABS(I3)
K=INDK
C change spins
I1R=-I1
I3R=-I3
IVZ=1
CALL LOKI(I1R,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HEXC(I,K)
CL CALL PCASE(80,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C change i
DO II=1,NOCC
INDII=II
IF (INDII.NE.INDI) THEN
I1R=SIGN(INDII,I1)
IVZ=1
CALL LOKI(I1R,IZERO,I3,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(I,II)-HFIND(I,INDII,INDK,INDK,4)
- +HFIND(I,INDK,INDII,INDK,3)
CL CALL PCASE(81,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C and spin
I1R=-SIGN(INDII,I1)
I3R=-I3
IVZ=1
CALL LOKI(I1R,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(I,INDK,INDII,INDK,3)
CL CALL PCASE(82,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
C change k
DO KK=NOV,NBAS
INDKK=KK
IF (INDKK.NE.INDK) THEN
I3R=SIGN(INDKK,I3)
IVZ=1
CALL LOKI(I1,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(K,KK)+HFIND(I,INDK,I,INDKK,3)
- -HFIND(I,I,INDK,INDKK,4)
CL CALL PCASE(83,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C change spin
I3R=-SIGN(INDKK,I3)
I1R=-I1
IVZ=1
CALL LOKI(I1R,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(I,INDK,I,INDKK,3)
CL CALL PCASE(84,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END IF
END IF
END DO
C
DO IDET=1,NDET2
I2=ID0(2,IDET)
IF (I2.EQ.0) THEN
I1=ID0(1,IDET)
IF (I1.NE.0) THEN
LI=I1.LT.0
INDI=ABS(I1)
I=INDI
I3=ID0(3,IDET)
LA=I3.LT.0
INDK=ABS(I3)
K=INDK
DO II=1,NOCC
INDII=II
IF (INDII.NE.INDI) THEN
DO KK=NOV,NBAS
INDKK=KK
IF (INDKK.NE.INDK) THEN
I1R=SIGN(INDII,I1)
I3R=SIGN(INDKK,I3)
IVZ=1
CALL LOKI(I1R,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(I,INDK,INDII,INDKK,9)-HFIND(I,INDII,INDK,INDKK
$ ,10)
CL CALL PCASE(85,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
I1R=-SIGN(INDII,I1)
I3R=-SIGN(INDKK,I3)
IVZ=1
CALL LOKI(I1R,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=HFIND(I,INDK,INDII,INDKK,9)
CL CALL PCASE(86,IDET,INDXR,IVZ,HHH)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END IF
END DO
END IF
END IF
END DO
C CALL TIMING('SS X')
C
9991 FORMAT(3X,'case ',I2,', elements ',I4,' <-> ',3I4,' :',E16.8)
C0 IF (IASD.EQ.0) IASD=1
RETURN
END
C
SUBROUTINE HAMSD(X,R)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
LOGICAL LI,LA
INTEGER INDII,INDJJ,INDKK,INDLL
DIMENSION X(*),R(*)
C
C we look for the singles
C
NOV=NOCC+1
DO IDET=1,NDET2
I2=ID0(2,IDET)
IF (I2.EQ.0) THEN
I1=ID0(1,IDET)
IF (I1.NE.0) THEN
I3=ID0(3,IDET)
LI=I1.LT.0
LA=I3.LT.0
INDI=ABS(I1)
INDK=ABS(I3)
I=INDI
K=INDK
C we generate 1 difference
DO II=1,NOCC
INDII=II
DO KK=NOV,NBAS
INDKK=KK
C different spin than i1,i3
I1R=I1
I2R=-SIGN(INDII,I1)
I3R=I3
I4R=-SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
C
C here we have NOT the condition IDET.LT.INDX
C since we have always a single at the left-hand side and a double
C on the right-hand side. No danger of double-counting H_ij
C
C but INDXR must be smaller than NDET2
IF (INDXR.LE.NDET2) THEN
INDIII=INDII
INDKKX=INDKK
INDKX=INDK
C CALL TURN4(INDII,INDKK,INDK,IVII,INDIII,INDKKX,INDKX)
HHH=F(II,KK)-HFIND(I,I,INDII,INDKK,2)
- +HFIND(II,INDKKX,INDKX,INDKX,5)
CL CALL PCASE(60,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
C same spin as I1,I3
C here we have to respect the signs if occ and virtuals are in different
c order
C
IF (INDII.NE.INDI.AND.INDKK.NE.INDK) THEN
I1R=I1
I2R=SIGN(INDII,I1)
I3R=I3
I4R=SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
INDIIX=INDII
INDKKX=INDKK
C CALL TURN4(INDII,INDKK,INDK,IVK,INDIIX,INDKKX,IDUM)
HHH=F(II,KK)
- -HFIND(I,I,INDII,INDKK,2)+HFIND(I,INDII,I,INDKK,2)
- +HFIND(K,K,INDIIX,INDKKX,5)-HFIND(K,INDKKX,K,INDIIX,5)
CL CALL PCASE(61,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C another possibility: ia -> Ij aB
IF (INDII.NE.INDI) THEN
I1R=-I1
I2R=SIGN(INDII,I1)
I3R=I3
I4R=-SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
HHH=-HFIND(I,INDKK,I,INDII,2)
CL CALL PCASE(68,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C another possibility: ia -> iJ Ab
IF (INDKK.NE.INDK) THEN
I1R=I1
I2R=-SIGN(INDII,I1)
I3R=-I3
I4R=SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
INDIIX=INDII
INDKKX=INDKK
C CALL TURN4(INDII,INDKK,INDK,IVK,INDIIX,INDKKX,IDUM)
HHH=HFIND(K,INDKKX,K,INDIIX,5)
CL CALL PCASE(69,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
END DO
END IF
END IF
END DO
C
C two differences
C
NOV=NOCC+1
DO IDET=1,NDET2
I2=ID0(2,IDET)
IF (I2.EQ.0) THEN
I1=ID0(1,IDET)
IF (I1.NE.0) THEN
LI=I1.LT.0
INDI=ABS(I1)
I=INDI
I3=ID0(3,IDET)
LA=I3.LT.0
INDK=ABS(I3)
K=INDK
C 1o/1v
DO II=1,NOCC
INDII=II
DO KK=NOV,NBAS
INDKK=KK
C
C 2v1o
DO LL=KK,NBAS
C same spins
INDLL=LL
IF (INDII.NE.INDI.AND.INDKK.NE.INDLL.AND.
- INDLL.NE.INDK.AND.INDKK.NE.INDK) THEN
I1R=I1
I2R=SIGN(INDII,I1)
I3R=SIGN(INDKK,I1)
I4R=SIGN(INDLL,I1)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
INDIIX=INDII
INDKKX=INDKK
INDLLX=INDLL
C CALL TURN4(INDII,INDKK,INDLL,IVK,INDIIX,INDKKX,INDLLX)
HH1=HFIND(K,INDLLX,INDIIX,INDKKX,11)
HH2=HFIND(K,INDKKX,INDIIX,INDLLX,11)
HHH=HH2-HH1
CL CALL PCASE(62,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C different spins I
IF (INDKK.NE.INDK.AND.INDLL.NE.INDK) THEN
IF (INDLL.EQ.INDKK) THEN
ICLASS=5
ELSE
ICLASS=11
END IF
I1R= I1
I2R=-SIGN(INDII,I1)
I3R= SIGN(INDKK,I1)
I4R=-SIGN(INDLL,I1)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
INDIIX=INDII
INDKKX=INDKK
INDLLX=INDLL
C CALL TURN4(INDII,INDKK,INDLL,IVK,INDIIX,INDKKX,INDLLX)
HHH=HFIND(K,INDKKX,INDIIX,INDLLX,ICLASS)
CL CALL PCASE(63,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
C different spins II
IF (INDKK.NE.INDLL.AND.INDKK.NE.INDK) THEN
IF (INDK.EQ.INDKK) THEN
ICLASS=5
ELSE
ICLASS=11
END IF
I1R= I1
I2R=-SIGN(INDII,I1)
I3R=-SIGN(INDKK,I1)
I4R= SIGN(INDLL,I1)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
INDIIX=INDII
INDKKX=INDKK
INDLLX=INDLL
C CALL TURN4(INDII,INDKK,INDLL,IVK,INDIIX,INDKKX,INDLLX
C )
HHH=HFIND(K,INDLLX,INDIIX,INDKKX,ICLASS)
CL CALL PCASE(64,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END DO
C
C 2o/1v
C
DO JJ=II,NOCC
INDJJ=JJ
IF (INDKK.NE.INDK.AND.INDII.NE.INDI.AND.
- INDJJ.NE.INDI.AND.INDJJ.NE.INDII) THEN
I1R=SIGN(INDII,I3)
I2R=SIGN(INDJJ,I3)
I3R=I3
I4R=SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
HHH=HFIND(INDI,INDJJ,INDII,INDKK,8)-HFIND(INDI,INDII
$ ,INDJJ,INDKK,8)
CL CALL PCASE(65,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C different spins I
IF (INDII.NE.INDI.AND.INDI.NE.INDJJ) THEN
IF (INDII.EQ.INDJJ) THEN
ICLASS=2
ELSE
ICLASS=8
END IF
I1R= SIGN(INDII,I3)
I2R=-SIGN(INDJJ,I3)
I3R= I3
I4R=-SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
HHH=-HFIND(INDI,INDII,INDJJ,INDKK,ICLASS)
CL CALL PCASE(66,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
C different spins II
IF (INDJJ.NE.INDII.AND.INDII.NE.INDI) THEN
IF (INDI.EQ.INDJJ) THEN
ICLASS=2
ELSE
ICLASS=8
END IF
I1R=-SIGN(INDII,I3)
I2R= SIGN(INDJJ,I3)
I3R= I3
I4R=-SIGN(INDKK,I3)
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LE.NDET2) THEN
HHH=-HFIND(INDI,INDJJ,INDII,INDKK,ICLASS)
CL CALL PCASE(67,IDET,INDXR,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
END DO
C
END DO
END DO
END IF
END IF
END DO
C
RETURN
END
C
SUBROUTINE HAMRR(X,R)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION X(*),R(*)
C
IVZ=1
HHH=BVECT(IREFN)
CL CALL PCASE(98,IREFN,IREFN,IVZ,HHH)
CALL UPDS(R,X,HHH,IREFN,IREFN,IVZ)
RETURN
END
C
SUBROUTINE HAMRS(X,R)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION X(*),R(*)
C
IVZ=1
DO IDET=1,NDET2
INDJ=ID0(2,IDET)
IF (INDJ.EQ.0.AND.IDET.NE.IREFN) THEN
HHH=BVECT(IDET)
CL CALL PCASE(98,IDET,IREFN,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,IREFN,IVZ)
END IF
END DO
RETURN
END
C
SUBROUTINE HAMRD(X,R)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION X(*),R(*)
C
IVZ=1
DO IDET=1,NDET2
INDJ=ID0(2,IDET)
IF (INDJ.NE.0) THEN
HHH=BVECT(IDET)
CL CALL PCASE(98,IDET,IREF,IVZ,HHH)
CALL UPDS(R,X,HHH,IDET,IREFN,IVZ)
END IF
END DO
RETURN
END
C
SUBROUTINE HCALC(X,XX)
INCLUDE 'param.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
DIMENSION X(*),XX(*)
C Operation H*x
IF (LSS) CALL HAMSS(X,XX)
IF (LSD) CALL HAMSD(X,XX)
IF (LDD) CALL HAMDD(X,XX)
C IF (LRR) CALL HAMRR(X,XX)
IF (LRS) CALL HAMRS(X,XX)
IF (LRD) CALL HAMRD(X,XX)
RETURN
END
C
SUBROUTINE CHAM
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
CM COMMON /MATRIX/ HMAT(NDETMX,NDETMX)
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
DIMENSION XDUM(NDETMX)
C
DO I=1,NDET2
DO J=1,I-1
CM HMAT(I,J)=0.D0
CM HMAT(J,I)=0.D0
END DO
VECT(I)=0.D0
CM HMAT(I,I)=0.D0
END DO
CALL HCALC(VECT,XDUM)
C
C dump the matrix and return
C
REWIND (89)
DO I=1,NDET2
I1=ID0(1,I)
I2=ID0(2,I)
I3=ID0(3,I)
I4=ID0(4,I)
DO J=1,I
J1=ID0(1,J)
J2=ID0(2,J)
J3=ID0(3,J)
J4=ID0(4,J)
CM IF (HMAT(I,J).NE.0.D0) WRITE(89,'(2I4,3X,E20.12)') I,J,HMAT(I,J)
CM IF (HMAT(I,J).NE.0.D0) WRITE(91,'(4I4,3X,4I4,3X,E20.12)')
CM - I1,I2,I3,I4,J1,J2,J3,J4,HMAT(I,J)
END DO
END DO
RETURN
END
C
SUBROUTINE ODET(I,J,K,L,IVZ)
INCLUDE 'param.h'
C put determinant into right order, get sign
LOGICAL LI,LJ,LK,LL,LIJ
IF (I.EQ.J) RETURN
IF (K.EQ.L) RETURN
LI=I.LT.0
LJ=J.LT.0
LK=K.LT.0
LL=L.LT.0
LIJ=LI.EQV.LJ
INDI=ABS(I)
INDJ=ABS(J)
INDK=ABS(K)
INDL=ABS(L)
IVZ=1
IF (INDI.EQ.INDJ) THEN
I=INDI
J=-INDI
IF (LI) IVZ=-IVZ
ELSE IF (INDI.GT.INDJ) THEN
IVZ=-IVZ
IDUM=I
I=J
J=IDUM
END IF
IF (INDK.EQ.INDL) THEN
K=INDK
L=-INDK
IF (LK) IVZ=-IVZ
ELSE IF (INDK.GT.INDL) THEN
IDUM=K
K=L
L=IDUM
IVZ=-IVZ
END IF
IF (.NOT.LIJ) THEN
IVZ=1
END IF
RETURN
END
C
SUBROUTINE PCASE(ICASE,IDET,INDXR,IVZ,HHH)
INCLUDE 'param.h'
CD IF (IDET.EQ.0.OR.INDXR.EQ.0) THEN
WRITE(6,9991) ICASE,IDET,IVZ*INDXR,HHH
CD END IF
9991 FORMAT(3X,'case ',I2,', elements ',I6,' <-> ',I6,' :',E16.8)
RETURN
END
C
SUBROUTINE DAVID(N,AB,B,THR,MAXDAV,NITER,ERR,IMODE)
INCLUDE 'param.h'
C
C DIAGONALIZATION SUBROUTINE FOR LARGE SYMMETRIC MATRICES
C E. R. DAVIDSON, J. COMP. PHYS 17, 87 (1975)
C
C ce morceau est du CASDI de Daniel MAYNAU
C
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
PARAMETER (NITM=50)
DIMENSION B(*),AB(*)
DIMENSION Q(NDETMX)
DIMENSION BAB(NITM,NITM)
DIMENSION ALPHA(NITM,NITM),ALAM(NITM),P1(NITM),P2(NITM)
LOGICAL YW,LTOTSAV
DIMENSION C(NDETMX),HC(NDETMX)
5 FORMAT (//10X,'EIGENVALUE NUMBER',I3)
10 FORMAT (3X,'ITER=',I3,' EIGENVALUE=',F17.12,
* ', CONVERGENCE =',D10.2)
11 FORMAT (1X,'DAV: ITER=',I3,' EIGENV=',E10.4,
* ', CONV =',D10.2)
20 FORMAT (///5X,'THE DAVIDSON PROCEDURE DOES NOT CONVERGE AFTER',
* I4,' ITERATIONS'///)
CALL FLUSH(6)
C
C
C we have to save the variable LTOTAL somewhere
LTOTSAV=LTOTAL
LTOTAL=.FALSE.
ZERO=0.D0
ONE=1.D0
EPS=1.D-25
C
C we open 2 direct-access files
C
IUNIT1=76
OPEN(UNIT=IUNIT1,FILE='VECTOR.TMP',STATUS='UNKNOWN',ACCESS='DIRECT
$'
C folded 1 (fixf $Revision: 1.3 $)
$ ,RECL=N*8)
IUNIT2=87
OPEN(UNIT=IUNIT2,FILE='HVECT.TMP',STATUS='UNKNOWN',ACCESS='DIRECT'
$ ,RECL=N*8)
IF (IMODE.GT.1) THEN
IUNIT5=66
OPEN(UNIT=IUNIT5,FILE='DRESSING.TMP',FORM='UNFORMATTED',STATUS
$ ='UNKNOWN')
END IF
C
IF (LXAV) WRITE(6,*)
$ ' TRYING IEPA-LIKE FORMULA OF X.GADEA FOR DIAGONALIZATION '
C
ITER=1
C
SUMQ=0.D0
DO I=1,N
SUMQ=SUMQ+B(I)*B(I)
END DO
SUMQ=SQRT(SUMQ)
SUMQQ=0.D0
DO I=1,N
AB(I)=0.D0
B(I)=B(I)/SUMQ
SUMQQ=SUMQQ+B(I)*B(I)
END DO
c$$$ WRITE(6,*) ' SUMQ, SUMQQ: ',SUMQ,SUMQQ
C
IF (IMODE.GT.1) THEN
C the first dressing vector is zero
WRITE(IUNIT5) (AB(I),I=1,N)
REWIND(IUNIT5)
END IF
C
IF (IMODE.EQ.8) THEN
CALL FDD(B,AB)
ELSE
CALL HCALC(B,AB)
END IF
CALL PUTV(B,1,N,IUNIT1)
CALL PUTV(AB,1,N,IUNIT2)
BABL=0.D0
DO J=1,N
BABL=BABL+B(J)*AB(J)
END DO
BAB(1,1)=BABL
C
M=1
C
C DIAGONALIZATION OF BAB ... EIGENVALUES ALAM, EIGENVECTORS ALPHA
C
C this is the iteration loop
C
70 CONTINUE
C
C this small matrix BAB has to be diagonalized
C
c$$$ WRITE(6,*) ' before diagonalization: '
c$$$ WRITE(6,'(4(2I4,E14.4))') ((I,J,BAB(I,J),J=1,I),I=1,M)
IERR=0
MATZ=1
CALL RS(NITM,M,BAB,ALAM,MATZ,ALPHA,P1,P2,IERR)
IF (IERR.NE.0) THEN
WRITE(6,*) ' ERROR IN DIAGONALIZATION OF Heff'
DO I=1,N
B(I)=0.D0
END DO
LTOTAL=LTOTSAV
RETURN
END IF
c$$$ WRITE(6,*) ' EIGENVALUE ',ALAM(1)
c$$$ WRITE(6,*) ' EIGENVECTOR ',(ALPHA(J,1),J=1,M)
C
C SETS UP THE CORRECTION VECTOR Q
C AND PERFORMS THE CONVERGENCE TEST
C
75 CONTINUE
C we need only the lowest eigenvalue
CALL GETV(B,1,N,IUNIT1)
CALL GETV(AB,1,N,IUNIT2)
AVAL=ALAM(1)
AVEC=ALPHA(1,1)
DO I=1,N
DIFFI=AB(I)-AVAL*B(I)
Q(I)=AVEC*DIFFI
END DO
DO L=2,M
CALL GETV(B,L,N,IUNIT1)
CALL GETV(AB,L,N,IUNIT2)
C ... and the corresponding eigenvector
AVEC=ALPHA(L,1)
DO I=1,N
DIFFI=AB(I)-AVAL*B(I)
Q(I)=Q(I)+AVEC*DIFFI
END DO
END DO
C
C WRITE(6,*) ' THE VECTOR (H-E0) PSI'
C WRITE(6,'(5(I4,E12.5))') (I,Q(I),I=1,N)
C
C convergence?
SUMQ=0.D0
DO I=1,N
SUMQ=SUMQ+Q(I)*Q(I)
END DO
SUMQ=DSQRT(SUMQ/N)
WRITE (6,10) ITER,ALAM(1),SUMQ
IF (ITER.EQ.1) CALL TIMING('IT 1')
IF (ITER.EQ.2) CALL TIMING('IT 2')
CALL FLUSH(6)
IF (IMODE.EQ.1.OR.ITER.GT.2)THEN
IF (SUMQ.LT.THR) GO TO 200
END IF
IF (ITER.GE.MAXDAV) GO TO 250
ITER=ITER+1
C
C IF M OVERFLOWS, THE B SUBSPACE IS THOROUGHLY REDEFINED
C
IF (M.GE.NITM) GO TO 200
C
IF (IMODE.GT.1) THEN
C here is the point were we could think of calculating
C a dressing
C
C first construct the best eigenvector:
CALL GETV(B,1,N,IUNIT1)
AVAL=ALPHA(1,1)
DO I=1,N
C(I)=AVAL*B(I)
END DO
DO L=2,M
CALL GETV(B,L,N,IUNIT1)
AVAL=ALPHA(L,1)
DO I=1,N
C(I)=C(I)+AVAL*B(I)
END DO
END DO
C
C calculate the correlation energy
C
C intermediate normalization
CNRM=C(IREFN)
DO I=1,N
C(I)=C(I)/CNRM
END DO
CALL VNORM(C,1)
C we need the correlation energy only
CALL ECORRC(N,C,2,ECORR)
DO I=1,N
HC(I)=0.D0
END DO
CALL EPV(ECORR,C,HC,IMODE)
C
C C we can overwrite with the ancient dressing vector now
C
REWIND(IUNIT5)
READ(IUNIT5) (C(I),I=1,N)
REWIND(IUNIT5)
C and we store the new dressing in the place of the old
WRITE(IUNIT5) (HC(I),I=1,N)
REWIND(IUNIT5)
C
DO I=1,N
C(I)=HC(I)-C(I)
END DO
C
C and now we have to recalculate the AB's and the
C small matrix BAB
C
DO L=1,M
CALL GETV(B,L,N,IUNIT1)
CALL GETV(AB,L,N,IUNIT2)
DO I=1,N
AB(I)=AB(I)+C(I)*B(I)
END DO
CALL PUTV(AB,L,N,IUNIT2)
DO LL=1,L
CALL GETV(B,LL,N,IUNIT1)
SUM=0.D0
DO I=1,N
SUM=SUM+B(I)*AB(I)
END DO
C WRITE(6,*) ' EFFECT OF DRESSING: ',L,LL,BAB(L,LL)-SUM
BAB(L,LL)=SUM
END DO
END DO
END IF
C
IF (LXAV) THEN
DO I=1,N
C(I)=0.D0
HC(I)=0.D0
END DO
C
DO L=1,M
CALL GETV(B,L,N,IUNIT1)
CALL GETV(AB,L,N,IUNIT2)
DO I=1,N
C(I)=C(I)+ALPHA(L,1)*B(I)
HC(I)=HC(I)+ALPHA(L,1)*AB(I)
END DO
END DO
C
C now C is the actual eigenvector
C
XA=ALAM(1)
C
DO I=1,N
XC=C(I)
XCC=XC*XC
HCC=HC(I)
DNRM=1.D0-XCC
IF (DABS(HCC).LT.1.D-9) THEN
Q(I)=XC
ELSE
IF (DABS(DNRM).LT.1.D-9) THEN
Q(I)=XC
ELSE
RDNRM=DSQRT(DNRM)
XB=(DIAG(I)+XCC*XA-2.D0*XC*HCC)/DNRM
COUP=(HCC-XC*XA)/RDNRM
IF (ABS(COUP).LT.1.D-9) THEN
Q(I)=XC
ELSE
R1=(XA+XB-SQRT((XA-XB)*(XA-XB)+4.D0*COUP*COUP))*.5D0
BETA=(R1-XA)/COUP
Q(I)=XC+BETA*RDNRM
END IF
END IF
END IF
END DO
ELSE
C we have NOT the Gadea formulae
C
C COMPUTES THE VECTOR B(M+1) TO ENLARGE THE B SUBSPACE
C
C Q contains (H-E_0)B
C
IQ=0
DO 100 I=1,N
IQ=IQ+1
IF (DABS(Q(IQ))-EPS) 95,95,97
95 CONTINUE
Q(IQ)=ZERO
GO TO 100
97 CONTINUE
IF(DABS(ALAM(1)-DIAG(I)).LT.1.D-15) THEN
WRITE(6,*)'QUASI DEGENERESCENCE',ALAM(1),DIAG(I)
Q(IQ)=Q(IQ)/(ALAM(1)-DIAG(I)-0.01)
ELSE
Q(IQ)=Q(IQ)/(ALAM(1)-DIAG(I))
END IF
100 CONTINUE
C end if of IF (LXAV)
END IF
C
C -- ORTHOGONALISATION DE B(M+1) AUX B(1)...B(M)
C
C WRITE(6,*) ' THE NEW VECTOR Q'
C WRITE(6,'(5(I4,E12.5))') (I,Q(I),I=1,N)
DO L=1,M
CALL GETV(B,L,N,IUNIT1)
SUM=ZERO
DO I=1,N
SUM=SUM+B(I)*Q(I)
END DO
DO I=1,N
Q(I)=Q(I)-SUM*B(I)
END DO
END DO
C WRITE(6,*) ' THE ORTHOGONALIZED VECTOR Q'
C WRITE(6,'(5(I4,E12.5))') (I,Q(I),I=1,N)
SUM=ZERO
DO I=1,N
SUM=SUM+Q(I)*Q(I)
END DO
SUM=ONE/DSQRT(SUM)
DO I=1,N
B(I)=SUM*Q(I)
END DO
C
M=M+1
CALL PUTV(B,M,N,IUNIT1)
DO I=1,N
AB(I)=0.D0
END DO
IF (IMODE.EQ.8) THEN
CALL FDD(B,AB)
ELSE
CALL HCALC(B,AB)
END IF
IF (IMODE.EQ.1) THEN
C
C normal CI
C
CALL PUTV(AB,M,N,IUNIT2)
DO L=1,M
SUM=ZERO
CALL GETV(B,L,N,IUNIT1)
DO J=1,N
SUM=SUM+B(J)*AB(J)
END DO
BAB(M,L)=SUM
END DO
ELSE
C BAB has already been corrected above, for the M-1 old vectors
C
C thus first get the dressing from the file
REWIND(IUNIT5)
READ(IUNIT5) (HC(I),I=1,N)
DO I=1,N
AB(I)=AB(I)+HC(I)*B(I)
END DO
C AB is now the M'th vector with the dressing of the M-1'th
C iteration
CALL PUTV(AB,M,N,IUNIT2)
DO L=1,M
SUM=ZERO
CALL GETV(B,L,N,IUNIT1)
DO J=1,N
SUM=SUM+B(J)*AB(J)
END DO
BAB(M,L)=SUM
END DO
END IF
C
C BACK TO THE DIAGONALIZATION OF BAB
C
GO TO 70
C
C THE EIGENVECTORS OF BAB ARE BACK-TRANSFORMED
C IN THE ORIGINAL BASIS
C
C
C the eigenvector is constructed from the stored intermediates,
C and iterations are restarted, if not all iterations have been used
C
200 CONTINUE
C
C construct vector
C
DO I=1,N
B(I)=ZERO
END DO
DO LL=1,M
ALP=ALPHA(LL,1)
CALL GETV(AB,LL,N,IUNIT1)
DO I=1,N
B(I)=B(I)+AB(I)*ALP
END DO
END DO
C
C on convergence we may return
C
IF (SUMQ.LT.THR) THEN
CLOSE(IUNIT1,STATUS='DELETE')
CLOSE(IUNIT2,STATUS='DELETE')
CLOSE(IUNIT5,STATUS='DELETE')
LTOTAL=LTOTSAV
RETURN
END IF
C
C otherwise we restart the iterations from the
C improved starting vector
C
CALL PUTV(B,1,N,IUNIT1)
C
C construct H*vector
C
DO I=1,N
B(I)=ZERO
END DO
DO LL=1,M
ALP=ALPHA(LL,1)
CALL GETV(AB,LL,N,IUNIT2)
DO I=1,N
B(I)=B(I)+AB(I)*ALP
END DO
END DO
CALL PUTV(B,1,N,IUNIT2)
C
WRITE (6,9221)
9221 FORMAT(' DAVIDSON ITERATIONS ARE RESTARTED WITH NEW VECTOR')
C
CALL GETV( B,1,N,IUNIT1)
CALL GETV(AB,1,N,IUNIT2)
BABL=0.D0
DO I=1,N
BABL=BABL+B(I)*AB(I)
END DO
C
M=1
BAB(1,1)=BABL
ALPHA(1,1)=ONE
ALAM(1)=BABL
GO TO 75
250 CONTINUE
WRITE (6,20) ITER
C
C the procedure did not converge, however we return the best vector
C found
C
DO I=1,N
B(I)=ZERO
END DO
DO LL=1,M
ALP=ALPHA(LL,1)
CALL GETV(AB,LL,N,IUNIT1)
DO I=1,N
B(I)=B(I)+AB(I)*ALP
END DO
END DO
CLOSE(IUNIT1,STATUS='DELETE')
CLOSE(IUNIT2,STATUS='DELETE')
CLOSE(IUNIT5,STATUS='DELETE')
C
LTOTAL=LTOTSAV
RETURN
END
C
SUBROUTINE GETV(X,IVEC,NDIM,IUNIT)
INCLUDE 'param.h'
DIMENSION X(NDIM)
C WRITE(6,*) ' WE TRY TO READ RECORD No',IVEC,' FROM FILE ',IUNIT
READ(IUNIT,REC=IVEC) X
RETURN
END
C
SUBROUTINE PUTV(X,IVEC,NDIM,IUNIT)
INCLUDE 'param.h'
DIMENSION X(NDIM)
C WRITE(6,*) ' WE TRY TO WRITE RECORD No',IVEC,' TO FILE ',IUNIT
WRITE(IUNIT,REC=IVEC) X
RETURN
END
C
SUBROUTINE VNORM(V,IMODE)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION V(NDET2),V2(NDETMX)
C
C IMODE=1 intermediate normalization
C
C IMODE=2 normalization to 1
C
C IMODE=3 correlated part normalized to 1
C
IF (IMODE.GT.3.OR.IMODE.LT.1)
- STOP 'VNORM: IMODE SHOULD BE BETWEEN 1 AND 3'
C
IF (IMODE.EQ.1) THEN
XMLT=1.D0/V(IREFN)
DO IDET=1,NDET2
V(IDET)=V(IDET)*XMLT
END DO
ELSE IF (IMODE.EQ.2) THEN
C
C the normalization to 1, the real coefficients c_{ijab} are entered
C
DNRM=0.D0
DO IDET=1,NDET2
DNRM=DNRM+V(IDET)*V(IDET)
END DO
DNRM=1.D0/SQRT(DNRM)
C
DO IDET=1,NDET2
V(IDET)=V(IDET)*DNRM
END DO
ELSE
WRITE(6,*)
WRITE(6,*) ' complementary intermediate norm '
WRITE(6,*)
XNRM=0.D0
DO IDET=1,NDET2
IF (IDET.NE.IREFN) XNRM=XNRM+V(IDET)*V(IDET)
END DO
IF (XNRM.GE.1.D-16) THEN
XNRM=1.D0/SQRT(XNRM)
DO IDET=1,NDET2
V(IDET)=XNRM*V(IDET)
END DO
WRITE(6,*) ' K0 = ',V(IREFN)
WRITE(6,*)
ELSE
V(IREFN)=1.D10
WRITE(6,*) ' no complement available '
WRITE(6,*) ' setting K0 to 10000 '
WRITE(6,*)
END IF
END IF
C
RETURN
END
C
FUNCTION IGETTY(I1,J1,K1,L1)
INCLUDE 'param.h'
LOGICAL LI,LJ,LA,LB,LEQU
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
I=I1
J=J1
K=K1
L=L1
LI=I.LE.NOCC
LJ=J.LE.NOCC
LA=K.LE.NOCC
LB=L.LE.NOCC
C how many holes are there
IHOLE=0
IF (LI) IHOLE=IHOLE+1
IF (LJ) IHOLE=IHOLE+1
IF (LA) IHOLE=IHOLE+1
IF (LB) IHOLE=IHOLE+1
IF (IHOLE.EQ.0) THEN
IGETTY=6
ELSE IF (IHOLE.EQ.1) THEN
IGETTY=5
ELSE IF (IHOLE.EQ.2) THEN
IF (LI.EQV.LJ) THEN
IGETTY=4
ELSE
IGETTY=3
END IF
ELSE IF (IHOLE.EQ.3) THEN
IGETTY=2
ELSE IF (IHOLE.EQ.4) THEN
IGETTY=1
END IF
IF (I1.EQ.J1.OR.I1.EQ.K1.OR.I1.EQ.L1.
- OR.J1.EQ.K1.OR.J1.EQ.L1.OR.K1.EQ.L1) THEN
RETURN
ELSE
IGETTY=IGETTY+6
END IF
RETURN
END
C
SUBROUTINE EPV(ECORR,CVECT,RDIAG,IMODE)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
PARAMETER (NE123M=600000)
COMMON /SCSC/ ETABLE(NE123M)
DIMENSION RDIAG(NDETMX)
C.. INCLUDE 'etable.h'
C CVECT is ths actual CI vector
DIMENSION CVECT(*)
DIMENSION ISARR(NBASM)
LOGICAL LI,LJ,LK,LL
C
C these are the CI dressings
C
C RDIAG is input
C CVECT is input
C ECORR is as well input
C
C but BVECT = comes from COMMON /NACT/
C it seems that we do not need COMMON /CIVEC/ with VECT and HVECT
C
C IMODE is as before:
C 1 meaning CISD, no dressing
C 2 meaning CEPA-0
C 3 meaning CEPA-1
C 4 meaning CEPA-2
C 5 meaning (SC)^2
C 6 meaning Kutzel
C 7 meaning ACPF
C 8 meaning MP2C
C 9 meaning AQCC
C 10 meaning AQCC-V
C
IF (IMODE.EQ.1) RETURN
C
DELTA=ECORR
C WRITE(6,*) ' EPV: DELTA = ',DELTA
C
C this is all for the CEPA-0
C
IF (IMODE.EQ.2.OR.IMODE.EQ.6) THEN
DDD=DELTA
DO IDET=1,NDET2
C for CEPA-0 all determinants will be dressed, except for the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.7) THEN
C ACPF: DDD=(1-2/Nelectr.)*ECORR
XML=(1.D0-1.D0/DBLE(NOCC))
WRITE(6,*) ' ACPF DRESSING: FACTOR ',XML
DDD=DELTA*XML
DO IDET=1,NDET2
C for ACPF all determinants will be dressed, except the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.9) THEN
C AQCC: DDD=(n-2)*(n-3)/n/(n-1)
NELE=NOCC*2
XML=DBLE((NELE-2)*(NELE-3))/DBLE(NELE*(NELE-1))
WRITE(6,*) ' AQCC DRESSING: FACTOR ',XML
DDD=DELTA*XML
DO IDET=1,NDET2
C for AQCC all determinants will be dressed, except the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.10) THEN
C AQCC-V: DDD=(n-2)*(n-3)/n/(n-1)*(N-2)*(N-3)/N/(N-1)*ECORR
C approx: 1-4/n*(n/N+1)
NELE=NOCC*2
NVI=(NBAS-NOCC)*2
XML=DBLE((NELE-2)*(NELE-3))/DBLE(NELE*(NELE-1))
XML=XML*DBLE((NVI-2)*(NVI-3))/DBLE(NVI*(NVI-1))
C
C approx:
C XML=1.D0-4.D0/DBLE(NELE)*(1.D0+DBLE(NELE)/DBLE(NVI))
WRITE(6,*) ' AQCC-V DRESSING: FACTOR ',XML
DDD=DELTA*XML
DO IDET=1,NDET2
C for AQCC all determinants will be dressed, except the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
C first, we fill an intermediate index table - to be used for E3
C
IF (IMODE.EQ.3) WRITE(6,*) ' CEPA-2 - dressing '
IF (IMODE.EQ.4) WRITE(6,*) ' CEPA-3 - dressing '
IF (IMODE.EQ.5) WRITE(6,*) ' SCSC - dressing '
INDX=0
DO I=1,NOCC
INDI=I
INDX=INDX+1
ISARR(INDI)=INDX
END DO
INDX=0
DO I=NOCC+1,NBAS
INDI=I
INDX=INDX+1
ISARR(INDI)=INDX
END DO
C
C constants and offsets
C
NBC=NBAS
NE1=NBAS
NE12=NE1+NBAS*(2*NBC+1)
NE12A=NE12+NOCC*(2*NOCC+1)*(2*NVIRT+1)
NE12B=NE12A+NOCC*(2*NVIRT+1)*(2*NVIRT+1)
IF (IMODE.EQ.2) THEN
NEED=NE1
ELSE IF (IMODE.EQ.3.OR.IMODE.EQ.4) THEN
NEED=NE12
ELSE IF (IMODE.EQ.5) THEN
NEED=NE12B
END IF
DO I=1,NEED
ETABLE(I)=0.D0
END DO
C
NOC=NOCC
NVC=NVIRT
INC1=2*NBC+1
INC2=2*NOC+1
INC3=2*NVC+1
IOFF1=NE1+1+NBC-INC1
IOFF2=NE12+INC3*NOC+NVC-INC3*INC2+1
IOFF3=NE12A+1+INC3*NVC-INC3*INC3
DO IDET=1,NDET2
INDI=ID0(1,IDET)
IF (INDI.NE.0) THEN
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
INDL=ID0(4,IDET)
C
C recall the order of the determinants
C reference (0000)
C singles (I0K0) I occ, K virt
C doubles (IJKL) I,J occ, K,L virt; |I| < |J|, |K|<|L|
C if |I|=|J|: I -I
C
IDET1=IDET
IVZ=1
C coefficients are in intermediate normalization
EPVC=CVECT(IDET1)*BVECT(IDET1)
C
LI=INDI.LE.0
LJ=INDJ.LE.0
LK=INDK.LE.0
LL=INDL.LE.0
C
INDI=ABS(INDI)
INDJ=ABS(INDJ)
INDK=ABS(INDK)
INDL=ABS(INDL)
C
I=INDI
K=INDK
IF (INDJ.NE.0) THEN
J=INDJ
L=INDL
END IF
C
IF (.NOT.LI) ETABLE(I)=ETABLE(I)+EPVC
IF (.NOT.LJ) ETABLE(J)=ETABLE(J)+EPVC
IF (.NOT.LK) ETABLE(K)=ETABLE(K)+EPVC
IF (.NOT.LL) ETABLE(L)=ETABLE(L)+EPVC
C
IF (.NOT.LI) THEN
C E2(I,J)
IF (INDJ.NE.0) THEN
INDIJ=INDJ
IF (LJ) INDIJ=-INDIJ
INDX=IOFF1+I*INC1+INDIJ
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '1 +++ ',I,INDIJ,INDX,EPVC,ETABLE(INDX)
END IF
C E2(I,K)
INDIK=INDK
IF (LK) INDIK=-INDIK
INDX=IOFF1+I*INC1+INDIK
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '2 +++ ',I,INDIK,INDX,EPVC,ETABLE(INDX)
C E2(I,L)
IF (INDL.NE.0) THEN
INDIL=INDL
IF (LL) INDIL=-INDIL
INDX=IOFF1+I*INC1+INDIL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '3 +++ ',I,INDIL,INDX,EPVC,ETABLE(INDX)
END IF
END IF
IF (.NOT.LJ) THEN
C E2(J,K)
INDJK=INDK
IF (LK) INDJK=-INDJK
INDX=IOFF1+J*INC1+INDJK
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '4 +++ ',J,INDJK,INDX,EPVC,ETABLE(INDX)
C E2(J,L)
INDJL=INDL
IF (LL) INDJL=-INDJL
INDX=IOFF1+J*INC1+INDJL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '5 +++ ',J,INDJL,INDX,EPVC,ETABLE(INDX)
END IF
IF (.NOT.LK.AND.INDL.NE.0) THEN
C E2(K,L)
INDKL=INDL
IF (LL) INDKL=-INDKL
INDX=IOFF1+K*INC1+INDKL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,*) '6 +++ ',K,INDKL,INDX,EPVC,ETABLE(INDX)
END IF
C
C we need the E3 table only for the (SC)^2
C
IF (IMODE.GT.4) THEN
C
C now the table E3
C first the table oov
C
IF (INDJ.NE.0) THEN
IF (.NOT.LI) THEN
INDX1=I
INDX2=ISARR(INDJ)
INDX3=ISARR(INDK)
INDX4=ISARR(INDL)
IF (LJ) INDX2=-INDX2
IF (LK) INDX3=-INDX3
IF (LL) INDX4=-INDX4
C
C E3(I,J,K)
INDX=IOFF2+INDX3+INC3*(INDX2+INC2*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C E3(I,J,L)
INDX=IOFF2+INDX4+INC3*(INDX2+INC2*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C
C now the table ovv
C
C E3(I,K,L)
INDX=IOFF3+INDX4+INC3*(INDX3+INC3*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
INDX=IOFF3+INDX3+INC3*(INDX4+INC3*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C E3(J,K,L)
IF (.NOT.LJ) THEN
INDX5=J
INDX=IOFF3+INDX4+INC3*(INDX3+INC3*INDX5)
ETABLE(INDX)=ETABLE(INDX)+EPVC
INDX=IOFF3+INDX3+INC3*(INDX4+INC3*INDX5)
ETABLE(INDX)=ETABLE(INDX)+EPVC
END IF
END IF
END IF
END IF
END IF
END DO
C
C the dressing
C
c$$$ WRITE(6,*) ' E1 ----------------------------------------- '
c$$$ DO I=1,NBAS
c$$$ IF (ETABLE(I).NE.0.D0) WRITE(6,*) ' E1(I)',I,ETABLE(I)
c$$$ END DO
c$$$ WRITE(6,*) ' E2 ----------------------------------------- '
c$$$ DO I=1,NBAS
c$$$ DO INDJ=1,NBAS
c$$$ INDX=IOFF1+I*INC1+INDJ
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,*) ' E2(I,J) ',I,INDJ,INDX
c$$$ $ ,ETABLE(INDX)
c$$$ INDX=IOFF1+I*INC1-INDJ
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,*) ' E2(I,-J)',I,-INDJ,INDX
c$$$ $ ,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ IF (IMODE.GT.4) THEN
c$$$ WRITE(6,*) ' E3A ----------------------------------------- '
c$$$ DO I=1,NOCC
c$$$ DO INDJ=1,NVIRT
c$$$ DO INDK=1,NVIRT
c$$$ INDX=IOFF2+INDK+INC2*(INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I, J, K)',I, INDJ, INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2-INDK+INC2*(INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I, J,-K)',I, INDJ,-INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2+INDK+INC2*(-INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I,-J, K)',I,-INDJ, INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2-INDK+INC2*(-INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I,-J,-K)',I,-INDJ,-INDK,INDX,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ END DO
c$$$ WRITE(6,*) ' E3B ----------------------------------------- '
c$$$ DO I=1,NOCC
c$$$ DO INDJ=1,NVIRT
c$$$ DO INDK=1,NVIRT
c$$$ INDX=IOFF3+INDK+INC3*(INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I, J, K)',I, INDJ, INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3-INDK+INC3*(INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I, J,-K)',I, INDJ,-INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3+INDK+INC3*(-INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I,-J, K)',I,-INDJ, INDK,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3-INDK+INC3*(-INDJ+INC3*I)
c$$$ IF (ETABLE(INDX).NE.0.D0) WRITE(6,'(2X,A13,4I5,E20.12)')
c$$$ $ ' E3(I,-J,-K)',I,-INDJ,-INDK,INDX,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ END DO
c$$$ END IF
C STOP ' FILLED E'
C
DO IDET=1,NDET2
INDI=ID0(1,IDET)
II=SIGN(1,INDI)
IF (INDI.NE.0) THEN
C the CEPA-0
DDD=DELTA
C
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
IJ=SIGN(1,INDJ)
IK=SIGN(1,INDK)
INDI=ABS(INDI)
INDK=ABS(INDK)
I=INDI
K=INDK
I1=I
K1=K
K2=II*IK*K
C dressing of doubles
IF (INDJ.NE.0) THEN
INDL=ID0(4,IDET)
IJ=SIGN(1,INDJ)
IL=SIGN(1,INDL)
INDJ=ABS(INDJ)
INDL=ABS(INDL)
J=INDJ
L=INDL
C
J1=J
L1=L
C
J2=II*IJ*J
L2=II*IL*L
C
K3=IJ*IK*K
L3=IJ*IL*L
C
L4=IK*IL*L
C
c$$$ DDD=DELTA-E1(I1)-E1(J1)-E1(K1)-E1(L1)
c$$$ - +E2(I1,J2)+E2(I1,K2)+E2(I1,L2)
c$$$ - +E2(J1,K3)+E2(J1,L3)+E2(K1,L4)
c$$$ - -E3(I1,J2,K2)-E3(I1,J2,L2)
c$$$ - -E3(I1,K2,L2)-E3(J1,K3,L3)
c$$$ - -CVECT(IDET)*BVECT(IDET)
C
C prepare the indices
C
I1J2=IOFF1+J2+INC1*I1
C
IF (IMODE.EQ.3) THEN
C the CEPA-2
DDD=DELTA-ETABLE(I1J2)
ELSE IF (IMODE.EQ.4) THEN
C the CEPA-3
DDD=DELTA-ETABLE(I1)-ETABLE(J1)+ETABLE(I1J2)
ELSE IF (IMODE.EQ.5) THEN
C the FULL CEPA
I1K2=IOFF1+K2+INC1*I1
I1L2=IOFF1+L2+INC1*I1
J1K3=IOFF1+K3+INC1*J1
J1L3=IOFF1+L3+INC1*J1
K1L4=IOFF1+L4+INC1*K1
JJ2=SIGN(ISARR(ABS(J2)),J2)
KK2=SIGN(ISARR(ABS(K2)),K2)
LL2=SIGN(ISARR(ABS(L2)),L2)
KK3=SIGN(ISARR(ABS(K3)),K3)
LL3=SIGN(ISARR(ABS(L3)),L3)
I1J2K2=IOFF2+KK2+INC3*(JJ2+INC2*I1)
I1J2L2=IOFF2+LL2+INC3*(JJ2+INC2*I1)
I1K2L2=IOFF3+LL2+INC3*(KK2+INC3*I1)
J1K3L3=IOFF3+LL3+INC3*(KK3+INC3*J1)
DDD=DDD
- -ETABLE(I1)-ETABLE(J1)-ETABLE(K1)-ETABLE(L1)
- +ETABLE(I1J2)+ETABLE(I1K2)+ETABLE(I1L2)
- +ETABLE(J1K3)+ETABLE(J1L3)+ETABLE(K1L4)
- -ETABLE(I1J2K2)-ETABLE(I1J2L2)
- -ETABLE(I1K2L2)-ETABLE(J1K3L3)
- +CVECT(IDET)*BVECT(IDET)
C - -CVECT(IDET)*BVECT(IDET)
END IF
ELSE
C dressing of SINGLES
INDL=0
I1K2=IOFF1+K2+INC1*I1
DDD=DELTA-ETABLE(I1)-ETABLE(K1)+ETABLE(I1K2)
END IF
C finally, the dressing
RDIAG(IDET)=RDIAG(IDET)+DDD
ELSE
C the reference will not be dressed
RDIAG(IDET)=RDIAG(IDET)
END IF
END DO
C
RETURN
END
C
SUBROUTINE MP2VEC
INCLUDE 'param.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
C
C recreate the MP2 - Vector
C
DO IDET=1,NDET2
INDJ=ABS(ID0(2,IDET))
IF (INDJ.NE.0) THEN
I=ABS(ID0(1,IDET))
J=ABS(ID0(2,IDET))
K=ABS(ID0(3,IDET))
L=ABS(ID0(4,IDET))
EDEN=ORBEN(K)+ORBEN(L)-ORBEN(I)-ORBEN(J)
VECT(IDET)=-BVECT(IDET)/EDEN
ELSE
INDI=ID0(1,IDET)
IF (INDI.EQ.0) THEN
VECT(IDET)=1.D0
ELSE
VECT(IDET)=0.D0
END IF
END IF
END DO
C
WRITE(6,*)
WRITE(6,*) ' THE MP2 - VECTOR has been recalculated'
WRITE(6,*)
RETURN
END
C
SUBROUTINE RDINP
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /CFREEZE/ IORBFZ(NBASM),IORBMP(NBASM)
C.. INCLUDE 'common_freeze.h'
CHARACTER*4 KEYW(2),STR3
CHARACTER*6 KEYOPT(50),STR6
CHARACTER*80 LINE
DATA KEYW /'*ICM','*END'/
DATA KEYOPT /'EPSTEI','LCCD ','CEPA-0','CEPA-2','CEPA-3',
- 'SCSC ','CISD ','NITDAV','PRINTL','NOPERT',
- 'TOLCCD','TOLCI ','ITLCCD','THRPRI','XGADEA',
- 'READCI','READLC','FORMAT','CIS ','CID ',
- 'THRINT','ACPF ','LCCSD ','AQCC ','MP2CAN',
- 'AQCC-V','QMC ','DETAIL','SELECT','FREEZE',
- 'DELETE','NATORB','APPROX','MP2EGO','EN2CAN',
- 'CALPHP','BANDST','MP3 ','EN3 ','EXSCI ',
- 'TOTALE','RESTOR','BONDCI','READET','PERLOC',
- 'XXXXXX','XXXXXX','XXXXXX','XXXXXX','XXXXXX'/
C
C DEFAULTS
THRINT=1.D-10
LPHP=.FALSE.
LCID=.FALSE.
LCIS=.FALSE.
LDELCU=.TRUE.
THRPRI=1.D-2
TOLCI=1.D-7
TOLCCD=1.D-7
NITDAV=50
ITLCCD=80
LPERT=.TRUE.
IPRINT=0
NITDAV=30
LEPSN=.FALSE.
LLCCD=.FALSE.
LCEPA0=.FALSE.
LCEPA2=.FALSE.
LCEPA3=.FALSE.
LSCSC=.FALSE.
LCISD=.FALSE.
LXAV=.FALSE.
LVECR1=.FALSE.
LVECR2=.FALSE.
LACPF=.FALSE.
LAQCC=.FALSE.
LAQCCV=.FALSE.
LMP2C=.FALSE.
LQMC=.FALSE.
LDETAIL=.FALSE.
LSELEC=.FALSE.
THRMP2=0.D0
LFRZ=.FALSE.
LNATOR=.FALSE.
LCIMP=.FALSE.
LMP2EG=.FALSE.
LEN2C=.FALSE.
LMP3 =.FALSE.
LEN3 =.FALSE.
LEXSCI=.FALSE.
LTOTAL=.FALSE.
LRESTO=.FALSE.
DO I=1,NBASM
IORBFZ(I)=2
END DO
LCILOC=.FALSE.
LRDET=.FALSE.
LPERLOC=.FALSE.
C structure of input:
C keyword for each program
IOINP=83
OPEN(UNIT=IOINP,FILE='INPUT.ICM',ERR=2217,FORM='FORMATTED',
- STATUS='OLD')
C first, look for keyword '*ICM'
1 CONTINUE
READ(IOINP,'(A4)',END=2,ERR=921) STR3
IF (STR3.EQ.KEYW(1)) THEN
C look for Keyoptions
11 CONTINUE
READ(IOINP,'(A6)',END=920,ERR=921) STR6
C this is the keyword *END
IF (STR6(1:4).EQ.KEYW(2)) RETURN
IF (STR6.EQ.KEYOPT(1)) THEN
C Epstein-Nesbet
LEPSN=.TRUE.
LPERT=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(2)) THEN
C LCCD
LLCCD=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(3)) THEN
C CEPA-0
LCEPA0=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(4)) THEN
C CEPA-2
LCEPA2=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(5)) THEN
C CEPA-3
LCEPA3=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(6)) THEN
C SCSC
LSCSC=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(7)) THEN
C CISD
LCISD=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(8)) THEN
C NITDAV
READ(IOINP,*) NITDAV
IF (NITDAV.LE.0) THEN
WRITE(6,*) ' WE SET NITDAV TO 50'
NITDAV=50
END IF
ELSE IF (STR6.EQ.KEYOPT(9)) THEN
C PRINTL
READ(IOINP,*) IPRINT
IF (IPRINT.LT.0) THEN
WRITE(6,*) ' WE SET IPRINT=0'
IPRINT=0
END IF
IF (IPRINT.GT.10) THEN
WRITE(6,*) ' WE SET IPRINT=10'
IPRINT=10
END IF
ELSE IF (STR6.EQ.KEYOPT(10)) THEN
C NOPERT
LPERT=.FALSE.
LEPSN=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(11)) THEN
C TOLCCD
READ(IOINP,*) ITOL
TOLCCD=10.D0**DBLE(-ITOL)
ELSE IF (STR6.EQ.KEYOPT(12)) THEN
C TOLCI
READ(IOINP,*) ITOL
TOLCI=10.D0**DBLE(-ITOL)
ELSE IF (STR6.EQ.KEYOPT(13)) THEN
C ITLCCD
READ(IOINP,*) ITLCCD
IF (ITLCCD.LE.0) THEN
WRITE(6,*) ' WE SET ITLCCD TO 50'
ITLCCD=50
END IF
ELSE IF (STR6.EQ.KEYOPT(14)) THEN
C THRPRI
READ(IOINP,*) THRPRI
ELSE IF (STR6.EQ.KEYOPT(15)) THEN
C XGADEA
LXAV=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(16)) THEN
C READCI
LVECR2=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(17)) THEN
C READLC
LVECR1=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(18)) THEN
C FORMAT
LDELCU=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(19)) THEN
C CIS
LCIS=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(20)) THEN
C CID
LCID=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(21)) THEN
C THRINT
READ(IOINP,*) ITOL
THRINT=10.D0**DBLE(-ITOL)
ELSE IF (STR6.EQ.KEYOPT(22)) THEN
C ACPF
LACPF=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(23)) THEN
C KUTZEL, LCCSD
LKUTZ=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(24)) THEN
C AQCC
LAQCC=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(25)) THEN
C MP2C
LMP2C=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(26)) THEN
C AQCC-V
LAQCCV=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(27)) THEN
C QMC
LQMC=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(28)) THEN
C QMC
LDETAIL=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(29)) THEN
C SELECT
LSELEC=.TRUE.
READ(IOINP,*) THRMP2
ELSE IF (STR6.EQ.KEYOPT(30)) THEN
C FREEZE ORBITALS
LFRZ=.TRUE.
READ(IOINP,*) NFRZO
IF (NFRZO.NE.0) READ(IOINP,*) (INREAD(I),I=1,NFRZO)
DO I=1,NFRZO
IORBFZ(INREAD(I))=1
END DO
ELSE IF (STR6.EQ.KEYOPT(31)) THEN
C DELETE ORBITALS
LFRZ=.TRUE.
READ(IOINP,*) NDELO
IF (NDELO.NE.0) READ(IOINP,*) (INREAD(I),I=1,NDELO)
DO I=1,NDELO
IORBFZ(INREAD(I))=3
END DO
ELSE IF (STR6.EQ.KEYOPT(32)) THEN
C natural orbitals
LNATOR=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(33)) THEN
C Approximated CI/CEPA methods, either 2X2 or diagonal approximation
LPERT=.TRUE.
LCIMP=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(34)) THEN
C MP2 development of the CI matrix, 2X2 rotations
LMP2EG=.TRUE.
LCIMP=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(35)) THEN
C EN2CAN: EN2 with dressing and F summations
LEN2C=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(36)) THEN
C CALPHP: calculate the real with the correlated wavefunction
LPHP=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(38)) THEN
C MP3
LMP3=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(39)) THEN
C EN3
LEN3=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(40)) THEN
C EXSCI selecting CI via exchange integral
LEXSCI=.TRUE.
READ(IOINP,*) TRSEXY
IF (ABS(TRSEXY).GT.1.D0) TRSEXY=10**(-ABS(TRSEXY))
ELSE IF (STR6.EQ.KEYOPT(41)) THEN
C TOTALE gives total energies instead of correlation energies only
LTOTAL=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(42)) THEN
C RESTORe restores the indices after a freezing/deleting of indices
LRESTO=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(43)) THEN
C RESTORe restores the indices after a freezing/deleting of indices
LCILOC=.TRUE.
READ(IOINP,*) IBOND1,IBOND2
ELSE IF (STR6.EQ.KEYOPT(44)) THEN
C Read a list of IJ pairs for forming the determinants in MAKRSD
LRDET=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(45)) THEN
C PERLOC adds the amplitudes of MP2CAN and an approximated dressed CEPA
LPERLOC=.TRUE.
ELSE
WRITE(6,*) ' UNKNOWN OPTION: |',STR6,'|'
WRITE(6,*)
WRITE(6,*) ' POSSIBLE OPTIONS IN THE BLOCK *ICM ... *END ARE:'
WRITE(6,*)
WRITE(6,*) ' ',KEYOPT(1)
WRITE(6,*) ' ',KEYOPT(2)
WRITE(6,*) ' ',KEYOPT(3)
WRITE(6,*) ' ',KEYOPT(4)
WRITE(6,*) ' ',KEYOPT(5)
WRITE(6,*) ' ',KEYOPT(6)
WRITE(6,*) ' ',KEYOPT(7)
WRITE(6,*) ' ',KEYOPT(8)
WRITE(6,*) ' ',KEYOPT(9)
WRITE(6,*) ' ',KEYOPT(10)
WRITE(6,*) ' ',KEYOPT(11)
WRITE(6,*) ' ',KEYOPT(12)
WRITE(6,*) ' ',KEYOPT(13)
WRITE(6,*) ' ',KEYOPT(14)
WRITE(6,*) ' ',KEYOPT(15)
WRITE(6,*) ' ',KEYOPT(16)
WRITE(6,*) ' ',KEYOPT(17)
WRITE(6,*) ' ',KEYOPT(18)
WRITE(6,*) ' ',KEYOPT(19)
WRITE(6,*) ' ',KEYOPT(20)
WRITE(6,*) ' ',KEYOPT(20)
WRITE(6,*) ' ',KEYOPT(21)
WRITE(6,*) ' ',KEYOPT(22)
WRITE(6,*) ' ',KEYOPT(23)
WRITE(6,*) ' ',KEYOPT(24)
WRITE(6,*) ' ',KEYOPT(25)
WRITE(6,*) ' ',KEYOPT(26)
WRITE(6,*) ' ',KEYOPT(27)
WRITE(6,*) ' ',KEYOPT(28)
WRITE(6,*) ' ',KEYOPT(29)
WRITE(6,*) ' ',KEYOPT(30)
WRITE(6,*) ' ',KEYOPT(31)
WRITE(6,*) ' ',KEYOPT(32)
WRITE(6,*) ' ',KEYOPT(33)
WRITE(6,*) ' ',KEYOPT(34)
WRITE(6,*) ' ',KEYOPT(35)
WRITE(6,*) ' ',KEYOPT(36)
WRITE(6,*) ' ',KEYOPT(38)
WRITE(6,*) ' ',KEYOPT(39)
WRITE(6,*) ' ',KEYOPT(40)
WRITE(6,*) ' ',KEYOPT(41)
WRITE(6,*) ' ',KEYOPT(42)
WRITE(6,*) ' ',KEYOPT(43)
WRITE(6,*) ' ',KEYOPT(44)
WRITE(6,*) ' ',KEYOPT(45)
STOP ' CHOOSE CORRECT OPTION '
END IF
GO TO 11
END IF
GO TO 1
C
921 CONTINUE
CLOSE(IOINP)
STOP ' ERROR IN INPUT'
2 CONTINUE
CLOSE(IOINP)
STOP ' NO KEYWORD *ICM FOUND, USING DEFAULTS '
920 CONTINUE
CLOSE(IOINP)
STOP ' YOU SHOULD TERMINATE THE BLOCK ICM BY <*END> '
2217 CONTINUE
WRITE(6,*) ' NO FILE , USING THE DEFAULT VALUES'
RETURN
END
C
SUBROUTINE FDD(X,R)
C
C here we construct the product F*Vector for the doubles
C this we may need for the canonical MP2
C
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
LOGICAL LIJ,LAB
DIMENSION X(*),R(*)
C
C we fabricate a non-spin-adapted vector
C the vector R has been initialized before
C
NBC=NBAS
NOV=NOCC+1
C
C performes the construction matrix times vector
C ITR=0 matrix
C ITR=1 transpose
C F is hermitian, ITR has thus no effect
C
C
C all integrals with at least 2 equal indices in core
C
NDET21=NDET2+1
DO 1 IDET=1,NDET2
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
C here we skip the singles and the reference
IF (I2.EQ.0) GO TO 1
C
INDI=ABS(I1)
INDJ=ABS(I2)
INDA=ABS(I3)
INDB=ABS(I4)
LIJ=SIGN(1,I1).EQ.SIGN(1,I2)
C
I=INDI
IF (I.NE.INDI) STOP
$ ' FDD: WE HAVE AN INCONSISTENCY IN I AND INDI'
J =INDJ
IA =INDA
IB =INDB
C
C the diagonal:
C
IVZ=1
HHH=DIAG(IDET)
CALL UPD(R,X,HHH,IDET,IDET,IVZ)
C
C the rest
C
INDJJ=INDJ
INDAA=INDA
INDBB=INDB
C CALL TURN4(INDJ,INDA,INDB,IVK,INDJJ,INDAA,INDBB)
DO K=1,NOCC
INDK=K
C
IF (INDK.NE.INDI.AND.INDK.NE.INDJ) THEN
C i -> k
I1R=SIGN(K ,I1)
J1R=SIGN(INDJJ,I2)
K1R=SIGN(INDAA,I3)
L1R=SIGN(INDBB,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(I,K)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
C j -> k
I1R=SIGN(INDI,I1)
J1R=SIGN(INDK,I2)
K1R=SIGN(INDA,I3)
L1R=SIGN(INDB,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(K,J)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END DO
C
C k=i, i=j this means that we are on the diagonal
IF (INDI.NE.INDJ) THEN
IF (.NOT.LIJ) THEN
JJ=INDJ
INDAA=INDA
INDBB=INDB
C CALL TURN4(INDJ,INDA,INDB,IVJ,JJ,INDAA,INDBB)
C k=j: jj
I1R= J
J1R=-J
K1R=SIGN(INDAA,I3)
L1R=SIGN(INDBB,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(I,J)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C k=i: iIab
I1R= I
J1R=-I
K1R=SIGN(INDA,I3)
L1R=SIGN(INDB,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=-F(I,J)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
C
C change virtual index
C
DO IC=NOCC+1,NBAS
INDC=IC
IF (INDC.NE.INDA.AND.INDC.NE.INDB) THEN
C a -> c
I1R=SIGN(INDI,I1)
J1R=SIGN(INDJ,I2)
K1R=SIGN(INDC,I3)
L1R=SIGN(INDB,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(IA,IC)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C
C b -> c
I1R=SIGN(INDI,I1)
J1R=SIGN(INDJ,I2)
K1R=SIGN(INDA,I3)
L1R=SIGN(INDC,I4)
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(IB,IC)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
C
END DO
C
C c=a or c=b
IF (INDA.NE.INDB) THEN
IF (.NOT.LIJ) THEN
C c=a
I1R=SIGN(INDI,I1)
J1R=SIGN(INDJ,I2)
K1R= INDA
L1R=-INDA
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(IA,IB)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
C c=b
I1R=SIGN(INDI,I1)
J1R=SIGN(INDJ,I2)
K1R= INDB
L1R=-INDB
IVZ=1
CALL ODET(I1R,J1R,K1R,L1R,IVZ)
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
IF (INDXR.LE.IDET) THEN
HHH=F(IA,IB)
CALL UPD(R,X,HHH,IDET,INDXR,IVZ)
END IF
END IF
END IF
C
C end of the loop over determinants
C
1 CONTINUE
C
RETURN
END
C
SUBROUTINE LINCGD(N,B,X,TOL,ITMAX,ITER,ERR,IMODE)
C conjugate gradients with preconditioner, dressing included
INCLUDE 'param.h'
PARAMETER (NMAX=NDETMX,EPS=1.D-14,NTMX=50)
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
INTEGER ITER,ITMAX,ITOL,N
DOUBLE PRECISION B(*),X(*)
DIMENSION R(NMAX),P(NMAX),Z(NMAX),AP(NMAX)
C
C USES ATIMES,ASOLVE,SNRM
C
IF (N.GT.NMAX) THEN
WRITE(6,*) 'NMAX =',NMAX
WRITE(6,*) 'N =',N
WRITE (6,*) 'LINCG: NMAX INSUFFICIENT '
RETURN
END IF
C
WRITE(6,*)
WRITE(6,*) ' ENTERED LINCGD, N= ',N
WRITE(6,*) ' DRESSING for .... '
WRITE(6,*)
C
IF (IMODE.EQ.1) THEN
WRITE(6,*) ' THIS WILL BE THE CISD '
ELSE IF (IMODE.EQ.2) THEN
WRITE(6,*) ' THIS WILL BE CEPA-0 '
ELSE IF (IMODE.EQ.3) THEN
WRITE(6,*) ' THIS WILL BE CEPA-2 '
ELSE IF (IMODE.EQ.4) THEN
WRITE(6,*) ' THIS WILL BE CEPA-3 '
ELSE IF (IMODE.EQ.5) THEN
WRITE(6,*) ' THIS WILL BE SCSC '
ELSE IF (IMODE.EQ.6) THEN
WRITE(6,*) ' THIS WILL BE LCC(S)D '
ELSE IF (IMODE.EQ.7) THEN
WRITE(6,*) ' THIS WILL BE ACPF '
ELSE IF (IMODE.EQ.8) THEN
WRITE(6,*) ' THIS WILL BE CANONICAL MP2 '
ELSE IF (IMODE.EQ.9) THEN
WRITE(6,*) ' THIS WILL BE AQCC '
ELSE
WRITE(6,*) ' IMODE =',IMODE
WRITE(6,*) ' WRONG IMODE ... '
STOP ' WRONG IMODE ... '
END IF
C
C in the case of dynamical dressing we have save the correct diagonal
C onto file
C
OPEN(UNIT=77,FILE='DIAG.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
WRITE(77) (DIAG(I),I=1,N)
CLOSE(77)
C
WRITE(6,*)
WRITE(6,*) ' THIS SHOULD BE THE MP2-ENERGY:'
CALL ECORRC(N,X,0,EDUM)
WRITE(6,*)
C dress the diagonal
CALL EPVL(ECORR,X,DIAG,IMODE)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C that was the preparation
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
BNRM=SNRM(N,B)
CALL ATIMES(N,X,R,IMODE)
DO I=1,N
R(I)=B(I)-R(I)
END DO
CALL ASOLVE(N,R,Z)
C R is provided, and the first Z
ITER=1
ITER2=ITER
C
C here we start the iteration loop
C
100 CONTINUE
C
C how about dressing here?
C
C generate the dressing
C IMODE=2 CEPA-0
C IMODE=3 CEPA-2
C IMODE=4 CEPA-3
C IMODE=5 SCSC
C IMODE=6 KUTZELNIGG's LCC(S)D
C IMODE=7 ACPF
C IMODE=8 canonical MP2
C IMODE=9 AQCC
C and calculate the actual correlation energy
CALL EVASOL(ITER,ERR,X,ECORR)
CALL FLUSH(6)
C dress the diagonal
C
C retrieve the diagonal from file
OPEN(UNIT=77,FILE='DIAG.TMP',STATUS='OLD',FORM='UNFORMATTED')
READ(77) (DIAG(I),I=1,N)
CLOSE(77)
C dress the diagonal
CALL EPVL(ECORR,X,DIAG,IMODE)
C calculate BETA and P
RKZK=0.D0
BB=0.D0
DO I=1,N
RKZK=RKZK+R(I)*Z(I)
END DO
C update P
IF (ITER.EQ.1) THEN
DO I=1,N
P(I)=Z(I)
END DO
ELSE
BETA=RKZK/RKZKO
DO I=1,N
P(I)=Z(I)+BETA*P(I)
END DO
END IF
RKZKO=RKZK
C
C calculate AP
C we may store AP in the vector Z here
CALL ATIMES(N,P,Z,IMODE)
C
BB=0.D0
DO I=1,N
BB=BB+P(I)*Z(I)
END DO
ALPHA=RKZK/BB
C
C the new residuum R(n+1)
DO I=1,N
C a new X
X(I)=X(I)+ALPHA*P(I)
R(I)=R(I)-ALPHA*Z(I)
END DO
C
C the new Z
CALL ASOLVE(N,R,Z)
C
ITER=ITER+1
ITER2=ITER2+1
IF (ITER.GE.NTMX) THEN
WRITE(6,*) ' NO CONVERGENCE, WE RESTART WITH THE ACTUAL VECTOR'
C
CALL ATIMES(N,X,R,IMODE)
DO I=1,N
R(I)=B(I)-R(I)
P(I)=R(I)
END DO
CALL ASOLVE(N,R,Z)
C R is provided, and the first Z
C store the first P
ITER=1
GO TO 100
END IF
C
IF (ITER2.GT.ITMAX) THEN
WRITE(6,*) ' ALL ITERATIONS USED ..... '
WRITE(6,*) ' NO CONVERGENCE, WE RETURN '
END IF
C
C check convergence
C
ERR=SNRM(N,R)/BNRM
WRITE(6,*) ' ITERATION ',ITER,' ERR = ',ERR
IF (ERR.GT.TOL.OR.ITER.LE.3) GOTO 100
C
C delete intermediate files
OPEN(UNIT=77,FILE='DIAG.TMP',STATUS='OLD',FORM='UNFORMATTED')
READ(77) (DIAG(I),I=1,N)
CLOSE(77,STATUS='DELETE')
C
RETURN
END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C the correct LINCG routine
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE LINCGX(N,B,X,TOL,ITMAX,ITER,ERR,IMODE)
C conjugate gradients with preconditioner, no dressing
INCLUDE 'param.h'
PARAMETER (NMAX=NDETMX,EPS=1.D-14,NTMX=50)
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
INTEGER ITER,ITMAX,ITOL,N
DOUBLE PRECISION B(*),X(*)
DIMENSION R(NMAX),P(NMAX),Z(NMAX)
C
C USES ATIMES,ASOLVE,SNRM
C
IF (N.GT.NMAX) THEN
WRITE(6,*) 'NMAX =',NMAX
WRITE(6,*) 'N =',N
WRITE (6,*) 'LINCG: NMAX INSUFFICIENT '
RETURN
END IF
C
WRITE(6,*)
WRITE(6,*) ' CORRELATION ENERGY OF THE STARTING VECTOR:'
CALL ECORRC(N,X,0,EDUM)
WRITE(6,*)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C that was the preparation
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
BNRM=SNRM(N,B)
CALL ATIMES(N,X,R,IMODE)
DO I=1,N
R(I)=B(I)-R(I)
END DO
CALL ASOLVE(N,R,Z)
C R is provided, and the first Z
ITER=1
ITER2=ITER
C
C here we start the iteration loop
C
100 CONTINUE
C
CALL EVASOL(ITER,ERR,X,ECORR)
C calculate BETA and P
RKZK=0.D0
BB=0.D0
DO I=1,N
RKZK=RKZK+R(I)*Z(I)
END DO
C update P
IF (ITER.EQ.1) THEN
DO I=1,N
P(I)=Z(I)
END DO
ELSE
BETA=RKZK/RKZKO
DO I=1,N
P(I)=Z(I)+BETA*P(I)
END DO
END IF
RKZKO=RKZK
C
C calculate AP
C we may store AP in the vector Z here
CALL ATIMES(N,P,Z,IMODE)
C
BB=0.D0
DO I=1,N
BB=BB+P(I)*Z(I)
END DO
ALPHA=RKZK/BB
C
C the new residuum R(n+1)
DO I=1,N
C a new X
X(I)=X(I)+ALPHA*P(I)
R(I)=R(I)-ALPHA*Z(I)
END DO
C
C the new Z
CALL ASOLVE(N,R,Z)
C
ITER=ITER+1
ITER2=ITER2+1
IF (ITER.GE.NTMX) THEN
WRITE(6,*) ' NO CONVERGENCE, WE RESTART WITH THE ACTUAL VECTOR'
C
CALL ATIMES(N,X,R,IMODE)
DO I=1,N
R(I)=B(I)-R(I)
P(I)=R(I)
END DO
CALL ASOLVE(N,R,Z)
C R is provided, and the first Z
C store the first P
ITER=1
GO TO 100
END IF
C
IF (ITER2.GT.ITMAX) THEN
WRITE(6,*) ' ALL ITERATIONS USED ..... '
WRITE(6,*) ' NO CONVERGENCE, WE RETURN '
END IF
C
C check convergence
C
ERR=SNRM(N,R)/BNRM
WRITE(6,*) ' ITERATION ',ITER,' ERR = ',ERR
IF (ERR.GT.TOL.OR.ITER.LE.3) GOTO 100
C
RETURN
END
C
SUBROUTINE EPVL(ECORR,CVECT,RDIAG,IMODE)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
PARAMETER (NE123M=600000)
COMMON /SCSC/ ETABLE(NE123M)
DIMENSION RDIAG(NDETMX)
C.. INCLUDE 'etable.h'
C CVECT is ths actual CI vector
DIMENSION CVECT(*)
DIMENSION ISARR(NBASM)
LOGICAL LI,LJ,LK,LL
C
C here we have the CEPA dressings
C
C
C IMODE is as before:
C 1 meaning CISD
C 2 meaning CEPA-0
C 3 meaning CEPA-1
C 4 meaning CEPA-2
C 5 meaning (SC)^2
C 6 meaning Kutzel
C 7 meaning ACPF
C 8 meaning MP2C
C 9 meaning AQCC
C 10 meaning AQCC-V
C
IF (IMODE.EQ.2) RETURN
IF (IMODE.EQ.6) RETURN
IF (IMODE.EQ.8) RETURN
C
IF (IMODE.EQ.1) THEN
C CISD: DDD=-ECORR*DBLE(NCELL)
DDD=-ECORR
DO IDET=1,NDET2
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.7) THEN
C ACPF: DDD=(-1/NOCC)*ECORR
XML=-1.D0/DBLE(NOCC)
DDD=ECORR*XML
C WRITE(6,9983) XML, ECORR,DDD
9983 FORMAT(' ACPF DRESSING: FACTOR, ECORR, DRESSING ',3F20.12)
DO IDET=1,NDET2
C for ACPF all determinants will be dressed, except for the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.9) THEN
C AQCC: DDD=-1/NOCC*ECORR*(2n-3)/(n-1)
NELE=2*NOCC
XML=-1.D0/DBLE(NOCC)*DBLE(2*NELE-3)/DBLE(NELE-1)
WRITE(6,*) ' AQCC DRESSING: FACTOR ',XML
DDD=ECORR*XML
DO IDET=1,NDET2
C for AQCC all determinants will be dressed, except the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
IF (IMODE.EQ.10) THEN
C AQCC-V: DDD=-2/NOCC*ECORR*(1+NOCC/NVIRT)
XML=-2.D0/DBLE(NOCC)*(1.D0+DBLE(NOCC)/DBLE(NBAS-NOCC))
WRITE(6,*) ' AQCC-V DRESSING: FACTOR ',XML
DDD=ECORR*XML
DO IDET=1,NDET2
C for AQCC all determinants will be dressed, except the reference
IF (IDET.NE.IREFN) RDIAG(IDET)=RDIAG(IDET)+DDD
END DO
RETURN
END IF
C
DELTA=0.D0
C
C first, we fill an intermediate index table - to be used for E3
C
INDX=0
DO I=1,NOCC
INDI=I
INDX=INDX+1
ISARR(INDI)=INDX
END DO
INDX=0
DO I=NOCC+1,NBAS
INDI=I
INDX=INDX+1
ISARR(INDI)=INDX
END DO
C
C constants and offsets
C
NBC=NBAS
NE1=NBAS
NE12=NE1+NBAS*(2*NBC+1)
NE12A=NE12+NOCC*(2*NOCC+1)*(2*NVIRT+1)
NE12B=NE12A+NOCC*(2*NVIRT+1)*(2*NVIRT+1)
IF (IMODE.EQ.2) THEN
NEED=NE1
ELSE IF (IMODE.EQ.3.OR.IMODE.EQ.4) THEN
NEED=NE12
ELSE IF (IMODE.EQ.5) THEN
NEED=NE12B
END IF
DO I=1,NEED
ETABLE(I)=0.D0
END DO
C
NOC=NOCC
NVC=NVIRT
INC1=2*NBC+1
INC2=2*NOC+1
INC3=2*NVC+1
IOFF1=NE1+1+NBC-INC1
IOFF2=NE12+INC3*NOC+NVC-INC3*INC2+1
IOFF3=NE12A+1+INC3*NVC-INC3*INC3
C
WRITE(6,*) ' IOFF1, IOFF2, IOFF3 ',IOFF1,IOFF2,IOFF3
WRITE(6,*) ' INC1, INC2, INC3 ',INC1, INC2, INC3
C
DO IDET=1,NDET2
INDI=ID0(1,IDET)
IF (INDI.NE.0) THEN
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
INDL=ID0(4,IDET)
C
C recall the order of the determinants
C reference (0000)
C singles (I0K0) I occ, K virt
C doubles (IJKL) I,J occ, K,L virt; |I| < |J|, |K|<|L|
C if |I|=|J|: I -I
C
IDET1=IDET
IVZ=1
EPVC=CVECT(IDET1)*BVECT(IDET1)
C
LI=INDI.LE.0
LJ=INDJ.LE.0
LK=INDK.LE.0
LL=INDL.LE.0
C
INDI=ABS(INDI)
INDJ=ABS(INDJ)
INDK=ABS(INDK)
INDL=ABS(INDL)
C
I=INDI
K=INDK
IF (INDJ.NE.0) THEN
J=INDJ
L=INDL
END IF
C
C E1(I), E1(J), E1(K), E1(L)
IF (.NOT.LI) ETABLE(I)=ETABLE(I)+EPVC
IF (.NOT.LJ) ETABLE(J)=ETABLE(J)+EPVC
IF (.NOT.LK) ETABLE(K)=ETABLE(K)+EPVC
IF (.NOT.LL) ETABLE(L)=ETABLE(L)+EPVC
C
IF (.NOT.LI) THEN
C E2(I,J)
IF (INDJ.NE.0) THEN
INDIJ=INDJ
IF (LJ) INDIJ=-INDIJ
INDX=IOFF1+I*INC1+INDIJ
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '1 +++ ',I,INDIJ,INDX,EPVC,ETABLE(INDX)
END IF
C E2(I,K)
INDIK=INDK
IF (LK) INDIK=-INDIK
INDX=IOFF1+I*INC1+INDIK
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '2 +++ ',I,INDIK,INDX,EPVC,ETABLE(INDX)
C E2(I,L)
IF (INDL.NE.0) THEN
INDIL=INDL
IF (LL) INDIL=-INDIL
INDX=IOFF1+I*INC1+INDIL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '3 +++ ',I,INDIL,INDX,EPVC,ETABLE(INDX)
END IF
END IF
IF (.NOT.LJ) THEN
C E2(J,K)
INDJK=INDK
IF (LK) INDJK=-INDJK
INDX=IOFF1+J*INC1+INDJK
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '4 +++ ',J,INDJK,INDX,EPVC,ETABLE(INDX)
C E2(J,L)
INDJL=INDL
IF (LL) INDJL=-INDJL
INDX=IOFF1+J*INC1+INDJL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '5 +++ ',J,INDJL,INDX,EPVC,ETABLE(INDX)
END IF
IF (.NOT.LK.AND.INDL.NE.0) THEN
C E2(K,L)
INDKL=INDL
IF (LL) INDKL=-INDKL
INDX=IOFF1+K*INC1+INDKL
ETABLE(INDX)=ETABLE(INDX)+EPVC
C WRITE(6,9771) '6 +++ ',K,INDKL,INDX,EPVC,ETABLE(INDX)
END IF
9771 FORMAT(' ',A7,3I5,2E20.12)
C
C we need the E3 table only for the (SC)^2
C
IF (IMODE.GT.4) THEN
C
C now the table E3
C first the table oov
C
IF (INDJ.NE.0) THEN
IF (.NOT.LI) THEN
INDX1=I
INDX2=ISARR(INDJ)
INDX3=ISARR(INDK)
INDX4=ISARR(INDL)
IF (LJ) INDX2=-INDX2
IF (LK) INDX3=-INDX3
IF (LL) INDX4=-INDX4
C
C E3(I,J,K)
INDX=IOFF2+INDX3+INC3*(INDX2+INC2*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C E3(I,J,L)
INDX=IOFF2+INDX4+INC3*(INDX2+INC2*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C
C now the table ovv
C
C E3(I,K,L)
INDX=IOFF3+INDX4+INC3*(INDX3+INC3*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
INDX=IOFF3+INDX3+INC3*(INDX4+INC3*INDX1)
ETABLE(INDX)=ETABLE(INDX)+EPVC
C E3(J,K,L)
IF (.NOT.LJ) THEN
INDX5=J
INDX=IOFF3+INDX4+INC3*(INDX3+INC3*INDX5)
ETABLE(INDX)=ETABLE(INDX)+EPVC
INDX=IOFF3+INDX3+INC3*(INDX4+INC3*INDX5)
ETABLE(INDX)=ETABLE(INDX)+EPVC
END IF
END IF
END IF
END IF
END IF
END DO
C
C the dressing
C
c$$$ WRITE(6,*) ' E1 ----------------------------------------- '
c$$$ DO I=1,NBAS
c$$$ WRITE(6,*) ' E1(I)',I,ETABLE(I)
c$$$ END DO
c$$$ WRITE(6,*) ' E2 ----------------------------------------- '
c$$$ DO I=1,NBAS
c$$$ DO INDJ=1,NBAS*NCELL
c$$$ INDX=IOFF1+I*INC1+INDJ
c$$$ WRITE(6,*) ' E2(I,J) ',I,INDJ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF1+I*INC1-INDJ
c$$$ WRITE(6,*) ' E2(I,-J)',I,-INDJ,INDX,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ IF (IMODE.GT.4) THEN
c$$$ WRITE(6,*) ' E3A ----------------------------------------- '
c$$$ DO I=1,NOCC
c$$$ DO INDJ=1,NVIRT*NCELL
c$$$ DO INDK=1,NVIRT*NCELL
c$$$ INDX=IOFF2+INDK+INC2*(INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I, J, K)',I, INDJ, INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2-INDK+INC2*(INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I, J,-K)',I, INDJ,-INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2+INDK+INC2*(-INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I,-J, K)',I,-INDJ, INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF2-INDK+INC2*(-INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I,-J,-K)',I,-INDJ,-INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ END DO
c$$$ WRITE(6,*) ' E3B ----------------------------------------- '
c$$$ DO I=1,NOCC
c$$$ DO INDJ=1,NVIRT*NCELL
c$$$ DO INDK=1,NVIRT*NCELL
c$$$ INDX=IOFF3+INDK+INC3*(INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I, J, K)',I, INDJ, INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3-INDK+INC3*(INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I, J,-K)',I, INDJ,-INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3+INDK+INC3*(-INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I,-J, K)',I,-INDJ, INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ INDX=IOFF3-INDK+INC3*(-INDJ+INC3*I)
c$$$ WRITE(6,'(2X,A13,4I5,E20.12)') ' E3(I,-J,-K)',I,-INDJ,-INDK
c$$$ $ ,INDX,ETABLE(INDX)
c$$$ END DO
c$$$ END DO
c$$$ END DO
c$$$ END IF
c$$$ STOP ' FILLED E'
C
DO IDET=1,NDET2
INDI=ID0(1,IDET)
II=SIGN(1,INDI)
IF (INDI.NE.0) THEN
C the CEPA-0
DDD=DELTA
C
INDJ=ID0(2,IDET)
INDK=ID0(3,IDET)
IJ=SIGN(1,INDJ)
IK=SIGN(1,INDK)
INDI=ABS(INDI)
INDK=ABS(INDK)
I=INDI
K=INDK
I1=I
K1=K
K2=II*IK*K
C dressing of doubles
IF (INDJ.NE.0) THEN
INDL=ID0(4,IDET)
IJ=SIGN(1,INDJ)
IL=SIGN(1,INDL)
INDJ=ABS(INDJ)
INDL=ABS(INDL)
J=INDJ
L=INDL
C
J1=J
L1=L
C
J2=II*IJ*J
L2=II*IL*L
C
K3=IJ*IK*K
L3=IJ*IL*L
C
L4=IK*IL*L
C
c$$$ DDD=DELTA-E1(I1)-E1(J1)-E1(K1)-E1(L1)
c$$$ - +E2(I1,J2)+E2(I1,K2)+E2(I1,L2)
c$$$ - +E2(J1,K3)+E2(J1,L3)+E2(K1,L4)
c$$$ - -E3(I1,J2,K2)-E3(I1,J2,L2)
c$$$ - -E3(I1,K2,L2)-E3(J1,K3,L3)
c$$$ - -CVECT(IDET)*BVECT(IDET)
C
C prepare the indices
C
I1J2=IOFF1+J2+INC1*I1
C
IF (IMODE.EQ.3) THEN
C the CEPA-2
DDD=DELTA-ETABLE(I1J2)
ELSE IF (IMODE.EQ.4) THEN
C the CEPA-3
DDD=DELTA-ETABLE(I1)-ETABLE(J1)+ETABLE(I1J2)
ELSE IF (IMODE.EQ.5) THEN
C the FULL CEPA
I1K2=IOFF1+K2+INC1*I1
I1L2=IOFF1+L2+INC1*I1
J1K3=IOFF1+K3+INC1*J1
J1L3=IOFF1+L3+INC1*J1
K1L4=IOFF1+L4+INC1*K1
JJ2=SIGN(ISARR(ABS(J2)),J2)
KK2=SIGN(ISARR(ABS(K2)),K2)
LL2=SIGN(ISARR(ABS(L2)),L2)
KK3=SIGN(ISARR(ABS(K3)),K3)
LL3=SIGN(ISARR(ABS(L3)),L3)
I1J2K2=IOFF2+KK2+INC3*(JJ2+INC2*I1)
I1J2L2=IOFF2+LL2+INC3*(JJ2+INC2*I1)
I1K2L2=IOFF3+LL2+INC3*(KK2+INC3*I1)
J1K3L3=IOFF3+LL3+INC3*(KK3+INC3*J1)
DDD=DDD
- -ETABLE(I1)-ETABLE(J1)-ETABLE(K1)-ETABLE(L1)
- +ETABLE(I1J2)+ETABLE(I1K2)+ETABLE(I1L2)
- +ETABLE(J1K3)+ETABLE(J1L3)+ETABLE(K1L4)
- -ETABLE(I1J2K2)-ETABLE(I1J2L2)
- -ETABLE(I1K2L2)-ETABLE(J1K3L3)
- +CVECT(IDET)*BVECT(IDET)
C - -CVECT(IDET)*BVECT(IDET)
END IF
ELSE
C dressing of SINGLES
INDL=0
I1K2=IOFF1+K2+INC1*I1
DDD=DELTA-ETABLE(I1)-ETABLE(K1)+ETABLE(I1K2)
END IF
C finally, the dressing
RDIAG(IDET)=RDIAG(IDET)+DDD
ELSE
C the reference will not be dressed
RDIAG(IDET)=RDIAG(IDET)
END IF
END DO
C
RETURN
END
C
SUBROUTINE OUTQMC(CHEXT)
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /VECTCO/ CI(NBASM,NBASM),IOCCS(NBASM),IOCC(NBASM)
C.. INCLUDE 'common_vectco.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /BAS/ EXX(NPRIMX),COEFF(NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX)
C.. INCLUDE 'common_basis.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
LOGICAL LI,LJ,LK,LL
DIMENSION IVALPH(NBASM),IVBETA(NBASM)
DIMENSION OWBUF(NPRIMX*(NLMAX+NLMAX+1)),
- IWBUF(NPRIMX*(NLMAX+NLMAX+1)),XNBUF(NPRIMX*(NLMAX+NLMAX+1))
DIMENSION XNORM(NLMAX,-NLMAX:NLMAX),DNORM(NPRIMX*(NLMAX+NLMAX+1))
DIMENSION XCOEF(NLMAX,-NLMAX:NLMAX)
CHARACTER*16 CSTRI(NLMAX,-NLMAX:NLMAX)
CHARACTER*6 CHEXT
CHARACTER*2 SYMBAT(0:92)
INTEGER*2 SYMLEN(0:92)
DIMENSION POS(3)
DIMENSION NSHLT(NLMAX,NATMX),COPRIM(NPRIMX),IZENTR(NSHLMX)
CHARACTER*1 CST(10),CBUCH(0:9)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA CBUCH /'0','1','2','3','4','5','6','7','8','9'/
DATA SYMBAT/ 'XX','H ','HE','LI','BE','B ','C ','N ',
1'O ','F ','NE','NA','MG','AL','SI','P ','S ','CL','AR',
2'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI','CU',
3'ZN','GA','GE','AS','SE','BR','KR','RB','SR','Y ','ZR',
4'NB','MO','TC','RU','RH','PD','AG','CD','IN','SN','SB',
5'TE','I ','XE','CS','BA','LA','CE','PR','ND','PM','SM',
6'EU','GD','TB','DY','HO','ER','TM','YB','LU','HF','TA',
7'W ','RE','OS','IR','PT','AU','HG','TL','PB','BI','PO',
8'AT','RN','FR','RA','AC','TH','PA','U '/
DATA SYMLEN/ 2,1,2,2,2,1,1,1,
1 1,1,2,2,2,2,2,1,1,2,2,
2 1,2,2,2,1,2,2,2,2,2,2,
3 2,2,2,2,2,2,2,2,2,1,2,
4 2,2,2,2,2,2,2,2,2,2,2,
5 2,1,2,2,2,2,2,2,2,2,2,
6 2,2,2,2,2,2,2,2,2,2,2,
7 1,2,2,2,2,2,2,2,2,2,2,
8 2,2,2,2,2,2,2,1/
CSTRI(1,0) ='S 1 '
CSTRI(2,-1)='P Y '
CSTRI(2,1) ='P X '
CSTRI(2,0) ='P Z '
CSTRI(3, 2)='D XX-YY '
CSTRI(3, 1)='D XZ '
CSTRI(3, 0)='D 3ZZ-RR '
CSTRI(3,-1)='D YZ '
CSTRI(3,-2)='D XY '
CSTRI(4, 3)='F X(XX-3YY) '
CSTRI(4, 2)='F Z(XX-YY) '
CSTRI(4, 1)='F X(5ZZ-RR) '
CSTRI(4, 0)='F Z(5ZZ-RR) '
CSTRI(4,-1)='F Y(5ZZ-RR) '
CSTRI(4,-2)='F XYZ '
CSTRI(4,-3)='F Y(3XX-YY) '
CSTRI(5, 4)='G X(XX-3YY) '
CSTRI(5, 3)='G X(XX-3YY) '
CSTRI(5, 2)='G Z(XX-YY) '
CSTRI(5, 1)='G X(5ZZ-RR) '
CSTRI(5, 0)='G Z(5ZZ-RR) '
CSTRI(5,-1)='G Y(5ZZ-RR) '
CSTRI(5,-2)='G XYZ '
CSTRI(5,-3)='G Y(3XX-YY) '
CSTRI(5,-4)='G X(XX-3YY) '
XCOEF(1, 0)=1.0D0
XCOEF(2,-1)=1.D0
XCOEF(2, 0)=1.D0
XCOEF(2, 1)=1.D0
XCOEF(3, 2)=3.D0
XCOEF(3, 1)=3.D0
XCOEF(3, 0)=0.5D0
XCOEF(3,-1)=3.D0
XCOEF(3,-2)=6.D0
XCOEF(4, 3)=15.0D0
XCOEF(4, 2)=15.0D0
XCOEF(4, 1)=1.5D0
XCOEF(4, 0)=0.5D0
XCOEF(4,-1)=1.5D0
XCOEF(4,-2)=30.0D0
XCOEF(4,-3)=15.0D0
WRITE(6,*)
WRITE(6,*) '-------------------------------------------------'
WRITE(6,*) '--- Q M C ----------- Q M C----------------------'
WRITE(6,*) '-------------------------------------------------'
C
C
C
C two files for the same information are opened:
C QMCDETLST_???? contains all relevant data and
C
C qmcin_???? contains the input file for the program of Michel
C
C the files are of the following structure:
C
C QMCDETLST_????: number of atoms, positions, basis, determiniants
C
C qmcin_????: number of atoms, positions, #determinants, Jastrows,
C basis, determinants
C
C so we determine already here the number of determinants in the
C expansion
C
NUMDET=0
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GT.THRPRI) NUMDET=NUMDET+1
END DO
C
C
IOUQMC=57
IINQMC=59
OPEN(UNIT=IOUQMC,FILE='QMCDETLST_'//CHEXT,FORM='FORMATTED',STATUS
$ ='UNKNOWN')
CLOSE(IOUQMC,STATUS='DELETE')
OPEN(UNIT=IOUQMC,FILE='QMCDETLST_'//CHEXT,FORM='FORMATTED',STATUS
$ ='NEW')
OPEN(UNIT=IINQMC,FILE='qmcin_'//CHEXT,FORM='FORMATTED',STATUS
$ ='UNKNOWN')
CLOSE(IINQMC,STATUS='DELETE')
OPEN(UNIT=IINQMC,FILE='qmcin_'//CHEXT,FORM='FORMATTED',STATUS
$ ='NEW')
WRITE(IOUQMC,*) ' Information written for a ',CHEXT,' run'
WRITE(IOUQMC,*) ' =========================================='
WRITE(IOUQMC,*)
C
C we give the whole information to a file, i.e. basis set, position and
C kind of atoms ... for this purpose we have to reread the system input,
C normalize basis functions, break Gaussians down ....
C
CALL FFCAL
IUNITR=76
C
OPEN(UNIT=IUNITR,FILE='SYSTEM.ORTHO',STATUS='OLD',
- FORM='FORMATTED')
READ(IUNITR,*) NATOM
C IOUQMC is a more general file with all necessary information
WRITE(IOUQMC,8001) NATOM
C IINQMC is the input file for the program of Michel Caffarel
WRITE(IINQMC,8101) NATOM
8001 FORMAT(' Number of atoms in the Molecule',/,I5)
8101 FORMAT('************************************',/
$ ,'Begin: Describe molecule',/
$ ,'************************************',/,'Number of nuclei',
$ /,I4,/,'Charge and position of nuclei')
WRITE(6,*)
C
NSHL=0
NBASY=1
LMAX=0
IPRIM=0
NPRIMT=0
DO IAT=1,NATOM
DO ITYPE=1,NLMAX
NSHLT(ITYPE,IAT)=0
END DO
READ(IUNITR,*) NUMAT,NSHLAT,(POS(J),J=1,3)
WRITE(IOUQMC,8002) SYMBAT(NUMAT),NUMAT,(POS(J),J=1,3)
WRITE(IINQMC,8102) NUMAT,(POS(J),J=1,3)
8002 FORMAT(' Atomic Symbol :',A,' nuclear charge '/,I5,/
$ ,' Position of this atom in a.u.',/,3(F20.12),/)
8102 FORMAT(I4,3F20.12)
C
WRITE(IOUQMC,8003)
8003 FORMAT(' Original Contracted Basis of that atom,'
$ ,' functions normalized (w.r.t. primtives)')
DO ISH=1,NSHLAT
NSHL=NSHL+1
IZENTR(NSHL)=IAT
READ(IUNITR,*) ITYPE,NPRIM(NSHL)
NPRIMT=NPRIMT+(ITYPE+ITYPE+1)*NPRIM(NSHL)
WRITE(IOUQMC,8004) ITYPE,NPRIM(NSHL),NSHL,CST(ITYPE+1)
8004 FORMAT(2I5,' ( contraction No',I4,' type ',A,' )')
IL(NSHL)=ITYPE
LMAX=MAX(ITYPE+1,LMAX)
NSHLT(ITYPE+1,IAT)=NSHLT(ITYPE+1,IAT)+1
NBASY=NBASY+ITYPE+ITYPE+1
IPST=IPRIM+1
DO III=1,NPRIM(NSHL)
IPRIM=IPRIM+1
READ(IUNITR,*) EXX(IPRIM),COEFF(IPRIM)
END DO
CALL NORMBF(NSHL,IPST)
DO III=0,NPRIM(NSHL)-1
WRITE(IOUQMC,'(2F20.12)') EXX(IPST+III),COEFF(IPST+III)
END DO
END DO
END DO
IF (LDETAIL) THEN
WRITE(IOUQMC,*)
WRITE(IOUQMC,*) ' SPECIFIC NORMATION FACTORS: '
WRITE(IOUQMC,*) ' L M FACTOR FUNCTION '
DO L=1,LMAX
DO M=-L+1,L-1
XNORM(L,M)=FAC(L-ABS(M))/FAC(L+ABS(M))
c$$$ WRITE(IOUQMC,*) ' L, M, (L-|M|)!, (L+|M|)! ',L-1,M, FAC(L-ABS(M))
c$$$ $ ,FAC(L+ABS(M))
IF (M.NE.0) XNORM(L,M)=XNORM(L,M)*2.0D0
XNORM(L,M)=XNORM(L,M)*XCOEF(L,M)
WRITE(IOUQMC,8006) L-1,M,XNORM(L,M),CSTRI(L,M)
END DO
END DO
8006 FORMAT(2I3,F20.12,' ',A)
WRITE(IOUQMC,*)
END IF
C
NBASY=NBASY-1
C
WRITE(6,*) ' NBAS =',NBASY
WRITE(6,*) ' NOCC =',NOCC
WRITE(6,*) ' LMAX =',LMAX
WRITE(6,*) ' NSHL =',NSHL
WRITE(6,*) ' NPRIM =',(NPRIM(I),I=1,NSHL)
WRITE(6,*) ' NPRIMT =',NPRIMT
C
WRITE(IINQMC,8103) 2*NOCC,NOCC,NOCC
WRITE(IINQMC,8104)
WRITE(IINQMC,8105) NUMDET
8103 FORMAT('Number of electrons',/,I4,/
$ ,'Number of elect. alpha and beta',/,2I4)
8104 FORMAT('************************************',/
$ ,'Begin: Wave function',/
$ ,'***************************************************',/
$ ,'Simple Jast factor: enter 1; Sophis. Jast : enter 0',/,'1',
$ /,'************************************',/
$ ,'Pseudo: enter 1; No Pseudos : enter 0',/,'0',/
$ ,'***************************************************')
8105 FORMAT('Number of configurations:',/,I4,/
$ ,'******************************************',/
$ ,'STARTING READING PARAMETERS SIMPLE JASTROW',/
$ ,'******************************************',/
$ ,'Parameters of simple Jastrow function: ')
8106 FORMAT(2I3,F10.6)
8107 FORMAT('Number of parameters:',/,I4,/
$ ,'END READING PARAMETERS SIMPLE JASTROW',/
$ ,'**************************************************',/
$ ,'BEGINNING READING PARAMETERS SOPHISTICATED JASTROW',/
$ ,'**************************************************',/
$ ,'Parameters of sophisticate Jastrow function:')
C
NJASIM=4+NATOM
NJASOF=23+5*NATOM
IZERO=0
ZERO=0.D0
DO IDET=1,NUMDET
DO IPAR=1,NJASIM
WRITE(IINQMC,8106) IPAR,IZERO,ZERO
END DO
END DO
WRITE(IINQMC,8107) NJASIM
DO IDET=1,NUMDET
DO IPAR=1,NJASOF
WRITE(IINQMC,8106) IPAR,IZERO,ZERO
END DO
END DO
WRITE(IINQMC,8108) NJASOF
8108 FORMAT('Number of parameters',/,I4,/
$ ,'END READING PARAMETERS SOPHISTICATED JASTROW',/
$ ,'**********************************',/,'Theta',/,'0.',/
$ ,'Atomic basis functions with or without normalization'
$ ,' prefactor',/
$ ,'1----> with prefactor 0-----> without prefactor',/,'0')
C
C that is all for the zeroed Jastrow
C
WRITE(6,*)
WRITE(IINQMC,8109) NPRIMT
8109 FORMAT('Nombre de fonctions de base:',/,I5,/
$ ,'Center Type Case exponent')
8110 FORMAT(3I6,F20.12,' ',A16)
C
CLOSE(IUNITR)
C
C reconstruct the angular momenta of the basis functions
C
C we assume that they are ordered with respect to angular momenta
C
WRITE(6,*) ' THE BASIS FUNCTIONS AND THEIR ANGULAR MOMENTA '
WRITE(6,*) ' (look at the output of CMM for coherence!! '
WRITE(6,*)
WRITE(6,*) ' IBAS CENTER L M '
WRITE(6,*) ' ============================'
IBAS=0
DO IAT=1,NATOM
DO ILL=1,LMAX
IF (ILL.EQ.2) THEN
DO ILTMP=1,NSHLT(ILL,IAT)
IKK=1
IBAS=IBAS+1
WRITE(6,9221) IBAS,IAT,CST(ILL),IKK
IKK=-1
IBAS=IBAS+1
WRITE(6,9221) IBAS,IAT,CST(ILL),IKK
IKK=0
IBAS=IBAS+1
WRITE(6,9221) IBAS,IAT,CST(ILL),IKK
END DO
C//SKIPCY
cYP-functions: MOLCAS and we: py, pz, px
cYhow big is this p-block?
cY ISSS=IBAS+1
cY NPF=NSHLT(ILL,IAT)
cYloop over all p-shells at this center
cY DO IKK=-1,1
cY ISHL=ISHLST
cY DO I=1,NPF
cY IBAS=IBAS+1
cY WRITE(6,9221) IBAS,IAT,CST(ILL),IKK
cY END DO
cY END DO
cY/ENDCY
ELSE
DO ILY=1,NSHLT(ILL,IAT)
DO IKK=-ILL+1,ILL-1
IBAS=IBAS+1
WRITE(6,9221) IBAS,IAT,CST(ILL),IKK
END DO
END DO
END IF
END DO
END DO
WRITE(6,*)
$ ' ====================================================== '
WRITE(6,*)
9221 FORMAT(2X,I6,I7,4X,A1,I6)
IF (LDETAIL) THEN
WRITE(6,*)
WRITE(6,*)
WRITE(6,*) 'AT THE LEVEL OF PRIMITIVES: '
WRITE(6,*)
WRITE(6,*) ' IPCOUNT IPRIM CENTR L '
$ ,'M Exp old Coeff new Coeff'
WRITE(6,*) ' ================================'
$ ,'========================================= '
END IF
C
WRITE(IOUQMC,*)
IF (LDETAIL) THEN
WRITE(IOUQMC,*)
$ ' IPRIM CENTER L M EXPONENT TYPE '
ELSE
WRITE(IOUQMC,*) ' IBAS CENTER CONTR L M TYPE '
END IF
IPRIM=0
ISHL=0
IPCOUNT=0
IBAS=0
DO IAT=1,NATOM
DO ILL=1,LMAX
IF (ILL.EQ.2) THEN
DO ILY=1,NSHLT(ILL,IAT)
ISHL=ISHL+1
LVAL=IL(ISHL)
NPRIML=NPRIM(ISHL)
IPST=IPRIM
IKK=1
IPRIM=IPST
IBAS=IBAS+1
IF (.NOT.LDETAIL) THEN
WRITE(IOUQMC,9224) IBAS,IAT,ISHL,LVAL,IKK,CSTRI(LVAL+1,IKK)
ELSE
DO III=1,NPRIML
IPRIM=IPRIM+1
EXPO=EXX(IPRIM)
IPCOUNT=IPCOUNT+1
WRITE(6,9222) IPCOUNT,IPRIM,IAT,LVAL,IKK,EXPO
$ ,COEFF(IPRIM),COEFF(IPRIM)*XNORM(LVAL+1,IKK)
WRITE(IOUQMC,9223) IPCOUNT,IAT,LVAL,IKK,EXPO,
- CSTRI(LVAL+1,IKK)
C
WRITE(IINQMC,8110) IAT,LVAL+9,IKK,EXPO,CSTRI(LVAL+1,IKK)
C
CALL NORM_PRIM(EXPO,LVAL,IKK,DCOEFF)
C
XNBUF(IPCOUNT)=COEFF(IPRIM)*DCOEFF*XCOEF(LVAL+1,IKK)
IF (ABS(XNBUF(IPCOUNT)).LE.1.D-6) WRITE(6,*) ' DOUBTFUL :'
$ ,COEFF(IPRIM),DCOEFF,XCOEF(LVAL+1,IKK)
IWBUF(IPCOUNT)=IBAS
END DO
END IF
C
IKK=-1
IPRIM=IPST
IBAS=IBAS+1
IF (.NOT.LDETAIL) THEN
WRITE(IOUQMC,9224) IBAS,IAT,ISHL,LVAL,IKK,CSTRI(LVAL+1,IKK)
ELSE
DO III=1,NPRIML
IPRIM=IPRIM+1
EXPO=EXX(IPRIM)
IPCOUNT=IPCOUNT+1
WRITE(6,9222) IPCOUNT,IPRIM,IAT,LVAL,IKK,EXPO
$ ,COEFF(IPRIM),COEFF(IPRIM)*XNORM(LVAL+1,IKK)
WRITE(IOUQMC,9223) IPCOUNT,IAT,LVAL,IKK,EXPO,
- CSTRI(LVAL+1,IKK)
WRITE(IINQMC,8110) IAT,LVAL+9,IKK,EXPO,CSTRI(LVAL+1,IKK)
CALL NORM_PRIM(EXPO,LVAL,IKK,DCOEFF)
XNBUF(IPCOUNT)=COEFF(IPRIM)*DCOEFF*XCOEF(LVAL+1,IKK)
IF (ABS(XNBUF(IPCOUNT)).LE.1.D-6) WRITE(6,*) ' DOUBTFUL :'
$ ,COEFF(IPRIM),DCOEFF,XCOEF(LVAL+1,IKK)
IWBUF(IPCOUNT)=IBAS
END DO
END IF
IKK=0
IPRIM=IPST
IBAS=IBAS+1
IF (.NOT.LDETAIL) THEN
WRITE(IOUQMC,9224) IBAS,IAT,ISHL,LVAL,IKK,CSTRI(LVAL+1,IKK)
ELSE
DO III=1,NPRIML
IPRIM=IPRIM+1
EXPO=EXX(IPRIM)
IPCOUNT=IPCOUNT+1
WRITE(6,9222) IPCOUNT,IPRIM,IAT,LVAL,IKK,EXPO
$ ,COEFF(IPRIM),COEFF(IPRIM)*XNORM(LVAL+1,IKK)
WRITE(IOUQMC,9223) IPCOUNT,IAT,LVAL,IKK,EXPO,
- CSTRI(LVAL+1,IKK)
WRITE(IINQMC,8110) IAT,LVAL+9,IKK,EXPO,CSTRI(LVAL+1,IKK)
CALL NORM_PRIM(EXPO,LVAL,IKK,DCOEFF)
XNBUF(IPCOUNT)=COEFF(IPRIM)*DCOEFF*XCOEF(LVAL+1,IKK)
IF (ABS(XNBUF(IPCOUNT)).LE.1.D-6) WRITE(6,*) ' DOUBTFUL :'
$ ,COEFF(IPRIM),DCOEFF,XCOEF(LVAL+1,IKK)
IWBUF(IPCOUNT)=IBAS
END DO
END IF
C WRITE(6,*) ' A LA FIN :',IPRIM,IPST+NPRIML
IPRIM=IPST+NPRIML
END DO
C//SKIPCY
cYP-functions: MOLCAS and we: py, pz, px
cYhow big is this p-block?
cY NPF=NSHLT(ILL,IAT)
cYloop over all p-shells at this center
cYwe hold the starting primitive of that block
cY IPST=IPRIM
cY ISHLST=ISHL
cY DO IKK=-1,1
cY IPRIM=IPST
cY ISHL=ISHLST
cY DO I=1,NPF
cY ISHL=ISHL+1
cY LVAL=IL(ISHL)
cY NPRIML=NPRIM(ISHL)
cY IBAS=IBAS+1
cY IF (.NOT.LDETAIL) THEN
cY WRITE(IOUQMC,9224) IBAS,IAT,ISHL,LVAL,IKK,CSTRI(LVAL+1,IKK)
cY ELSE
cY DO III=1,NPRIML
cY IPRIM=IPRIM+1
cY EXPO=EXX(IPRIM)
cY IPCOUNT=IPCOUNT+1
cY WRITE(6,9222) IPCOUNT,IPRIM,IAT,LVAL,IKK,EXPO
cY $ ,COEFF(IPRIM),COEFF(IPRIM)*XNORM(LVAL+1,IKK)
cY WRITE(IOUQMC,9223) IPCOUNT,IAT,LVAL,IKK,EXPO,
cY - CSTRI(LVAL+1,IKK)
cY
cY WRITE(IINQMC,8110) IAT,LVAL+9,IKK,EXPO,CSTRI(LVAL+1,IKK)
cY
cY CALL NORM_PRIM(EXPO,LVAL,IKK,DCOEFF)
cY
cY XNBUF(IPCOUNT)=COEFF(IPRIM)*DCOEFF*XCOEF(LVAL+1,IKK)
cY IWBUF(IPCOUNT)=IBAS
cY END DO
cY END IF
cY END DO
cY END DO
cY/ENDCY
9222 FORMAT(I6,I6,I7,I4,I3,F15.8,F12.8,' ->',F12.8)
9223 FORMAT(I6,I7,I4,I3,F20.12,' ',A)
9224 FORMAT(I6,I5,I6,I5,I3,' ',A)
ELSE
DO ILY=1,NSHLT(ILL,IAT)
ISHL=ISHL+1
LVAL=IL(ISHL)
NPRIML=NPRIM(ISHL)
IPST=IPRIM
DO IKK=-ILL+1,ILL-1
IPRIM=IPST
IBAS=IBAS+1
IF (.NOT.LDETAIL) THEN
WRITE(IOUQMC,9224) IBAS,IAT,ISHL,LVAL,IKK,CSTRI(LVAL+1,IKK)
ELSE
DO III=1,NPRIML
IPRIM=IPRIM+1
EXPO=EXX(IPRIM)
IPCOUNT=IPCOUNT+1
WRITE(6,9222) IPCOUNT,IPRIM,IAT,LVAL,IKK,EXPO
$ ,COEFF(IPRIM),COEFF(IPRIM)*XNORM(LVAL+1,IKK)
WRITE(IOUQMC,9223) IPCOUNT,IAT,LVAL,IKK,EXPO,
- CSTRI(LVAL+1,IKK)
WRITE(IINQMC,8110) IAT,LVAL+9,IKK,EXPO,CSTRI(LVAL+1,IKK)
CALL NORM_PRIM(EXPO,LVAL,IKK,DCOEFF)
XNBUF(IPCOUNT)=COEFF(IPRIM)*DCOEFF*XCOEF(LVAL+1,IKK)
IF (ABS(XNBUF(IPCOUNT)).LE.1.D-6) WRITE(6,*) ' DOUBTFUL :'
$ ,COEFF(IPRIM),DCOEFF,XCOEF(LVAL+1,IKK)
IWBUF(IPCOUNT)=IBAS
END DO
END IF
END DO
C WRITE(6,*) ' A LA FIN :',IPRIM,IPST+NPRIML
IPRIM=IPST+NPRIML
END DO
END IF
END DO
END DO
C
WRITE(6,*)
WRITE(6,*) ' NORMALIZATION FACTORS OF THE INDIVIDUAL PRIMITIVES: '
WRITE(6,*) ' Primitive Basis multiplicator '
DO I=1,IPCOUNT
WRITE(6,'(I10,I7,F20.12)') I,IWBUF(I),XNBUF(I)
END DO
WRITE(6,*)
WRITE(6,*)
IF (LDETAIL) THEN
WRITE(6,*)
$ ' ===================================================='
WRITE(6,*)
WRITE(6,*) ' COUNTING M VALUES WE HAVE ',IPCOUNT,
- ' PRIMITIVE BASIS FUNCTIONS'
WRITE(6,*)
END IF
C
C we put down the list of determinants
C
C normalization of the CI vector to be 1
CALL VNORM(VECT,2)
C save first the complete vector
C
OPEN (UNIT=66,FILE='VECT.TMP',FORM='UNFORMATTED',STATUS='UNKNOWN')
WRITE(66) (VECT(IDET),IDET=1,NDET2)
WRITE(IOUQMC,*)
WRITE(IOUQMC,*) ' THE LIST OF IMPORTANT DETERMINANTS '
WRITE(IOUQMC,*) ' THRESHOLD AT ',THRPRI
WRITE(6,*)
WRITE(6,*) ' THE LIST OF IMPORTANT DETERMINANTS '
WRITE(6,*) ' THRESHOLD AT ',THRPRI
C
INUM=0
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GE.THRPRI) THEN
INUM=INUM+1
ELSE
VECT(IDET)=0.D0
END IF
END DO
C normalization of the CI vector to be 1
CALL VNORM(VECT,2)
C
INUM=0
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GE.THRPRI) THEN
INUM=INUM+1
WRITE(IOUQMC,8008) INUM,(ID0(J,IDET),J=1,4),VECT(IDET)
WRITE(6,8008) IDET,(ID0(J,IDET),J=1,4),VECT(IDET)
ELSE
VECT(IDET)=0.D0
END IF
HVECT(IDET)=0.D0
END DO
WRITE(IOUQMC,*)
WRITE(IOUQMC,*) ' Number of Selected Determinants'
WRITE(IOUQMC,*) INUM
WRITE(IOUQMC,*)
WRITE(6,*)
8008 FORMAT(' ',I8,': (',2I5,' ) --> (',2I5,' ) COEFF: ',F20.12)
CALL PHPCAL(PHP)
C
C intermediate normalization of the CI vector
C
CALL VNORM(VECT,1)
CALL ECORRC(NDET2,VECT,1,ECORR)
IF (LTOTAL) THEN
WRITE(6,*) ' WARNING : the HF energy is counted twice, '
$ ,'you gave TOTALE as option'
END IF
C
WRITE(IOUQMC,8009) EHF,ECORR,EHF+ECORR,PHP
8009 FORMAT(' Hartree-Fock Energy: ',/,F20.12,/
$ ,' Correlation Energy by the selected determinants: ',/,F20
$ .12,/,' Total Energy: ',/,F20.12,/,' /: '
$ ,/,F20.12,/)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
WRITE(6,*)
WRITE(6,*) ' THE REFERENCE '
WRITE(6,*)
$ ' ========================================================= '
WRITE(6,*) ' ORBITALS:'
CALL PFUNC(CI,NOCC)
IF (LDETAIL) THEN
WRITE(6,*)
WRITE(6,*) ' EXPANDED ORBITALS:'
DO IORB=1,NOCC
CALL EXPNND(CI(1,IORB),OWBUF,IWBUF,XNBUF,IPCOUNT)
WRITE(6,9901) IORB,'alpha spin',(OWBUF(IPRIM),IPRIM=1,IPCOUNT)
END DO
DO IORB=1,NOCC
CALL EXPNND(CI(1,IORB),OWBUF,IWBUF,XNBUF,IPCOUNT)
WRITE(6,9901) IORB,'beta spin ',(OWBUF(IPRIM),IPRIM=1,IPCOUNT)
END DO
END IF
WRITE(6,*)
INUM=0
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GT.THRPRI) THEN
INUM=INUM+1
WRITE(IOUQMC,9000) INUM,VECT(IDET)
WRITE(IINQMC,8111) INUM,INUM+NJASIM,IZERO,VECT(IDET)
9000 FORMAT(' Determinant ',I5,' Weight and coefficients ',/,F20.12)
C
WRITE(6,*) ' WRITING DETERMINANT ',IDET,' ON FILE ... '
8111 FORMAT('Determinant ',I4,' Weight and coefficients ',/,
- 2I4,F20.12)
I=ID0(1,IDET)
J=ID0(2,IDET)
K=ID0(3,IDET)
L=ID0(4,IDET)
LI=I.GE.0
LJ=J.GE.0
LK=K.GE.0
LL=L.GE.0
I=ABS(I)
J=ABS(J)
K=ABS(K)
L=ABS(L)
DO II=1,NOCC
IVALPH(II)=II
IVBETA(II)=II
END DO
C
IF (J.EQ.0) THEN
C for the reference, we do nothing
IF (I.NE.0) THEN
C the single is alpha or beta?
IF (LI) THEN
C alpha
IVALPH(I)=K
ELSE
C beta
IVBETA(I)=K
END IF
END IF
ELSE
C true double excitation
IF (LI) THEN
IF (LK) THEN
C i -> k
IVALPH(I)=K
ELSE
C i -> l
IVALPH(I)=L
END IF
ELSE
IF (LK) THEN
C I -> L
IVBETA(I)=L
ELSE
C I -> K
IVBETA(I)=K
END IF
END IF
C
IF (LJ) THEN
IF (LL) THEN
C j -> l
IVALPH(J)=L
ELSE
C j -> k
IVALPH(J)=K
END IF
ELSE
IF (LL) THEN
C J -> K
IVBETA(J)=K
ELSE
C J -> L
IVBETA(J)=L
END IF
END IF
END IF
C
DO IORB=1,NOCC
IF (LDETAIL) THEN
CALL EXPNND(CI(1,IVALPH(IORB)),OWBUF,IWBUF,XNBUF,IPCOUNT)
WRITE(IOUQMC,9901) IORB,'alpha spin',(OWBUF(IPRIM)
$ ,IPRIM=1,IPCOUNT)
WRITE(IINQMC,8112) IORB,'alpha spin',(OWBUF(IPRIM)
$ ,IPRIM=1,IPCOUNT)
ELSE
WRITE(IOUQMC,9901) IORB,'alpha spin',(CI(IALPH,IVALPH(IORB))
$ ,IALPH=1,NBAS)
END IF
END DO
DO IORB=1,NOCC
IF (LDETAIL) THEN
CALL EXPNND(CI(1,IVBETA(IORB)),OWBUF,IWBUF,XNBUF,IPCOUNT)
WRITE(IOUQMC,9901) IORB,'beta spin',(OWBUF(IPRIM)
$ ,IPRIM=1,IPCOUNT)
WRITE(IINQMC,8112) IORB,'beta spin',(OWBUF(IPRIM)
$ ,IPRIM=1,IPCOUNT)
ELSE
WRITE(IOUQMC,9901) IORB,'beta spin ',(CI(IALPH,IVBETA(IORB))
$ ,IALPH=1,NBAS)
END IF
END DO
END IF
END DO
9901 FORMAT(' Molecular orbital No ',I3,' ',A,/,3(F20.12))
8112 FORMAT(' Molecular orbital No ',I3,' ',A,/,3(F23.17))
CLOSE(IOUQMC)
CLOSE(IINQMC)
C
C exit with intermediate normalization
C regain the correct CI vector
C
REWIND(66)
WRITE(66) (VECT(IDET),IDET=1,NDET2)
CLOSE (66,STATUS='DELETE')
CALL VNORM(VECT,1)
C
RETURN
END
C
SUBROUTINE EXPNND(CI,OWBUF,IWBUF,XNBUF,IPCOUNT)
INCLUDE 'param.h'
DIMENSION CI(*),IWBUF(IPCOUNT),XNBUF(IPCOUNT),OWBUF(IPCOUNT)
C
DO I=1,IPCOUNT
OWBUF(I)=CI(IWBUF(I))*XNBUF(I)
END DO
RETURN
END
C
SUBROUTINE NORM_PRIM(EXPON,LVAL,MVAL,FACTOR)
INCLUDE 'param.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
C
C here we normalize a primitive Gaussian function
C
C sqrt[
C l-dependent:
C 2^l*(2a)^(l+3/2)/(pi^3/2 (2l-1)!!)
C m-dependent:
C [(l-|m|)!/(l+|m|)!] * (2-delta_m0)
C ]
C
PI=2.0D0*ACOS(0.D0)
XVAL=DBLE(LVAL)
PIF=FACC(LVAL+1)*(PI**1.5D0)
CD WRITE(6,*) ' FACC, PI ',FACC(LVAL+1),PI
PIF=(2.D0**XVAL)/PIF
CCC=(2.D0*EXPON)**(XVAL+1.5D0)
XMVAL=FAC(LVAL-ABS(MVAL)+1)/FAC(LVAL+ABS(MVAL)+1)
IF (MVAL.NE.0) XMVAL=XMVAL*2.D0
FACTOR=SQRT(PIF*CCC*XMVAL)
CD WRITE(6,*) ' NORM_PRIM: L,M,EXPON,XMVAL,FACTOR ',LVAL,MVAL,EXPON
CD $ ,XMVAL,FACTOR
RETURN
END
C
SUBROUTINE NORMBF(NSHLF,IPST)
INCLUDE 'param.h'
COMMON /BAS/ EXX(NPRIMX),COEFF(NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX)
C.. INCLUDE 'common_basis.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
C the (2l+1)!! and the (l+|m|)!
C
C we normalize the functions x^l \sum_i c_i exp{-a_i * (r^2))} to unity
C this gives as factor:
C
C sqrt[(\pi^{3/2}*(2l-1)!! / 2^l) * \sum_{ij} c_i c_j / ((a_i + a_j)^(l+3/2))]
C
C in general this will be multiplied by
C
C sqrt[ (l+|m|)! / ((2-\delta_{m0})*(l-|m|)! ) ], a factor of 1 for m=0
C
C this is the prefactor for the solid harmonics
C
C
C well, we normalize here primitives to 1 and contractions modulo the
c individual norm of the primitives
C
XNRM=0.D0
C 0: s, 1: p, ...
LVAL=IL(NSHLF)
NPRIMM=NPRIM(NSHLF)
EPS=1.D-9
PI=2.0D0*ACOS(0.D0)
XVAL=DBLE(LVAL)
LVAL=LVAL+1
PIF=FACC(LVAL)*(PI**1.5D0)
PIF=(2.D0**XVAL)/PIF
CD WRITE(6,*) 'NORMBF',LVAL,IPST,NPRIM,EXX(IPST),FACC(LVAL)
C
IF (NPRIMM.EQ.1) THEN
CD CCC=(2.D0*EXX(IPST))**(XVAL+1.5D0)
CD COEFF(IPST)=SQRT(PIF*CCC)
COEFF(IPST)=1.D0
CD WRITE(6,*) ' a) LVAL,COEFF,EXP',IPST,LVAL-1,COEFF(IPST),EXX(IPST)
ELSE
CCC=0.D0
DO IP=IPST,IPST+NPRIMM-1
CIP=COEFF(IP)
DIP=SQRT((2.D0*EXX(IP))**(XVAL+1.5D0))
DO JP=IPST,IPST+NPRIMM-1
EXXX=1.D0/(EXX(IP)+EXX(JP))
CJP=COEFF(JP)
DJP=SQRT((2.D0*EXX(JP))**(XVAL+1.5D0))
CCC=CCC+CIP*CJP*DIP*DJP*(EXXX**(XVAL+1.5D0))
END DO
END DO
DO IP=IPST,IPST+NPRIMM-1
COEFF(IP)=COEFF(IP)/SQRT(CCC)
CD WRITE(6,*) ' b) LVAL,COEFF,EXP',IP,LVAL-1,COEFF(IP),EXX(IP)
END DO
END IF
RETURN
END
C
SUBROUTINE FFCAL
INCLUDE 'param.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
C..DELCD
C
C the (2l-1)!! and the (l+|m|)!
C first the (2l-1)!!
C
FACC(1)=1.D0
DO L=2,NLMAX
FACC(L)=FACC(L-1)*DBLE(L+L-3)
END DO
C
FAC(1)=1.D0
FAC(2)=1.D0
DO I=3,NLMAX+NLMAX
XMLT=DBLE(I-1)
FAC(I)=XMLT*FAC(I-1)
END DO
C
DO L=1,NLMAX
WRITE(6,*) ' L, FAC(L), FACC(L) ',L-1,FAC(L),FACC(L)
END DO
DO L=1+NLMAX,NLMAX+NLMAX
WRITE(6,*) ' L, FAC(L) ',L-1,FAC(L)
END DO
C
RETURN
END
C
SUBROUTINE FREEZE
INCLUDE 'param.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CFREEZE/ IORBFZ(NBASM),IORBMP(NBASM)
C.. INCLUDE 'common_freeze.h'
CHARACTER*3 CPF,CPFF
CPF =' | '
CPFF=' V '
C
C here we are before reading the integrals, but after construction and
C transformation of the Fock matrix, so we rearrange F,NOCC,NBAS, and
c construct the mapping table
C
ISHI=0
DO I=1,NBAS
IF (IORBFZ(I).EQ.2) THEN
IORBMP(I)=I-ISHI
ELSE
ISHI=ISHI+1
IF (IORBFZ(I).EQ.1) THEN
IORBMP(I)=-1
ELSE IF (IORBFZ(I).EQ.3) THEN
IORBMP(I)=0
END IF
END IF
END DO
C
WRITE(6,*)
WRITE(6,*) ' GENERATING NEW INDICES:'
WRITE(6,*)
C
WRITE(6,*)
WRITE(6,*) ' THE INDEX REDUCTION TABLE:'
II=0
DO I=1,NBAS,18
WRITE(6,'(1H|,18(I3,1H|))') (INDX,INDX=I,MIN(I+17,NBAS))
WRITE(6,'(1H|,18(A3,1H|))') (CPF,INDX=I,MIN(I+17,NBAS))
WRITE(6,'(1H|,18(A3,1H|))') (CPFF,INDX=I,MIN(I+17,NBAS))
WRITE(6,'(1H|,18(I3,1H|))') (IORBMP(INDX),INDX=I,MIN(I+17,NBAS))
WRITE(6,*)
END DO
C subtract the HONE of the core from EN
ENO=EN
DO I=1,NOCC
IF (IORBMP(I).LT.0) THEN
EN=EN+2.D0*HONE(I,I)
END IF
END DO
C
C reduce the Fock matrix, as well HONE and ORBEN
C
DO I=1,NBAS
INEW=IORBMP(I)
IF (INEW.GT.0) THEN
ORBEN(IRED)=ORBEN(I)
DO J=1,NBAS
JNEW=IORBMP(J)
IF (JNEW.GT.0) THEN
HONE(INEW,JNEW)=HONE(I,J)
F(INEW,JNEW) =F(I,J)
END IF
END DO
END IF
END DO
C
C generate new NOCC etc
C
NOCCN=0
DO I=1,NOCC
IF (IORBFZ(I).EQ.1) NOCCN=NOCCN+1
END DO
NVIRTN=0
DO I=NOCC,NBAS
IF (IORBFZ(I).EQ.3) NVIRTN=NVIRTN+1
END DO
NBSOLD=NBAS
NBASN=NBAS-NOCCN-NVIRTN
NOCCN=NOCC-NOCCN
NVIRTN=NBASN-NOCCN
C
NOCC =NOCCN
NVIRT =NVIRTN
NBAS =NBASN
C
WRITE(6,*) ' NEW DIMENSIONS '
WRITE(6,*) ' NBAS = ',NBAS ,' NOCC = ',NOCC ,' NVIRT = ',NVIRT
WRITE(6,*)
C
RETURN
END
C
C this routine we have to redo completely. It is much more simple to
C work in molecular orbitals.
C
C P_ij = sum_I c_I^2 \delta_ij \delta(i in occ)
C + \sum_I\sum_(J.ne.I) c_I c_J \delta(i in occ(I)) \delta(j in occ(J))
C
SUBROUTINE NATORB
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /VECTCO/ CI(NBASM,NBASM),IOCCS(NBASM),IOCC(NBASM)
C.. INCLUDE 'common_vectco.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
DIMENSION P(NBASM,NBASM),ORBNAT(NBASM,NBASM),FTMP(NBASM)
DIMENSION CDUM1(NBASM),CDUM2(NBASM),SAO(NBASM,NBASM)
LOGICAL LI,LJ,LA,LB,LIJ,LIA,LIB,LJA,LJB,LAB
C
C
IF (LFRZ) THEN
WRITE(6,*) ' NO NATURAL ORBITALS WHEN FRREZING/DELETING'
RETURN
END IF
C
C normalize the vector to one
CALL VNORM(VECT,2)
C
C what about frozen/deleted orbitals? Frozen orbitals have to be
C included in the determinants (verify as well in QMC part!!!)
C
C well, perhaps not, the occupation is always 2 ...
C that is for later .....
C
C in any case, if there is orbital freezing, the number of AOs is larger
C than the number of MOs, so there will be a real problem. That again is
C the same for the QMC part
C
C construction of the vector FTMP for the diagonal contribution, this is
C the diagonal of P
C
DO I=1,NBAS
IF (I.LE.NOCC) THEN
FTMP(I)=2.D0
ELSE
FTMP(I)=0.D0
END IF
END DO
NOV=NOCC+1
DO IDET=1,NDET2
INDI=ABS(ID0(1,IDET))
INDJ=ABS(ID0(2,IDET))
INDK=ABS(ID0(3,IDET))
INDL=ABS(ID0(4,IDET))
C do nothing for the reference
IF (INDI.NE.0) THEN
C single excitation
IF (INDJ.EQ.0) THEN
FTMP(INDJ)=FTMP(INDJ)-VECT(IDET)*VECT(IDET)
FTMP(INDL)=FTMP(INDL)+VECT(IDET)*VECT(IDET)
ELSE
C double excitation
GIJAB=VECT(IDET)*VECT(IDET)
FTMP(INDI)=FTMP(INDI)-GIJAB
FTMP(INDJ)=FTMP(INDJ)-GIJAB
FTMP(INDK)=FTMP(INDK)+GIJAB
FTMP(INDL)=FTMP(INDL)+GIJAB
END IF
END IF
END DO
C
WRITE(6,*)
WRITE(6,*) ' DIAGONAL OF P: '
WRITE(6,*)
WRITE(6,'(4(I4,F14.7))') (I,FTMP(I),I=1,NBAS)
XELEC=0.D0
DO I=1,NBAS
XELEC=XELEC+FTMP(I)
END DO
WRITE(6,*)
WRITE(6,*) ' Total number of electrons on the diagonal: ', XELEC
WRITE(6,*)
C
C construction of the correlated density matrix
C
C the diagonal
DO I=1,NBAS
DO J=1,I-1
P(I,J)=0.D0
P(J,I)=0.D0
END DO
P(I,I)=FTMP(I)
END DO
C
C the off-diagonal, look for determinants with one single difference
C
DO IDET=1,NDET2
VI=VECT(IDET)
I1=ID0(1,IDET)
I2=ID0(2,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
C here we skip the singles and the reference
IF (I2.NE.0) THEN
C
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
LIA=LI.EQV.LA
LIB=LI.EQV.LB
LJA=LJ.EQV.LA
LJB=LJ.EQV.LB
LAB=LA.EQV.LB
IF (LAB.NEQV.LIJ) STOP 'LOOP over IDET: ERROR in SPIN COUNTING'
I=ABS(I1)
J=ABS(I2)
K=ABS(I3)
L=ABS(I4)
C
C change 1 Index, same spin
C
C change first index
C
C loop over all occupied, includes JJ
C
DO II=1,NOCC
JJ=II
IF (I.NE.II) THEN
I1R=SIGN(II,I1)
I2R=I2
IF (I1R.NE.I2R) THEN
I3R=I3
I4R=I4
IVZ=1
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,I,II
9721 FORMAT('<',4I4,' P ',4I4,'>',F20.12,2I7,2I4)
P(I,II)=P(I,II)+VI*VJ
END IF
END IF
C
END IF
C
C change second index
C
IF (JJ.NE.J) THEN
I1R=I1
I2R=SIGN(JJ,I2)
IF (I2R.NE.I1R) THEN
I3R=I3
I4R=I4
IVZ=1
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,J,JJ
P(J,JJ)=P(J,JJ)+VI*VJ
END IF
END IF
END IF
END DO
C
C change third index
C
DO KK=NOV,NBAS
LL=KK
IF (KK.NE.K) THEN
I3R=SIGN(KK,I3)
I4R=I4
IF (I3R.NE.I4R) THEN
I1R=I1
I2R=I2
IVZ=1
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,K,KK
P(K,KK)=P(K,KK)+VI*VJ
END IF
END IF
END IF
C
C change fourth index
C
IF (LL.NE.L) THEN
I3R=I3
I4R=SIGN(LL,I4)
IF (I3R.NE.I4R) THEN
I1R=I1
I2R=I2
IVZ=1
CALL ODET(I1R,I2R,I3R,I4R,IVZ)
CALL LOKI(I1R,I2R,I3R,I4R,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,L,LL
P(L,LL)=P(L,LL)+VI*VJ
END IF
END IF
END IF
END DO
C
C end of the search for possible pairs
C
ELSE
C now the singles
IF (I1.NE.0) THEN
C change i
DO II=1,NOCC
IF (II.NE.I) THEN
I1R=SIGN(II,I1)
IVZ=1
CALL LOKI(I1R,IZERO,I3,IZERO,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,I,II
P(I,II)=P(I,II)+VI*VJ
END IF
END IF
END DO
C change k
DO KK=NOV,NBAS
IF (KK.NE.K) THEN
I3R=SIGN(KK,I3)
IVZ=1
CALL LOKI(I1,IZERO,I3R,IZERO,INDXR,IVZ)
IF (INDXR.LT.IDET) THEN
VJ=DBLE(2*IVZ)*VECT(INDXR)
C IF (ABS(VI*VJ).GT.1.D-6)
C - WRITE(6,9721) I1,I2,I3,I4,I1R,I2R,I3R,I4R,VI*VJ,IDET
C - ,IVZ*INDXR,K,KK
P(K,KK)=P(K,KK)+VI*VJ
END IF
END IF
END DO
END IF
END IF
C
C end of the loop over determinants
END DO
C
9910 FORMAT(I10,2E20.12,E24.12)
C
C complete the density matrix to be hermitian
C
DO I=1,NBAS
DO J=1,I-1
P(I,J)=P(I,J)+P(J,I)
P(J,I)=P(I,J)
END DO
END DO
C
IONE=1
CALL RS(NBASM,NBAS,P,FTMP,IONE,ORBNAT,CDUM1,CDUM2,IERR)
C
C the natural orbitals and the occupation numbers
C
WRITE(6,*)
WRITE(6,*) ' OCCUPATION NUMBERS: '
WRITE(6,*)
WRITE(6,'(4(I4,F14.7))') (NBAS-I+1,FTMP(I),I=NBAS,1,-1)
XELEC=0.D0
DO I=1,NBAS
XELEC=XELEC+FTMP(I)
END DO
WRITE(6,*)
WRITE(6,*) ' Total number of electrons : ', XELEC
WRITE(6,*)
C
C store the natural orbitals somewhere
C
C expand the natural orbitals in atomic orbitals
C
DO IORB=1,NBAS
DO IVEC=1,NBAS
CDUM1(IVEC)=ORBNAT(IVEC,IORB)
END DO
DO IALPH=1,NBAS
SUM=0.D0
DO IVEC=1,NBAS
SUM=SUM+CI(IALPH,IVEC)*CDUM1(IVEC)
END DO
ORBNAT(IALPH,IORB)=SUM
END DO
END DO
IUNITX=31
WRITE(6,*) ' WRITING VECTOR TO FILE '
OPEN(UNIT=IUNITX,FILE='VECTOR.NATORB',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
DO J=1,NOCC
WRITE(IUNITX,'(4E20.12)') (ORBNAT(K,NBAS+1-J),K=1,NBAS)
WRITE(IUNITX,*)
END DO
WRITE(IUNITX,*)
DO J=1+NOCC,NBAS
WRITE(IUNITX,'(4E20.12)') (ORBNAT(K,NBAS+1-J),K=1,NBAS)
WRITE(IUNITX,*)
END DO
WRITE(IUNITX,'(30I2)') (IOCC(I),I=1,NBAS)
WRITE(IUNITX,'(30I2)') (IOCCS(I),I=1,NBAS)
WRITE(IUNITX,*)
WRITE(IUNITX,*) '# OCCUPATION NUMBERS OF THE NATURAL ORBITALS'
WRITE(IUNITX,'(4(F14.7))') (NBAS-I+1,FTMP(I),I=NBAS,1,-1)
CLOSE(IUNITX)
C
C renormalize the CI vector to intermediate normalization
C
CALL VNORM(VECT,1)
RETURN
END
C
SUBROUTINE RDMAT(NAME,ARRAY)
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
DIMENSION ARRAY(NBASM,NBASM)
CHARACTER*7 NAME
C
DO I=1,NBAS
DO J=1,NBAS
ARRAY(I,J)=0.D0
END DO
END DO
C
IUNITR=31
OPEN(UNIT=IUNITR,FILE=NAME,STATUS='OLD',FORM='FORMATTED',ERR=8101)
100 CONTINUE
READ(IUNITR,*,IOSTAT=KK) I,J,XDUM
IF (KK.NE.0) GO TO 101
ARRAY(I,J)=XDUM
ARRAY(J,I)=XDUM
GO TO 100
101 CONTINUE
CLOSE(IUNITR)
RETURN
8101 CONTINUE
WRITE(6,*) ' ERROR WHILE OPENING FILE <',NAME,'>!! ERROR EXIT'
STOP ' ERROR IN RDMAT'
END
C
SUBROUTINE APPROX(IMODE)
C
C approximative CISD:
C
C CI: diagonal approximation and individual 2X2 dressing
C ACPF,AQCC,AQCC-V: diagonal approximation
C CEPA-0: nothing since Epstein-Nesbet already calculated
C CEPA-2, CEPA-3, SCSC: direct solution of 2X2 linear subsystems
C
C IMODE=11: indivually dressed CI matrix
C IMODE=12: instead of H_ii we use F_ii+F_jj-F_aa-F_bb
C
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
CHARACTER*6 CHEXT
C
WRITE(6,*)
WRITE(6,*) ' Approximations to the CI/CEPA procedure'
WRITE(6,*)
C
IF (IMODE.EQ.1) THEN
CHEXT='CISD '
WRITE(6,*) ' 2X2 dressed CEPA matrices, diagonal approximation '
ELSE IF (IMODE.EQ.2) THEN
WRITE(6,*) ' CEPA-0 is in fact Epstein-Nesbet '
CHEXT= 'CEPA-0'
ELSE IF (IMODE.EQ.3) THEN
CHEXT= 'CEPA-2'
WRITE(6,*) ' 2X2 dressed CEPA matrices '
ELSE IF (IMODE.EQ.4) THEN
CHEXT= 'CEPA-3'
WRITE(6,*) ' 2X2 dressed CEPA matrices '
ELSE IF (IMODE.EQ.5) THEN
CHEXT= '(SC)^2'
WRITE(6,*) ' 2X2 dressed CEPA matrices '
ELSE IF (IMODE.EQ.7) THEN
CHEXT= 'ACPF '
WRITE(6,*) ' diagonal approximation through 2X2 dressed CEPA'
ELSE IF (IMODE.EQ.9) THEN
CHEXT= 'AQCC '
WRITE(6,*) ' diagonal approximation through 2X2 dressed CEPA'
ELSE IF (IMODE.EQ.10) THEN
CHEXT= 'AQCC-V'
WRITE(6,*) ' diagonal approximation through 2X2 dressed CEPA'
ELSE IF (IMODE.EQ.11) THEN
CHEXT='CISD-2'
WRITE(6,*) ' 2X2 individually dressed CI matrices '
ELSE IF (IMODE.EQ.12) THEN
CHEXT= 'MP2EGO'
WRITE(6,*) ' diagonal approximation through 2X2 dressed CEPA'
ELSE
WRITE(6,*) ' no approximation available '
RETURN
END IF
WRITE(6,*) ' --- ',CHEXT, ' --- ',CHEXT, ' --- ',CHEXT, ' --- '
WRITE(6,*)
C
C save HVECT on a file for CEPA-2, CEPA-3, and SCSC, we'll use it as dummy array for
C dressings
C
OPEN(UNIT=44,FILE='HVECT.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED'
$ )
WRITE(44) (HVECT(I),I=1,NDIM)
CLOSE(44)
WRITE(6,*) ' max number of iterations: ',ITLCCD
WRITE(6,*) ' convergency: ',TOLCI
WRITE(6,*) ' NDIM = ',NDIM
WRITE(6,*)
C
C starting vector for the procedure is the MP2 vector -> array VECT
ITER=10
CALL MP2VEC
CALL EVASOL(ITER,ERR,VECT,ECORR)
WRITE(6,*) ' The MP2 correlation energy ',ECORR
WRITE(6,*)
C
C for the individual correlation energies e_I and coefficients c_I we
C solve directly, without iterations:
IF (IMODE.EQ.11.OR.IMODE.EQ.12) THEN
ECD=0.D0
IF (IMODE.EQ.12) THEN
DO IDET=1,NDIM
IF (ID0(2,IDET).NE.0) THEN
c$$$ ECORR=0.D0
C here we use only the MP2 denominator
INDI=ABS(ID0(1,IDET))
INDJ=ABS(ID0(2,IDET))
INDA=ABS(ID0(3,IDET))
INDB=ABS(ID0(4,IDET))
HII=-ORBEN(INDI)-ORBEN(INDJ)+ORBEN(INDA)+ORBEN(INDB)
HOI=BVECT(IDET)
C
EI=HII-SQRT(HII*HII+4.D0*HOI*HOI)
EI=EI*0.5D0
ECD=ECD+EI
C WRITE(6,9113) INDI,INDJ,INDA,INDB,HOI,HII,EI
9113 FORMAT(2I4,' -> ',2I4,': ',3E20.12)
VOLD=VECT(IDET)
IF (ABS(HOI).GT.1.D-10) VECT(IDET)=EI/HOI
END IF
END DO
ELSE
DO IDET=1,NDIM
IF (ID0(2,IDET).NE.0) THEN
c$$$ ECORR=0.D0
C here we use only the MP2 denominator
HII=DIAG(IDET)
HOI=BVECT(IDET)
C
EI=HII-SQRT(HII*HII+4.D0*HOI*HOI)
EI=EI*0.5D0
ECD=ECD+EI
C WRITE(6,9113) ABS(ID0(1,IDET)),ABS(ID0(2,IDET)),ABS(ID0(3,IDET
C $ )),ABS(ID0(4,IDET)),HOI,HII,EI
VOLD=VECT(IDET)
IF (ABS(HOI).GT.1.D-10) VECT(IDET)=EI/HOI
END IF
END DO
END IF
C
WRITE(6,*) ' Correlation energy as direct sum: ',ECD
ELSE
ITER=0
C here starts the loop over the iterations
100 CONTINUE
C
C initialize the dummy array HVECT
C
C we calculate the dressing from the CI-vector and the diagonal
WRITE(6,*) ' dressing, ITER= ',ITER
C IMODE=11 or 12: individual dressing by -HOI*c_I = -E_I
DO IDET=1,NDIM
HVECT(IDET)=0.D0
END DO
CALL EPVL(ECORR,VECT,HVECT,IMODE)
C we dressed the singles as well, but this has no effect here since the
C updates are calculated for double excitations only
C
C now the new coefficients as C_I=-H_0I/(H_II+Delta_I)
C new coefficients
C
DO IDET=1,NDIM
C
C double excitation only
IF (ID0(2,IDET).NE.0) THEN
C the matrix elements of the 2X2 matrix
HOI=BVECT(IDET)
C in HVECT is only the dressing
HII=DIAG(IDET)+HVECT(IDET)
VOLD=VECT(IDET)
IF (ABS(HOI).GT.1.D-10) VECT(IDET)=-HOI/HII
c$$$ IF (ABS(HOI).GT.1.D-10) WRITE(6,9901) IDET,HOI,DIAG(IDET)
c$$$ $ ,HVECT(IDET),VOLD,VECT(IDET)
9901 FORMAT(' IDET= ',I5,' HOI = ',E14.6,', Hii = ',E14.6
$ ,' Delta_I =',F12.6,' Vold = ',F12.6,' Vnew = ',F12.6)
END IF
END DO
C
C calculate the correlation energy for the new coefficients
C
CALL EVASOL(ITER,ERR,VECT,ECORR)
WRITE(6,9946) ITER,ECORR,ERR
9946 FORMAT(' ITER: ',I6,' ECORR: ',F20.12,' CHANGE: ',E12.2)
C
ITER=ITER+1
IF (ERR.GT.TOLCI.AND.ITER.LE.ITLCCD) GO TO 100
END IF
C
C we converged, or used all iterations
CALL ECORRC(NDIM,VECT,5,EDUM)
WRITE(6,9124) CHEXT,EDUM
9124 FORMAT(' ',A6,' - ENERGY : ',F20.12,' (approximated)',/,' '
$ ,55('='),//)
C
C and we may calculate the third-order expression with the coefficients
IF (LEN3) THEN
CALL HAMDD(VECT,HVECT)
EEN3=0.D0
DO IDET=1,NDET2
EEN3=EEN3+VECT(IDET)*HVECT(IDET)
END DO
EEN3=EEN3+EDUM
IF (LTOTAL) THEN
WRITE(6,9125) CHEXT,EEN3+EHF
ELSE
WRITE(6,9125) CHEXT,EEN3
END IF
9125 FORMAT(' ',A6,' - ENERGY : ',F20.12
$ ,' (approximated, 3rd order)',/,' ',55('='),//)
END IF
C
C normalize the vector to length 1
CALL VNORM(VECT,2)
C
WRITE(6,*)
WRITE(6,*) ' THE RESULT OF OUR EXERCISE AS normalized COEFFICIENTS
$: '
C folded 1 (fixf $Revision: 1.3 $)
WRITE(6,*)
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GE.THRPRI)
- WRITE(6,'(I7,I8,3I5,F20.12)') IDET,(ID0(J,IDET),J=1,4)
$ ,VECT(IDET)
END DO
C
C QMC output
IF (LQMC) CALL OUTQMC(CHEXT)
C
C intermediate normalization - well, the vector is never used anymore
C
CALL VNORM(VECT,1)
C
C restore HVECT in memory
OPEN(UNIT=44,FILE='HVECT.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED'
$ )
READ(44) (HVECT(I),I=1,NDIM)
CLOSE(44,STATUS='DELETE')
C
RETURN
END
C
SUBROUTINE PHPCAL(PHP)
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
C
C we calculate
C
WRITE(6,*) ' we calculate .... '
DO IDET=1,NDET2
HVECT(IDET)=0.D0
END DO
CALL HCALC(VECT,HVECT)
PHP=0.D0
XNRM=0.D0
DO IDET=1,NDET2
PHP=PHP+VECT(IDET)*HVECT(IDET)
XNRM=XNRM+VECT(IDET)*VECT(IDET)
END DO
C
PHP=EHF+PHP/XNRM
ECORR=PHP-EHF
WRITE(6,*)
WRITE(6,*) ' / = ',PHP
WRITE(6,*) ' was = ',XNRM
WRITE(6,*)
WRITE(6,*) ' Hartree-Fock energy = ',EHF
WRITE(6,*) ' Correlation energy = ',ECORR
WRITE(6,*)
RETURN
END
C
SUBROUTINE HPSORT(N,H0,IH0)
INCLUDE 'param.h'
DIMENSION H0(N)
INTEGER IH0(4,N)
LOGICAL LLOW
C
C SORT BY IH0
C
IF (N.LT.2) RETURN
L=N/2+1
IR=N
10 CONTINUE
IF (L.GT.1) THEN
L=L-1
IRA1=IH0(1,L)
IRA2=IH0(2,L)
IRA3=IH0(3,L)
IRA4=IH0(4,L)
RA5=H0(L)
ELSE
IRA1=IH0(1,IR)
IRA2=IH0(2,IR)
IRA3=IH0(3,IR)
IRA4=IH0(4,IR)
RA5=H0(IR)
IH0(1,IR)=IH0(1,1)
IH0(2,IR)=IH0(2,1)
IH0(3,IR)=IH0(3,1)
IH0(4,IR)=IH0(4,1)
H0(IR)=H0(1)
IR=IR-1
IF (IR.EQ.1) THEN
IH0(1,1)=IRA1
IH0(2,1)=IRA2
IH0(3,1)=IRA3
IH0(4,1)=IRA4
H0(1)=RA5
RETURN
END IF
END IF
I=L
J=L+L
20 CONTINUE
IF (J.LE.IR) THEN
IF (J.LT.IR) THEN
C
C we have to measure ...
C
IF (IH0(1,J).LT.IH0(1,J+1)) THEN
J=J+1
ELSE IF (IH0(1,J).EQ.IH0(1,J+1)) THEN
IF (IH0(2,J).LT.IH0(2,J+1)) THEN
J=J+1
ELSE IF (IH0(2,J).EQ.IH0(2,J+1)) THEN
IF (IH0(3,J).LT.IH0(3,J+1)) THEN
J=J+1
ELSE IF (IH0(3,J).EQ.IH0(3,J+1)) THEN
IF (IH0(4,J).LT.IH0(4,J+1)) THEN
J=J+1
ELSE IF (IH0(4,J).EQ.IH0(4,J+1)) THEN
STOP ' J+1: 4 equal indices '
END IF
END IF
END IF
END IF
END IF
C
LLOW=.FALSE.
IF (IRA1.LT.IH0(1,J)) THEN
LLOW=.TRUE.
ELSE IF (IRA1.EQ.IH0(1,J)) THEN
IF (IRA2.LT.IH0(2,J)) THEN
LLOW=.TRUE.
ELSE IF (IRA2.EQ.IH0(2,J)) THEN
IF (IRA3.LT.IH0(3,J)) THEN
LLOW=.TRUE.
ELSE IF (IRA3.EQ.IH0(3,J)) THEN
IF (IRA4.LT.IH0(4,J)) THEN
LLOW=.TRUE.
ELSE IF (IRA4.EQ.IH0(4,J)) THEN
STOP ' 4 equal indices '
END IF
END IF
END IF
END IF
IF (LLOW) THEN
IH0(1,I)=IH0(1,J)
IH0(2,I)=IH0(2,J)
IH0(3,I)=IH0(3,J)
IH0(4,I)=IH0(4,J)
H0(I)=H0(J)
I=J
J=J+J
ELSE
J=IR+1
END IF
GOTO 20
END IF
IH0(1,I)=IRA1
IH0(2,I)=IRA2
IH0(3,I)=IRA3
IH0(4,I)=IRA4
H0(I)=RA5
GOTO 10
C
200 CONTINUE
C
RETURN
END
C
SUBROUTINE CALMP3
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
LOGICAL LI,LJ,LA,LB,LIJ,LIA,LIB,LJA,LJB,LAB
C
C third-order Moeller-Plesset via determinants
C we need only the doubles
C
C we need the formula
C sum_IJ <0|V|I>/ /
C - <0|V|0> sum_I (<0|V|I>/)^2
C
C V is all but the diagonal Fock matrix
C
C we may write
C -<0|V|0> = -
C
C <0|H|I> is in BVECT(I)
C is in DIAG(I)
C
C we may store <0|V|I>/ in X(I) and calculate X (H-E_HF) X
C via HAMDD
C
C from this we have to subtract sum_I X(I) X(I) which is
C nothing else than E(2)
C
WRITE(6,*)
WRITE(6,*) ' Third-order Moeller-Plesset '
WRITE(6,*)
EMP0=0.D0
DO I=1,NOCC
EMP0=EMP0+ORBEN(I)
END DO
EMP0=2.D0*EMP0+EN
EMP1=EHF-EMP0
EMP2=0.D0
EMP2S=0.D0
EMP2T=0.D0
TERM2=0.D0
EMP3RR=0.D0
DO IDET=1,NDET2
VECT(IDET)=0.D0
HVECT(IDET)=0.D0
END DO
DO IDET=1,NDET2
I2=ID0(2,IDET)
C here we skip the singles and the reference
IF (I2.NE.0) THEN
I1=ID0(1,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
C
I=ABS(I1)
J=ABS(I2)
K=ABS(I3)
L=ABS(I4)
HII=ORBEN(K)+ORBEN(L)-ORBEN(I)-ORBEN(J)
HOI=BVECT(IDET)
HOIII=HOI/HII
VECT(IDET)=HOIII
TERM=HOIII*HOI
IF (LIJ) THEN
EMP2T=EMP2T-TERM
ELSE
EMP2S=EMP2S-TERM
END IF
EMP2=EMP2-TERM
TERM2=TERM2+HOIII*HOIII
END IF
END DO
C the B(3) term (for educational purpose only)
EB3=-EMP1*TERM2
C save the Fock matrix as we set the off-diagonal elements to zero
OPEN(UNIT=88,FILE='FOCK.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
WRITE(88) ((F(I,J),J=1,I),I=1,NBAS)
CLOSE(88)
DO I=1,NBAS
DO J=I+1,NBAS
F(I,J)=0.D0
F(J,I)=0.D0
END DO
END DO
CALL HAMDD(VECT,HVECT)
C restore the Fock matrix
OPEN(UNIT=88,FILE='FOCK.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
READ(88) ((F(I,J),J=1,I),I=1,NBAS)
CLOSE(88,STATUS='DELETE')
DO I=1,NBAS
DO J=1,I
F(J,I)=F(I,J)
END DO
END DO
EMP3=EMP2
DO IDET=1,NDET2
EMP3=EMP3+VECT(IDET)*HVECT(IDET)
END DO
EA3=EMP3-EB3
WRITE(6,9324) 'EHF ',EHF
WRITE(6,9324) 'MP0 ',EMP0
WRITE(6,9324) 'MP1 ',EMP1
WRITE(6,9324) 'MP2S ',EMP2T
WRITE(6,9324) 'MP2T ',EMP2S
WRITE(6,9324) 'MP2 ',EMP2
SCSMP2=1.2D0*EMP2S+1.D0/3.D0*EMP2T
WRITE(6,9324) 'SCSMP2',SCSMP2
WRITE(6,9324) 'A(3) ',EA3
WRITE(6,9324) 'B(3) ',EB3
WRITE(6,9324) 'MP3 ',EMP3
IF (LTOTAL) THEN
WRITE(6,9324) 'MP2+3 ',EMP3+EMP2+EHF
ELSE
WRITE(6,9324) 'MP2+3 ',EMP3+EMP2
END IF
9324 FORMAT(' ',A6,' - ENERGY : ',F20.12,/,' ',45('='),//)
RETURN
END
C
SUBROUTINE CALEN3
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
LOGICAL LI,LJ,LA,LB,LIJ,LIA,LIB,LJA,LJB,LAB
C
C third-order Epstein-Nesbet via determinants
C we need only the doubles
C
C we need the formula
C sum_IJ <0|V|I>/ /
C - <0|V|0> sum_I (<0|V|I>/)^2
C
C V is all but the diagonal Fock matrix
C
C we may write
C -<0|V|0> = -
C
C <0|H|I> is in BVECT(I)
C is in DIAG(I)
C
C we may store <0|V|I>/ in X(I) and calculate X (H-E_HF) X
C via HAMDD
C
C from this we have to subtract sum_I X(I) X(I)
C
C
C the only difference to CALMP3 is the construction of HII
C instead of ORBEN(I)+... we use DIAG(IDET)
C
WRITE(6,*)
WRITE(6,*) ' Third-order Epstein-Nesbet '
WRITE(6,*)
EEN0=EHF
EEN1=EHF-EEN0
EEN2=0.D0
EEN3RR=0.D0
DO IDET=1,NDET2
VECT(IDET) =0.D0
HVECT(IDET)=0.D0
END DO
DO IDET=1,NDET2
I2=ID0(2,IDET)
C here we skip the singles and the reference
IF (I2.NE.0) THEN
I1=ID0(1,IDET)
I3=ID0(3,IDET)
I4=ID0(4,IDET)
LI=I1.LT.0
LJ=I2.LT.0
LA=I3.LT.0
LB=I4.LT.0
LIJ=LI.EQV.LJ
C
I=ABS(I1)
J=ABS(I2)
K=ABS(I3)
L=ABS(I4)
HII=DIAG(IDET)
HOI=BVECT(IDET)
HOIII=HOI/HII
VECT(IDET)=HOIII
TERM=HOIII*HOI
EEN2=EEN2-TERM
END IF
END DO
C save the Fock matrix as we set the off-diagonal elements to zero
OPEN(UNIT=88,FILE='FOCK.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
WRITE(88) ((F(I,J),J=1,I),I=1,NBAS)
CLOSE(88)
DO I=1,NBAS
DO J=I+1,NBAS
F(I,J)=0.D0
F(J,I)=0.D0
END DO
END DO
CALL HAMDD(VECT,HVECT)
C restore the Fock matrix
OPEN(UNIT=88,FILE='FOCK.TMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
READ(88) ((F(I,J),J=1,I),I=1,NBAS)
CLOSE(88,STATUS='DELETE')
EEN3=EEN2
DO IDET=1,NDET2
EEN3=EEN3+VECT(IDET)*HVECT(IDET)
END DO
WRITE(6,9324) 'EHF ',EHF
WRITE(6,9324) 'EN0 ',EEN0
WRITE(6,9324) 'EN1 ',EEN1
WRITE(6,9324) 'EN2 ',EEN2
WRITE(6,9324) 'EN3 ',EEN3
IF (LTOTAL) THEN
WRITE(6,9324) 'E(2+3)',EEN3+EEN2+EHF
ELSE
WRITE(6,9324) 'E(2+3)',EEN3+EEN2
END IF
9324 FORMAT(' ',A6,' - ENERGY : ',F20.12,/,' ',45('='),//)
RETURN
END
C
SUBROUTINE READ53(IUNIT4)
INCLUDE 'param.h'
PARAMETER (NBULL=8000000)
C.. INCLUDE 'nbuldef.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /TWOI/ H0(NBULL),IH0(4,NBULL),ISTRTC(12+NBASM),IFINC(12
$ +NBASM),NUMINT
C.. INCLUDE 'common_twoi.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
COMMON /CFREEZE/ IORBFZ(NBASM),IORBMP(NBASM)
C.. INCLUDE 'common_freeze.h'
PARAMETER (ITMX=12,LBLKL=256)
COMMON /READBF/ HV(ITMX,LBLKL),ID(ITMX,LBLKL),JD(ITMX,LBLKL),
- KD(ITMX,LBLKL),LD(ITMX,LBLKL),IPS(ITMX)
C.. INCLUDE 'common_readbuf.h'
COMMON /WBUF/ HVAL(IWBULL),IIND(IWBULL),JIND(IWBULL),KIND(IWBULL),
- LIND(IWBULL),IPOS,IUNIT,IBLE
CHARACTER*5 FEXT(12)
CHARACTER*1 FFEXT(0:9)
DIMENSION ONEINT(NBASM,NBASM)
LOGICAL LF,LI,LJ,LA,LB,LEQ
DATA FEXT /'OOOO1','OOOV1','OVOV1','OOVV1','OVVV1','VVVV1',
- 'OOOO2','OOOV2','OVOV2','OOVV2','OVVV2','VVVV2'/
DATA FFEXT /'0','1','2','3','4','5','6','7','8','9'/
C
WRITE(6,*)
WRITE(6,*) ' WE READ THE INTEGRALS FROM FILE ',IUNIT4
WRITE(6,*)
C
C
C WE HAVE CLASSES (OO|OO), (OO|OV), (OV|OV), (OO|VV), (OV|VV), (VV|VV)
C OPEN FOR EACH CLASS A SEPARATE FILE
C
DO IFILE=1,12
OPEN(UNIT=IFILE+55,FILE=FEXT(IFILE),FORM='UNFORMATTED',STATUS='UN
$KNOWN')
C folded 1 (fixf $Revision: 1.3 $)
WRITE(6,*) ' OPENED UNIT ',IFILE+55,' AS FILE ',
- FEXT(IFILE)
IPS(IFILE)=0
ISTRTC(IFILE)=0
END DO
C
IF (LDELCU) THEN
IMODE=2
CALL WOPEN(IUNIT4,IMODE)
NUMINT=0
NJET=0
100 CONTINUE
CALL WREAD(LF)
DO I=1,IPOS
I1=IIND(I)
J1=JIND(I)
K1=KIND(I)
L1=LIND(I)
HHH=HVAL(I)
IF (I1.EQ.0.OR.J1.EQ.0.OR.K1.EQ.0.OR.L1.EQ.0) THEN
WRITE(6,*) ' WE REACHED THE ONE-ELECTRON SECTION '
GO TO 200
ELSE
C..FILE 'mapping.h'
C apply the mapping
I1R=IORBMP(I1)
J1R=IORBMP(J1)
K1R=IORBMP(K1)
L1R=IORBMP(L1)
IF (I1R.GT.0) THEN
IF (J1R.GT.0) THEN
IF (K1R.GT.0) THEN
IF (L1R.GT.0) THEN
C no frozen index
CALL HRANGE(I1R,J1R,K1R,L1R,HHH,NJET,HV,ID,JD,KD,LD
$ ,IPS,ITMX,LBLKL)
END IF
END IF
END IF
ELSE
C all 4 indices go to zero via the mapping -> effective nuclear charge
c EN
C in fact, our indices are -1 if frozen, not zero
IF (J1R.LT.0.AND.K1R.LT.0.AND.L1R.LT.0) THEN
IF ((I1.EQ.J1).AND.(K1.EQ.L1)) THEN
C (ii|ii)
IF (K1.EQ.I1) THEN
EN=EN+HHH
ELSE
C (ii|kk)
EN=EN+4.D0*HHH
END IF
ELSE
C
IF (I1.EQ.K1.AND.J1.EQ.L1) THEN
C (ij|ij), but not (ii|ii)
EN=EN-2.D0*HHH
END IF
END IF
END IF
END IF
C
C at least one index goes to zero
C
C (ij|ll), l in core, ij out of core
C
IF (I1R.GT.0.AND.J1R.GT.0.AND.K1R.LT.0.AND.L1R.LT.0.AND.K1.EQ
$ .L1) THEN
HONE(I1R,J1R)=HONE(I1R,J1R)+2.D0*HHH
IF (I1.NE.J1) THEN
HONE(J1,I1)=HONE(J1,I1)+2.D0*HHH
END IF
END IF
C
C (ll|ij), l in core, ij out of core
C
IF (K1R.GT.0.AND.L1R.GT.0.AND.I1R.LT.0.AND.J1R.LT.0.AND.I1.EQ
$ .J1) THEN
HONE(K1R,L1R)=HONE(K1R,L1R)+2.D0*HHH
IF (K1.NE.L1) THEN
HONE(L1R,K1R)=HONE(L1R,K1R)+2.D0*HHH
END IF
END IF
C
C (il|jl) l in core, ij out of core
C
IF (I1R.GT.0.AND.K1R.GT.0.AND.J1R.LT.0.AND.L1R.LT.0.AND.J1.EQ
$ .L1) THEN
HONE(I1R,K1R)=HONE(I1R,K1R)-HHH
IF (I1.NE.K1) THEN
HONE(K1R,I1R)=HONE(K1R,I1R)-HHH
END IF
END IF
C
C (li|lj) l in core, ij out of core
C
IF (J1R.GT.0.AND.L1R.GT.0.AND.I1R.LT.0.AND.K1R.LT.0.AND.I1.EQ
$ .K1) THEN
HONE(J1R,L1R)=HONE(J1R,L1R)-HHH
IF (J1.NE.L1) THEN
HONE(L1R,J1R)=HONE(L1R,J1R)-HHH
END IF
END IF
C
C (li|jl) l in core, ij out of core
C
IF (J1R.GT.0.AND.K1R.GT.0.AND.I1R.LT.0.AND.L1R.LT.0.AND.I1.EQ
$ .L1) THEN
HONE(J1R,K1R)=HONE(J1R,K1R)-HHH
IF (J1.NE.K1) THEN
HONE(K1R,J1R)=HONE(K1R,J1R)-HHH
END IF
END IF
C
C (il|lj) l in core, ij out of core
C
IF (I1R.GT.0.AND.L1R.GT.0.AND.J1R.LT.0.AND.K1R.LT.0.AND.J1.EQ
$ .K1) THEN
HONE(I1R,L1R)=HONE(I1R,L1R)-HHH
IF (I1.NE.L1) THEN
HONE(L1R,I1R)=HONE(L1R,I1R)-HHH
END IF
END IF
C
C.. INCLUDE 'mapping.h'
END IF
END DO
IF (.NOT.LF) GO TO 100
C
200 CONTINUE
C
CALL WCLOS(IMODE)
ELSE
OPEN(UNIT=IUNIT4,FILE='MOTWO_N5',STATUS='OLD',FORM='FORMATTED')
C we have the integrals formatted on file
C
NUMINT=0
NJET=0
101 CONTINUE
READ(IUNIT4,*,IOSTAT=KK) I1,J1,K1,L1,HHH
IF (KK.NE.0) THEN
WRITE(6,*) 'WE HAVE ',NUMINT+NJET
$ ,' INTEGRALS, BUT THE FILE ENDED '
LF=.TRUE.
END IF
IF (I1.EQ.0.OR.J1.EQ.0.OR.K1.EQ.0.OR.L1.EQ.0) THEN
WRITE(6,*) ' WE REACHED THE ONE-ELECTRON SECTION '
GO TO 201
ELSE
C apply the mapping
I1R=IORBMP(I1)
J1R=IORBMP(J1)
K1R=IORBMP(K1)
L1R=IORBMP(L1)
IF (I1R.GT.0) THEN
IF (J1R.GT.0) THEN
IF (K1R.GT.0) THEN
IF (L1R.GT.0) THEN
C no frozen index
CALL HRANGE(I1R,J1R,K1R,L1R,HHH,NJET,HV,ID,JD,KD,LD
$ ,IPS,ITMX,LBLKL)
END IF
END IF
END IF
ELSE
C all 4 indices go to zero via the mapping -> effective nuclear charge
c EN
C in fact, our indices are -1 if frozen, not zero
IF (J1R.LT.0.AND.K1R.LT.0.AND.L1R.LT.0) THEN
IF ((I1.EQ.J1).AND.(K1.EQ.L1)) THEN
C (ii|ii)
IF (K1.EQ.I1) THEN
EN=EN+HHH
ELSE
C (ii|kk)
EN=EN+4.D0*HHH
END IF
ELSE
C
IF (I1.EQ.K1.AND.J1.EQ.L1) THEN
C (ij|ij), but not (ii|ii)
EN=EN-2.D0*HHH
END IF
END IF
END IF
END IF
C
C at least one index goes to zero
C
C (ij|ll), l in core, ij out of core
C
IF (I1R.GT.0.AND.J1R.GT.0.AND.K1R.LT.0.AND.L1R.LT.0.AND.K1.EQ
$ .L1) THEN
HONE(I1R,J1R)=HONE(I1R,J1R)+2.D0*HHH
IF (I1.NE.J1) THEN
HONE(J1,I1)=HONE(J1,I1)+2.D0*HHH
END IF
END IF
C
C (ll|ij), l in core, ij out of core
C
IF (K1R.GT.0.AND.L1R.GT.0.AND.I1R.LT.0.AND.J1R.LT.0.AND.I1.EQ
$ .J1) THEN
HONE(K1R,L1R)=HONE(K1R,L1R)+2.D0*HHH
IF (K1.NE.L1) THEN
HONE(L1R,K1R)=HONE(L1R,K1R)+2.D0*HHH
END IF
END IF
C
C (il|jl) l in core, ij out of core
C
IF (I1R.GT.0.AND.K1R.GT.0.AND.J1R.LT.0.AND.L1R.LT.0.AND.J1.EQ
$ .L1) THEN
HONE(I1R,K1R)=HONE(I1R,K1R)-HHH
IF (I1.NE.K1) THEN
HONE(K1R,I1R)=HONE(K1R,I1R)-HHH
END IF
END IF
C
C (li|lj) l in core, ij out of core
C
IF (J1R.GT.0.AND.L1R.GT.0.AND.I1R.LT.0.AND.K1R.LT.0.AND.I1.EQ
$ .K1) THEN
HONE(J1R,L1R)=HONE(J1R,L1R)-HHH
IF (J1.NE.L1) THEN
HONE(L1R,J1R)=HONE(L1R,J1R)-HHH
END IF
END IF
C
C (li|jl) l in core, ij out of core
C
IF (J1R.GT.0.AND.K1R.GT.0.AND.I1R.LT.0.AND.L1R.LT.0.AND.I1.EQ
$ .L1) THEN
HONE(J1R,K1R)=HONE(J1R,K1R)-HHH
IF (J1.NE.K1) THEN
HONE(K1R,J1R)=HONE(K1R,J1R)-HHH
END IF
END IF
C
C (il|lj) l in core, ij out of core
C
IF (I1R.GT.0.AND.L1R.GT.0.AND.J1R.LT.0.AND.K1R.LT.0.AND.J1.EQ
$ .K1) THEN
HONE(I1R,L1R)=HONE(I1R,L1R)-HHH
IF (I1.NE.L1) THEN
HONE(L1R,I1R)=HONE(L1R,I1R)-HHH
END IF
END IF
C
C.. INCLUDE 'mapping.h'
END IF
IF (.NOT.LF) GO TO 101
C
201 CONTINUE
C
C close the IF (LDELCU)
END IF
C we read all integrals successfully
RATIO=DBLE(NUMINT)/DBLE(NUMINT+NJET)*100.D0
WRITE(6,9127) NUMINT+NJET,NUMINT,RATIO
9127 FORMAT(/,' READ ',I9,' INTEGRALS ',/,' KEPT ',I9,
- ' INTEGRALS (',F5.1,'%)',//)
C
DO ITYPE=1,12
IF (IPS(ITYPE).EQ.LBLKL) THEN
IPS(ITYPE)=0
WRITE(ITYPE+55) (ID(ITYPE,JJ1),JJ1=1,LBLKL),
- (JD(ITYPE,JJ2),JJ2=1,LBLKL),
- (KD(ITYPE,JJ3),JJ3=1,LBLKL),
- (LD(ITYPE,JJ4),JJ4=1,LBLKL),
- (HV(ITYPE,JJ5),JJ5=1,LBLKL)
END IF
ID(ITYPE,LBLKL)=-1
JD(ITYPE,LBLKL)=IPS(ITYPE)
WRITE(ITYPE+55) (ID(ITYPE,JJ1),JJ1=1,LBLKL),
- (JD(ITYPE,JJ2),JJ2=1,LBLKL),
- (KD(ITYPE,JJ3),JJ3=1,LBLKL),
- (LD(ITYPE,JJ4),JJ4=1,LBLKL),
- (HV(ITYPE,JJ5),JJ5=1,LBLKL)
REWIND(ITYPE+55)
END DO
C
C all integrals are on different files now, the files are rewound
C
C can we hold all integrals in core or do we have to switch to the
C out-of-core procedures?
C
C we leave just the integrals VVVV (ABCD) on disk
C
C we just close the VVVV2 file
ITYPE=12
CLOSE(ITYPE+55)
INTOT1=0
INTOT2=0
WRITE(6,8003)
8003 FORMAT(' NUMBER OF INTEGRALS IN THE DIFFERENT CLASSES:',/,
- ' TYPE N1 N2',/,
- ' (AABC) (ABCD)',/,
- ' ------------------------------')
DO ITYPE=1,6
IF (ITYPE.LE.5) THEN
INTOT1=INTOT1+ISTRTC(ITYPE)+ISTRTC(ITYPE+6)
ELSE
INTOT1=INTOT1+ISTRTC(ITYPE)
INTOT2=ISTRTC(ITYPE+6)
END IF
WRITE(6,9128) FEXT(ITYPE)(1:4),ISTRTC(ITYPE),ISTRTC(ITYPE+6)
END DO
INTOT=INTOT1+INTOT2
9128 FORMAT(3X,A4,I12,I12)
WRITE(6,*) ' ------------------------------'
WRITE(6,*)
C
IF (INTOT1.GT.NBULL) THEN
C remove the temporary files
DO I=1,12
OPEN(55,file=FEXT(I),status='old',form='unformatted')
CLOSE(55,status='delete')
END DO
STOP ' THERE ARE TOO MANY INTEGRALS TO BE HELD IN CORE'
END IF
C
WRITE(6,*) ' THE BIELECTRONIC INTEGRAL FILE WILL '
$ ,'BE SPLIT IN TWO PARTS'
WRITE(6,*) INTOT1,' INTEGRALS WILL BE IN CORE '
WRITE(6,*) INTOT2,' INTEGRALS REST ON DISK'
ITYPMX=11
C
C read and sort the integrals
C
IFINC(1)=ISTRTC(1)
ISTRTC(1)=1
WRITE(6,*) ' SEGMENT ',ITYPE,': STARTING AT:',
- ISTRTC(1),' ENDING AT:', IFINC(1)
DO ITYPE=2,ITYPMX
IFINC(ITYPE)=IFINC(ITYPE-1)+ISTRTC(ITYPE)
ISTRTC(ITYPE)=IFINC(ITYPE-1)+1
WRITE(6,*) ' SEGMENT ',ITYPE,': STARTING AT:',
- ISTRTC(ITYPE),' ENDING AT:', IFINC(ITYPE)
END DO
C
IPOINT=0
C in any case we read the first 11 segments
DO ITYPE=1,11
INUM=IFINC(ITYPE)-ISTRTC(ITYPE)+1
112 CONTINUE
READ(ITYPE+55) (ID(ITYPE,JJ1),JJ1=1,LBLKL),
- (JD(ITYPE,JJ2),JJ2=1,LBLKL),
- (KD(ITYPE,JJ3),JJ3=1,LBLKL),
- (LD(ITYPE,JJ4),JJ4=1,LBLKL),
- (HV(ITYPE,JJ5),JJ5=1,LBLKL)
IF (ID(ITYPE,LBLKL).EQ.-1) THEN
INUMR=JD(ITYPE,LBLKL)
ELSE
INUMR=LBLKL
END IF
DO IIINT=1,INUMR
IPOINT=IPOINT+1
H0(IPOINT)=HV(ITYPE,IIINT)
IH0(1,IPOINT)=ID(ITYPE,IIINT)
IH0(2,IPOINT)=JD(ITYPE,IIINT)
IH0(3,IPOINT)=KD(ITYPE,IIINT)
IH0(4,IPOINT)=LD(ITYPE,IIINT)
END DO
IF (ID(ITYPE,LBLKL).NE.-1) GO TO 112
IF (IPOINT.NE.IFINC(ITYPE)) THEN
WRITE(6,*) ITYPE,IPOINT,ISTRTC(ITYPE),IFINC(ITYPE)
STOP ' SOME ERROR IN READING INTEGRALS '
END IF
CLOSE(ITYPE+55,STATUS='DELETE')
C sort the area of integrals
IF (INUM.GT.0) THEN
WRITE(6,*) ' CHECKING ORDER OF INTEGRALS IN SEGMENT ',ITYPE,
- '; ',INUM,' INTEGRALS'
CALL INTSRT(IH0(1,ISTRTC(ITYPE)),H0(ISTRTC(ITYPE)),INUM)
END IF
C
END DO
C
RETURN
END
SUBROUTINE EN23S
INCLUDE 'param.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /NACT/ BVECT(NDETMX),DIAG(NDETMX),NDIM
C.. INCLUDE 'common_nact.h'
COMMON /CONSTA/ S2,SNCL
C.. INCLUDE 'common_consta.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
LOGICAL LI,LJ,LK,LL,LIJ,LKL
C
C we calculate the spin-adapted EN2 and EN3 energy on the fly
C
C first we determine VECT and EN2 and then we calculate EN3 as VECT*HVECT
C
C Spin projection for fabricating a pure singlet state
C
C we may have singlet, triplet and quintet contributions from
C the six determinants iAjB IajB iAbJ IaJb iBaJ bIjA
C
C 2 singlets; 3 triplets, one quintet
C
C the reference and iIaA are singlet
C
C iIaB and iAaJ are singlet or triplet
C singlet: aB+bA iJ+Ij
C triplet: aB-bA iJ-Ij
C
C for iAjB we construct the singlet with full interaction with 0
C and the singlet orthogonal to it
C
C there is only one quintet
WRITE(6,*)
WRITE(6,*) ' spin-adapted EN3 '
WRITE(6,*)
C a dummy sign
IVZ=1
DO IDET=1,NDET2
VECT(IDET)=0.D0
HVECT(IDET)=0.D0
END DO
DO IDET=1,NDET2
I=ID0(1,IDET)
J=ID0(2,IDET)
K=ID0(3,IDET)
L=ID0(4,IDET)
LI=I.GT.0
LJ=J.GT.0
LK=K.GT.0
LL=L.GT.0
I=ABS(I)
J=ABS(J)
K=ABS(K)
L=ABS(L)
IF (I.NE.0) THEN
C not the reference, but iIkL, iIKl, iIkK, iJkK or IjkK
IF (I.EQ.J) THEN
IF (K.EQ.L) THEN
VECT(IDET)=-BVECT(IDET)/DIAG(IDET)
ELSE
C iIkL
IF (LK) THEN
C find the corresponding kL
I1R=I
J1R=-I
K1R=-K
L1R=L
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
DENOM=DIAG(IDET)+HEXC(K,L)
TERM=-BVECT(IDET)/DENOM
VECT(IDET) =TERM
VECT(INDXR)=TERM
END IF
END IF
ELSE
IF (LI.AND.K.EQ.L) THEN
C find the corresponding IjkK
I1R=-I
J1R= J
K1R= K
L1R=-K
CALL LOKI(I1R,J1R,K1R,L1R,INDXR,IVZ)
DENOM=DIAG(IDET)+HEXC(I,J)
TERM=-BVECT(IDET)/DENOM
VECT(IDET) =TERM
VECT(INDXR)=TERM
END IF
END IF
IF (LI) THEN
IF (LJ) THEN
IF (LK) THEN
IF (LL) THEN
C we really have 4 different indices, otherwise one would have been
C negative
C
C IDET is ijab
C we look for IJAB
C iJaB
C iJAb
C IjaB
C IjAb
IDET1=IDET
I1R=-I
J1R=-J
K1R=-K
L1R=-L
CALL LOKI(I1R,J1R,K1R,L1R,IDET2,IVZ)
I1R=-I
J1R= J
K1R=-K
L1R= L
CALL LOKI(I1R,J1R,K1R,L1R,IDET3,IVZ)
I1R= I
J1R=-J
K1R= K
L1R=-L
CALL LOKI(I1R,J1R,K1R,L1R,IDET4,IVZ)
I1R=-I
J1R= J
K1R= K
L1R=-L
CALL LOKI(I1R,J1R,K1R,L1R,IDET5,IVZ)
I1R= I
J1R=-J
K1R=-K
L1R= L
CALL LOKI(I1R,J1R,K1R,L1R,IDET6,IVZ)
c$$$ WRITE(6,*) ' IDET1 : ',IDET1,(ID0(JJ,IDET1),JJ=1,4)
c$$$ WRITE(6,*) ' IDET2 : ',IDET2,(ID0(JJ,IDET2),JJ=1,4)
c$$$ WRITE(6,*) ' IDET3 : ',IDET3,(ID0(JJ,IDET3),JJ=1,4)
c$$$ WRITE(6,*) ' IDET4 : ',IDET4,(ID0(JJ,IDET4),JJ=1,4)
c$$$ WRITE(6,*) ' IDET5 : ',IDET5,(ID0(JJ,IDET5),JJ=1,4)
c$$$ WRITE(6,*) ' IDET6 : ',IDET6,(ID0(JJ,IDET6),JJ=1,4)
c$$$ WRITE(6,*)
EXAB=HEXC(K,L)
EXIJ=HEXC(I,J)
EXIA=HEXC(I,K)
EXIB=HEXC(I,L)
EXJA=HEXC(J,K)
EXJB=HEXC(J,L)
c$$$ H10=BVECT(IDET1)
H20=BVECT(IDET3)
H30=BVECT(IDET5)
H10=H20-H30
c$$$ WRITE(6,*) ' H10, H20, H30 =',H10,H20,H30,H10-H20+H30
EDEN=H10*H10+H20*H20+H30*H30
IF (EDEN.NE.0.D0) THEN
EDEN=S2*SQRT(EDEN)
E1=H10/EDEN
E2=H20/EDEN
E3=H30/EDEN
c$$$ WRITE(6,*) ' E1-3=',E1,E2,E3
FACTOR=E1*H10+E2*H20+E3*H30
DENOM=E1*E1*DIAG(IDET1)+E2*E2*DIAG(IDET3)+E3*E3*DIAG(IDET5)
- + 2.D0*E1*(E2*(EXJB + EXIA) - E3*(EXJA + EXIB))
$ + 2.D0*E2*E3*(EXAB+EXIJ)
TERM=-FACTOR/DENOM
VECT(IDET1)=E1*TERM
VECT(IDET2)=E1*TERM
VECT(IDET3)=E2*TERM
VECT(IDET4)=E2*TERM
VECT(IDET5)=E3*TERM
VECT(IDET6)=E3*TERM
END IF
END IF
END IF
END IF
END IF
END IF
END DO
C
C VECT is filled
CALL ECORRC(NDET2,VECT,5,EEN2)
calculate HVECT
CALL HAMDD(VECT,HVECT)
EEN3=EEN2
DO IDET=1,NDET2
EEN3=EEN3+VECT(IDET)*HVECT(IDET)
END DO
EEN0=EHF
EEN1=0.D0
WRITE(6,9324) 'EHF ',EHF
WRITE(6,9324) 'EN0 ',EEN0
WRITE(6,9324) 'EN1 ',EEN1
WRITE(6,9324) 'EN2 ',EEN2
WRITE(6,9324) 'EN3 ',EEN3
IF (LTOTAL) THEN
WRITE(6,9324) 'E(2+3)',EEN3+EEN2+EHF
ELSE
WRITE(6,9324) 'E(2+3)',EEN3+EEN2
END IF
9324 FORMAT(' ',A6,' - ENERGY : ',F20.12,/,' ',45('='),//)
RETURN
END
FUNCTION INVMAP(INDX)
INCLUDE 'param.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
COMMON /CFREEZE/ IORBFZ(NBASM),IORBMP(NBASM)
C.. INCLUDE 'common_freeze.h'
IF (LFRZ) THEN
DO I=1,NBSOLD
IF (IORBMP(I).EQ.INDX) INVMAP=I
END DO
ELSE
INVMAP=INDX
END IF
RETURN
END
FUNCTION XMATEL(I1,J1,IR1,IS1,K1,L1,IT1,IU1,NOCC,XMULT)
C maximally doubly excited
INCLUDE 'param.h'
COMMON /INTU/ HCOU(NBASM,NBASM),HEXC(NBASM,NBASM)
$ ,F(NBASM,NBASM),HONE(NBASM,NBASM),ORBEN(NBASM)
C.. INCLUDE 'common_intu.h'
COMMON /FLOW/ THRINT,THRPRI,TOLCI,TOLCCD,THRMP2,TRSEXY
$ ,INREAD(NBASM),IBOND1,IBOND2,ICUT,ICUTMN,ICUTMX,NITDAV,ITLCCD
$ ,IPRINT,LEPSN,LLCCD,LCEPA0,LCEPA2,LCEPA3,LSCSC,LCISD,LPERT
$ ,LXAV,LVECR1,LVECR2,LDELCU,LCIS,LCID,LACPF,LAQCC,LMP2C,LKUTZ
$ ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO,LCIMP,LMP2EG
$ ,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO,LCILOC,LRDET
$ ,LSCSMP,LPERLOC
LOGICAL LLCCD,LCEPA0,LCEPA3,LCEPA2,LSCSC,LCISD,LPERT,LEPSN,LXAV
$ ,LDELCU,LVECR1,LVECR2,LCIS,LCID,LACPF,LAQCC,LMP2C
$ ,LKUTZ,LAQCCV,LQMC,LDETAIL,LSELEC,LFRZ,LNATOR,LMP2CO
$ ,LCIMP,LMP2EG,LEN2C,LPHP,LMP3,LEN3,LEXSCI,LTOTAL,LRESTO
$ ,LCILOC,LRDET,LSCSMP,LPERLOC
C.. INCLUDE 'common_flow.h'
CHARACTER*8 PNAME
CHARACTER*1 CSIGN(-1:1)
DIMENSION ILEFT(4),IRIGHT(4)
DIMENSION ISPINL(4),ISPINR(4)
DIMENSION ITYPEL(4),ITYPER(4)
DIMENSION ILEFT2(4),IRIGHT2(4)
DIMENSION IHOLES(4)
DATA CSIGN /'-',' ','+'/
ILEFT(1)=I1
ILEFT(2)=J1
ILEFT(3)=IR1
ILEFT(4)=IS1
IRIGHT(1)=K1
IRIGHT(2)=L1
IRIGHT(3)=IT1
IRIGHT(4)=IU1
DO I=1,4
ILEFT2(I)=0
IRIGHT2(I)=0
IHOLES(I)=0
END DO
C
C how many holes in the LHS ?
ILHA=0
ILHB=0
ILPA=0
ILPB=0
IRHA=0
IRHB=0
IRPA=0
IRPB=0
DO I=1,4
IF (ILEFT(I).LT.0) THEN
IF (ABS(ILEFT(I)).LE.NOCC) THEN
ILHB=ILHB+1
ITYPEL(I)=1
ISPINL(I)=1
ELSE
ILPB=ILPB+1
ITYPEL(I)=2
ISPINL(I)=1
END IF
ELSE IF (ILEFT(I).GT.0) THEN
IF (ILEFT(I).LE.NOCC) THEN
ILHA=ILHA+1
ITYPEL(I)=1
ISPINL(I)=2
ELSE
ILPA=ILPA+1
ITYPEL(I)=2
ISPINL(I)=2
END IF
END IF
IF (IRIGHT(I).LT.0) THEN
IF (ABS(IRIGHT(I)).LE.NOCC) THEN
IRHB=IRHB+1
ITYPER(I)=1
ISPINR(I)=1
ELSE
IRPB=IRPB+1
ITYPER(I)=2
ISPINR(I)=1
END IF
ELSE IF (IRIGHT(I).GT.0) THEN
IF (IRIGHT(I).LE.NOCC) THEN
IRHA=IRHA+1
ITYPER(I)=1
ISPINR(I)=2
ELSE
IRPA=IRPA+1
ITYPER(I)=2
ISPINR(I)=2
END IF
END IF
END DO
NLEFT=ILHA+ILHB+ILPA+ILPB
NRIGHT=IRHA+IRHB+IRPA+IRPB
c$$$ WRITE(6,*) ' left determinant : holes alpha, beta ',ILHA,ILHB
c$$$ WRITE(6,*) ' left determinant : part. alpha, beta ',ILPA,ILPB
c$$$ WRITE(6,*) ' right determinant : holes alpha, beta ',IRHA,IRHB
c$$$ WRITE(6,*) ' right determinant : part. alpha, beta ',IRPA,IRPB
IF (ILHA.NE.ILPA) STOP ' error in holes/particles alpha LHS'
IF (ILHB.NE.ILPB) STOP ' error in holes/particles beta LHS'
IF (IRHA.NE.IRPA) STOP ' error in holes/particles alpha RHS'
IF (IRHB.NE.IRPB) STOP ' error in holes/particles beta RHS'
C transform the strings to occupations
INDX=0
DO I=1,2
IF (ILEFT(I).NE.0.AND.ABS(ILEFT(I)).LE.NOCC) THEN
INDX=INDX+1
ILEFT2(INDX)=ILEFT(I)
END IF
IF (IRIGHT(I).NE.0.AND.ABS(IRIGHT(I)).LE.NOCC) THEN
INDX=INDX+1
ILEFT2(INDX)=IRIGHT(I)
END IF
END DO
c$$$ WRITE(6,*) ' ILEFT2 ',(ILEFT2(JJ),JJ=1,4)
C
C eliminate same holes
C
DO I=1,4
DO J=I+1,4
IF (ILEFT2(I).EQ.ILEFT2(J).AND.ILEFT2(I).NE.0) THEN
ILEFT2(J)=0
END IF
END DO
END DO
NORBI=4
DO I=1,4
IF (ILEFT2(I).EQ.0) THEN
LFOUND=0
DO J=I+1,4
IF (LFOUND.EQ.0) THEN
IF (ILEFT2(J).NE.0) THEN
ILEFT2(I)=ILEFT2(J)
ILEFT2(J)=0
LFOUND=1
END IF
END IF
END DO
END IF
END DO
NORBI=0
DO I=1,4
IF (ILEFT2(I).NE.0) NORBI=NORBI+1
END DO
ISIGN=1
C check order of the RHS holes
IF (IRHA.EQ.2.OR.IRHB.EQ.2) THEN
DO I=1,NORBI
IF (ILEFT2(I).EQ.IRIGHT(1)) IRP1=I
IF (ILEFT2(I).EQ.IRIGHT(2)) IRP2=I
END DO
IF (IRP1.GT.IRP2) ISIGN=-ISIGN
END IF
c$$$ WRITE(6,9902) NORBI,(ILEFT2(J),J=1,NORBI)
c$$$ 9902 FORMAT(' NORBI = ',I4,' STRING ',4I4)
C save the string of the holes
DO I=1,NORBI
IHOLES(I)=ILEFT2(I)
END DO
NHOLES=NORBI
DO I=1,NORBI
IRIGHT2(I)=ILEFT2(I)
END DO
C now we have to place the particles
DO I=1,NORBI
C if this hole appears in the left string, we look for an adequate
c particle
LFOUND=0
DO J=1,4
IF (ILEFT2(I).EQ.ILEFT(J)) THEN
LFOUND=1
LSPIN=ISPINL(J)
END IF
END DO
C and replace the hole
IF (LFOUND.EQ.1) THEN
LSUB=0
DO J=1,4
IF (LSUB.EQ.0) THEN
C look for a particle with the same spin
IF ((LSPIN.EQ.ISPINL(J)).AND.(ITYPEL(J).EQ.2)) THEN
ILEFT2(I)=ILEFT(J)
ITYPEL(J)=0
LSUB=1
END IF
END IF
END DO
END IF
END DO
DO I=1,NORBI
C if this hole appears in the right string, we look for an adequate
c particle
LFOUND=0
DO J=1,4
IF (IRIGHT2(I).EQ.IRIGHT(J)) THEN
LFOUND=1
LSPIN=ISPINR(J)
END IF
END DO
C and replace the hole
IF (LFOUND.EQ.1) THEN
LSUB=0
DO J=1,4
IF (LSUB.EQ.0) THEN
C look for a particle with the same spin
IF ((LSPIN.EQ.ISPINR(J)).AND.(ITYPER(J).EQ.2)) THEN
IRIGHT2(I)=IRIGHT(J)
ITYPER(J)=0
LSUB=1
END IF
END IF
END DO
END IF
END DO
c$$$ WRITE(6,9903) 'left ',(ILEFT2(J),J=1,NORBI)
c$$$ WRITE(6,9903) 'right',(IRIGHT2(J),J=1,NORBI)
c$$$ 9903 FORMAT(' ',A5,' determinant as occupation : ',10I4)
C
C now we have to determine how many of the indices are equal
C
NEQUAL=0
DO I=1,NORBI
LFOUND=0
DO J=1,NORBI
IF (ILEFT2(I).EQ.IRIGHT2(J).AND.LFOUND.EQ.0) THEN
NEQUAL=NEQUAL+1
LFOUND=1
IF (I.NE.J) THEN
C exchange I and J in the right string
ISIGN=-ISIGN
IDUM=IRIGHT2(J)
IRIGHT2(J)=IRIGHT2(I)
IRIGHT2(I)=IDUM
END IF
END IF
END DO
END DO
c$$$ WRITE(6,*) '-left ',(ILEFT2(J),J=1,NORBI)
c$$$ WRITE(6,*) '-right',(IRIGHT2(J),J=1,NORBI)
C get the different particles to the left-hand side
DO I=1,NORBI
LFOUND=0
DO J=I,NORBI
C are these already different ?
IF (ILEFT2(J).NE.IRIGHT2(J).AND.LFOUND.EQ.0) THEN
IDUM=ILEFT2(I)
ILEFT2(I)=ILEFT2(J)
ILEFT2(J)=IDUM
IDUM=IRIGHT2(I)
IRIGHT2(I)=IRIGHT2(J)
IRIGHT2(J)=IDUM
LFOUND=1
END IF
END DO
END DO
c$$$ WRITE(6,*) 'left ',(ILEFT2(J),J=1,NORBI)
c$$$ WRITE(6,*) 'right',(IRIGHT2(J),J=1,NORBI)
NDIFF=NORBI-NEQUAL
c$$$ WRITE(6,*) ' implied orbitals : ',NORBI
c$$$ WRITE(6,*) ' equal indices : ',NEQUAL
c$$$ WRITE(6,*) ' different indices: ',NDIFF
c$$$ WRITE(6,*)
c$$$ WRITE(6,*) ' sign of the permutation: ',ISIGN
NORBI=NDIFF
c$$$ WRITE(6,9903) 'left ',(ILEFT2(J),J=1,NORBI)
c$$$ WRITE(6,9903) 'right',(IRIGHT2(J),J=1,NORBI)
IF (NORBI.LE.2) THEN
DO I=1,NORBI
IF (ILEFT2(I).LT.0) THEN
ISPINL(I)=1
ELSE
ISPINL(I)=2
END IF
IF (IRIGHT2(I).LT.0) THEN
ISPINR(I)=1
ELSE
ISPINR(I)=2
END IF
END DO
C
IF (NDIFF.EQ.0) THEN
WRITE(6,9904) I1,J1,IR1,IS1,K1,L1,IT1,IU1
WRITE(6,*) ' NDIFF = 0 '
STOP ' this should not have happened '
ELSE IF (NDIFF.EQ.1) THEN
I=MIN(ABS(ILEFT2(1)),ABS(IRIGHT2(1)))
J=MAX(ABS(ILEFT2(1)),ABS(IRIGHT2(1)))
XMATEL=F(I,J)
IF (IPRINT.GT.4) WRITE(6,9912) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),I,J
C subtract all hole interactions
DO IH=1,NHOLES
IHOLE=IHOLES(IH)
IF (SIGN(1,IHOLE).EQ.SIGN(1,ILEFT2(1))) THEN
IHOLE=ABS(IHOLE)
II1=ABS(ILEFT2(1))
JJ1=ABS(IRIGHT2(1))
KK1=IHOLE
LL1=IHOLE
II2=ABS(ILEFT2(1))
JJ2=IHOLE
KK2=ABS(IRIGHT2(1))
LL2=IHOLE
CALL OCAN(II1,JJ1,KK1,LL1)
CALL OCAN(II2,JJ2,KK2,LL2)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
ICLASS2=IGETTY(II2,JJ2,KK2,LL2)
XT1=HFIND(II1,JJ1,KK1,LL1,ICLASS1)-HFIND(II2,JJ2,KK2,LL2
$ ,ICLASS2)
XMATEL=XMATEL-XT1
IF (IPRINT.GT.4) WRITE(6,9913) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(-ISIGN),II1,JJ1,KK1,LL1,CSIGN(ISIGN),II2,JJ2,KK2
$ ,LL2,XT1
ELSE
IHOLE=ABS(IHOLE)
II1=ABS(ILEFT2(1))
JJ1=ABS(IRIGHT2(1))
KK1=IHOLE
LL1=IHOLE
CALL OCAN(II1,JJ1,KK1,LL1)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
XT1=HFIND(II1,JJ1,KK1,LL1,ICLASS1)
XMATEL=XMATEL-XT1
IF (IPRINT.GT.4) WRITE(6,9914) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(-ISIGN),II1,JJ1,KK1,LL1,XT1
END IF
END DO
C add all particle interactions
DO IEQUAL=1,NEQUAL
IPART=ILEFT2(1+IEQUAL)
IF (SIGN(1,IPART).EQ.SIGN(1,ILEFT2(1))) THEN
IPART=ABS(IPART)
II1=ABS(ILEFT2(1))
JJ1=ABS(IRIGHT2(1))
KK1=IPART
LL1=IPART
II2=ABS(ILEFT2(1))
JJ2=IPART
KK2=ABS(IRIGHT2(1))
LL2=IPART
CALL OCAN(II1,JJ1,KK1,LL1)
CALL OCAN(II2,JJ2,KK2,LL2)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
ICLASS2=IGETTY(II2,JJ2,KK2,LL2)
XT1=HFIND(II1,JJ1,KK1,LL1,ICLASS1)-HFIND(II2,JJ2,KK2,LL2
$ ,ICLASS2)
XMATEL=XMATEL+XT1
IF (IPRINT.GT.4) WRITE(6,9913) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,CSIGN(-ISIGN),II2,JJ2,KK2
$ ,LL2,XMATEL
ELSE
IPART=ABS(IPART)
II1=ABS(ILEFT2(1))
JJ1=ABS(IRIGHT2(1))
KK1=IPART
LL1=IPART
CALL OCAN(II1,JJ1,KK1,LL1)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
XT1=HFIND(II1,JJ1,KK1,LL1,ICLASS1)
XMATEL=XMATEL+XT1
IF (IPRINT.GT.4) WRITE(6,9914) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,XMATEL
END IF
END DO
C we have the interaction with the holes
XMATEL=XMATEL*XMULT*DBLE(ISIGN)
IF (IPRINT.GT.4) WRITE(6,9916) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,XMATEL
ELSE IF (NDIFF.EQ.2) THEN
DO I=1,2
ILEFT2(I)=ABS(ILEFT2(I))
IRIGHT2(I)=ABS(IRIGHT2(I))
END DO
C same spins
IF (ISPINL(1).EQ.ISPINL(2)) THEN
II1=ILEFT2(1)
JJ1=IRIGHT2(1)
KK1=ILEFT2(2)
LL1=IRIGHT2(2)
CALL OCAN(II1,JJ1,KK1,LL1)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
II2=ILEFT2(1)
JJ2=IRIGHT2(2)
KK2=ILEFT2(2)
LL2=IRIGHT2(1)
CALL OCAN(II2,JJ2,KK2,LL2)
ICLASS2=IGETTY(II2,JJ2,KK2,LL2)
IF (ISIGN.GT.0) THEN
XMATEL=HFIND(II1,JJ1,KK1,LL1,ICLASS1)-HFIND(II2,JJ2,KK2
$ ,LL2,ICLASS2)
XMATEL=XMATEL*XMULT
IF (IPRINT.GT.4) WRITE(6,9913) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,CSIGN(-ISIGN),II2,JJ2,KK2
$ ,LL2,XMATEL
ELSE
XMATEL=-HFIND(II1,JJ1,KK1,LL1,ICLASS1)+HFIND(II2,JJ2,KK2
$ ,LL2,ICLASS2)
XMATEL=XMATEL*XMULT
IF (IPRINT.GT.4) WRITE(6,9913) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,CSIGN(-ISIGN),II2,JJ2,KK2
$ ,LL2,XMATEL
END IF
ELSE
II1=ILEFT2(1)
JJ1=IRIGHT2(1)
KK1=ILEFT2(2)
LL1=IRIGHT2(2)
CALL OCAN(II1,JJ1,KK1,LL1)
ICLASS1=IGETTY(II1,JJ1,KK1,LL1)
IF (ISIGN.GT.0) THEN
XMATEL= HFIND(II1,JJ1,KK1,LL1,ICLASS1)*XMULT
IF (IPRINT.GT.4) WRITE(6,9914) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,XMATEL
ELSE
XMATEL=-HFIND(II1,JJ1,KK1,LL1,ICLASS1)*XMULT
IF (IPRINT.GT.4) WRITE(6,9914) I1,J1,IR1,IS1,K1,L1,IT1,IU1
$ ,CSIGN(ISIGN),II1,JJ1,KK1,LL1,XMATEL
END IF
END IF
END IF
ELSE
IF (IPRINT.GT.4) WRITE(6,9915) I1,J1,IR1,IS1,K1,L1,IT1,IU1
XMATEL=0.D0
END IF
9904 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> ')
9912 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> : interaction ',A1,'F(',I3,',',I3,')',F20.12)
9913 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> : interaction ',A1,'(',2I4,'|',2I4,') ',A1,' (',2I4,'|'
$ ,2I4,') ',F20.12)
9914 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> : interaction ',A1,'(',2I4,'|',2I4,') ',F20.12)
9915 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> : no interaction ')
9916 FORMAT(' calculating matrix element <',4I4,'||',4I4
$ ,'> : global element : ',F20.12)
RETURN
END
SUBROUTINE VERIFI
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
COMMON /RSD/ LRR,LRS,LRD,LSS,LSD,LDD
LOGICAL LRR,LRS,LRD,LSS,LSD,LDD
C.. INCLUDE 'common_rsd.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
WRITE(6,*)
WRITE(6,*) ' verifying the matrix elements '
WRITE(6,*)
LSS=.TRUE.
LSD=.TRUE.
LDD=.TRUE.
LRS=.TRUE.
LRD=.TRUE.
WRITE(6,*) ' these elements seem not correct : '
WRITE(6,*)
ONE=1.D0
DO IDET=1,NDET2
I1=ID0(1,IDET)
J1=ID0(2,IDET)
K1=ID0(3,IDET)
L1=ID0(4,IDET)
DO JDET=1,NDET2
VECT(JDET)=0.D0
HVECT(JDET)=0.D0
END DO
VECT(IDET)=1.D0
C in HVECT we have the matrix elements of H
CALL HCALC(VECT,HVECT)
C
C we recalculate the element
C
DO JDET=IDET+1,NDET2
I2=ID0(1,JDET)
J2=ID0(2,JDET)
K2=ID0(3,JDET)
L2=ID0(4,JDET)
ELEM=XMATEL(I1,J1,K1,L1,I2,J2,K2,L2,NOCC,ONE)
EDIFF=ELEM-HVECT(JDET)
IF (ABS(EDIFF).LT.1.D-12) THEN
WRITE(6,'(7H RI--- ,4I4,3H | ,4I4,3H : ,3F20.12)') I1,J1,K1,L1
$ ,I2,J2,K2,L2,HVECT(JDET),ELEM,EDIFF
ELSE
E2DIFF=ELEM+HVECT(JDET)
IF (ABS(E2DIFF).LT.1.D-12) THEN
WRITE(6,'(7H SIGN ,4I4,3H | ,4I4,3H : ,3F20.12)') I1,J1,K1
$ ,L1,I2,J2,K2,L2,HVECT(JDET),ELEM,EDIFF
ELSE
WRITE(6,'(7H WRONG ,4I4,3H | ,4I4,3H : ,3F20.12)') I1,J1,K1
$ ,L1,I2,J2,K2,L2,HVECT(JDET),ELEM,EDIFF
END IF
END IF
END DO
END DO
RETURN
END
SUBROUTINE OCAN(I,J,K,L)
IMPLICIT INTEGER (A-Z)
I1=I
J1=J
K1=K
L1=L
IF (I1.GT.J1) THEN
IDUM=I1
I1=J1
J1=IDUM
END IF
IF (K1.GT.L1) THEN
IDUM=K1
K1=L1
L1=IDUM
END IF
IF (I1.GT.K1) THEN
IDUM=I1
I1=K1
K1=IDUM
IDUM=J1
J1=L1
L1=IDUM
ELSE IF (I1.EQ.K1) THEN
IF (J1.GT.L1) THEN
IDUM=J1
J1=L1
L1=IDUM
END IF
END IF
I=I1
J=J1
K=K1
L=L1
RETURN
END
SUBROUTINE WCOMPL
INCLUDE 'param.h'
COMMON /DETLST/ ID0(5,NDETMX),NDET2,IREFN
C.. INCLUDE 'common_detlst.h'
COMMON /CIVEC/ VECT(NDETMX),HVECT(NDETMX)
C.. INCLUDE 'common_civec.h'
C NBSOLD: NBAS before freezing/deleting
COMMON /SYST/ EHF,EN,ENO,NBAS,NOCC,NVIRT,NBSOLD,LCORE
LOGICAL LCORE
C.. INCLUDE 'common_syst.h'
C
C we store the final CI vector in a different norm : the correlated
C part is normed to 1
C
WRITE(6,*) ' writing file CICOMPL.VEC '
CALL VNORM(VECT,3)
OPEN(UNIT=67,FILE='CICOMPL.VEC',FORM='FORMATTED',STATUS='UNKNOWN'
$ )
C there is no real complement, i.e. VECT(IREFN) > 1.D8
IF (VECT(IREFN).GT.1.D8) THEN
WRITE(6,*) ' no contribution from excited determinants '
DO I=1,NDET2
VECT(I)=0.D0
END DO
VECT(IREFN)=1.D4
END IF
IZERO=0
WRITE(67,'(4I5,E20.12)') IZERO,IZERO,IZERO,IZERO,VECT(IREFN)
DO IDET=1,NDET2
IF (ABS(VECT(IDET)).GT.1.D-12) THEN
I=ID0(1,IDET)
J=ID0(2,IDET)
K=ID0(3,IDET)
L=ID0(4,IDET)
C single excitation
IF (J.EQ.0) THEN
C only C_ia, not the beta spins
IF (I.GT.0) THEN
II=INVMAP(I)
KK=INVMAP(K)
WRITE(67,'(4I5,E20.12)') II,IZERO,KK,IZERO,VECT(IDET)
END IF
ELSE
C double excitation
C
C i.le.j, k.le.l
C
C we have the case iIkL, iIKl, iJkL, iJKl, ijkl
C
IF (I.GT.0) THEN
IF (J.GT.0) THEN
C ijkl
II=INVMAP(I)
JJ=INVMAP(J)
KK=INVMAP(K)
LL=INVMAP(L)
C we store it as iJkL which has the same coefficient as IjKl
WRITE(67,'(4I5,E20.12)') II,JJ,KK,LL,VECT(IDET)
ELSE
IF (K.GT.0) THEN
C iJkL (or iIkL)
II=INVMAP(I)
JJ=INVMAP(-J)
KK=INVMAP(K)
LL=INVMAP(-L)
WRITE(67,'(4I5,E20.12)') II,-JJ,KK,-LL,VECT(IDET)
ELSE
C iJKl (or iIKl)
II=INVMAP(I)
JJ=INVMAP(-J)
KK=INVMAP(-K)
LL=INVMAP(L)
WRITE(67,'(4I5,E20.12)') II,-JJ,-KK,LL,VECT(IDET)
END IF
END IF
END IF
END IF
END IF
END DO
CLOSE(67)
RETURN
END