Merge branch 'master' of github.com:pfloos/QuAcK

.gitignore

@@ -1,2 +1,5 @@
 *.o
 *.
+__pycache__
+
+.ninja_deps

PyDuck.py

@@ -18,6 +18,7 @@ parser.add_argument('-b', '--basis', type=str, required=True, help='Name of the
 parser.add_argument('--bohr', default='Angstrom', action='store_const', const='Bohr', help='By default QuAcK assumes that the xyz files are in Angstrom. Add this argument if your xyz file is in Bohr.')
 parser.add_argument('-c', '--charge', type=int, default=0, help='Total charge of the molecule. Specify negative charges with "m" instead of the minus sign, for example m1 instead of -1. Default is 0')
 parser.add_argument('--cartesian', default=False, action='store_true', help='Add this option if you want to use cartesian basis functions.')
+parser.add_argument('--print_2e', default=False, action='store_true', help='Add this option if you want to print 2e-integrals.')
 parser.add_argument('-fc', '--frozen_core', type=bool, default=False, help='Freeze core MOs. Default is false')
 parser.add_argument('-m', '--multiplicity', type=int, default=1, help='Spin multiplicity. Default is 1 therefore singlet')
 parser.add_argument('--working_dir', type=str, default=QuAcK_dir, help='Set a working directory to run the calculation.')
@@ -32,6 +33,7 @@ frozen_core=args.frozen_core
 multiplicity=args.multiplicity
 xyz=args.xyz + '.xyz'
 cartesian=args.cartesian
+print_2e=args.print_2e
 working_dir=args.working_dir
 
 #Read molecule
@@ -90,11 +92,10 @@ t1e  = mol.intor('int1e_kin') #Kinetic energy matrix elements
 dipole = mol.intor('int1e_r') #Matrix elements of the x, y, z operators
 x,y,z = dipole[0],dipole[1],dipole[2]
 
-norb = len(ovlp)
+norb = len(ovlp) # nBAS_AOs
 subprocess.call(['rm', working_dir + '/int/nBas.dat'])
 f = open(working_dir+'/int/nBas.dat','w')
-f.write(str(norb))
+f.write(" {} ".format(str(norb)))
-f.write(' ')
 f.close()
 
 
@@ -122,7 +123,6 @@ write_matrix_to_file(y,norb,working_dir+'/int/y.dat')
 subprocess.call(['rm', working_dir + '/int/z.dat'])
 write_matrix_to_file(z,norb,working_dir+'/int/z.dat')
 
-#Write two-electron integrals
 eri_ao = mol.intor('int2e')
 
 def write_tensor_to_file(tensor,size,file,cutoff=1e-15):
@@ -132,12 +132,23 @@ def write_tensor_to_file(tensor,size,file,cutoff=1e-15):
             for k in range(i,size):
                 for l in range(j,size):
                     if abs(tensor[i][k][j][l]) > cutoff:
+                        #f.write(str(i+1)+' '+str(j+1)+' '+str(k+1)+' '+str(l+1)+' '+"{:.16E}".format(tensor[i][k][j][l]))
                         f.write(str(i+1)+' '+str(j+1)+' '+str(k+1)+' '+str(l+1)+' '+"{:.16E}".format(tensor[i][k][j][l]))
                         f.write('\n')
     f.close()
 
-subprocess.call(['rm', working_dir + '/int/ERI.dat'])
+# Write two-electron integrals
-write_tensor_to_file(eri_ao,norb,working_dir+'/int/ERI.dat')
+if print_2e:
+    # (formatted)
+    subprocess.call(['rm', working_dir + '/int/ERI.dat'])
+    write_tensor_to_file(eri_ao,norb,working_dir+'/int/ERI.dat')
+else:
+    # (binary)
+    subprocess.call(['rm', working_dir + '/int/ERI.bin'])
+    # chem -> phys notation
+    eri_ao = eri_ao.transpose(0, 2, 1, 3)
+    eri_ao.tofile('int/ERI.bin')
+
 
 #Execute the QuAcK fortran program
 subprocess.call(QuAcK_dir+'/bin/QuAcK')

int/CAP.dat

@@ -1,16 +0,0 @@
-   1  1  9.1642021581097924E-03  6.2961947849362709E-02 9.1642021581097941E-03
-   1  2  2.9798815568270971E-02  1.0031339688416364E-01 2.9798815568270971E-02
-   1  3  4.8078353659559226E-03  5.1255302523161485E-03 4.8078353659559234E-03
-   1  4  2.3003539814844435E-02  4.1290024754715535E-02 2.3003539814844435E-02
-   2  1  2.9798815568270971E-02  1.0031339688416364E-01 2.9798815568270971E-02
-   2  2  3.5629639141443131E-01  5.7428563627799001E-01 3.5629639141443131E-01
-   2  3  2.3003539814844435E-02  4.1290024754715576E-02 2.3003539814844435E-02
-   2  4  3.0301481386007040E-01  3.0301481386007040E-01 3.0301481386007040E-01
-   3  1  4.8078353659559226E-03  5.1255302523161485E-03 4.8078353659559234E-03
-   3  2  2.3003539814844435E-02  4.1290024754715576E-02 2.3003539814844435E-02
-   3  3  9.1642021581097924E-03  6.2961947849362682E-02 9.1642021581097941E-03
-   3  4  2.9798815568270971E-02  1.0031339688416376E-01 2.9798815568270971E-02
-   4  1  2.3003539814844435E-02  4.1290024754715535E-02 2.3003539814844435E-02
-   4  2  3.0301481386007040E-01  3.0301481386007040E-01 3.0301481386007040E-01
-   4  3  2.9798815568270971E-02  1.0031339688416376E-01 2.9798815568270971E-02
-   4  4  3.5629639141443131E-01  5.7428563627799034E-01 3.5629639141443131E-01

mol/H2.xyz

@@ -1,4 +1,4 @@
 2
 
-H  0.0000  0.0000  -0.37500000
+H     0.00000000      -0.37500000       0.00000000
-H  0.0000  0.0000  0.37500000
+H     0.00000000       0.37500000       0.00000000

mol/N2.xyz

@@ -1,4 +1,4 @@
 2
 
-N  0.0000  0.0000  0.0000
+N  0.0000  0.0000  -0.5475132
-N  0.0000  0.0000  1.1007
+N  0.0000  0.0000  0.5475132

src/AOtoMO/AOtoMO.f90

@@ -1,26 +1,31 @@
-subroutine AOtoMO(nBas,C,A,B)
+subroutine AOtoMO(nBas, nOrb, C, M_AOs, M_MOs)
 
-! Perform AO to MO transformation of a matrix A for given coefficients c
+  ! Perform AO to MO transformation of a matrix M_AOs for given coefficients c
+  ! M_MOs = C.T M_AOs C
 
   implicit none
 
-! Input variables
+  integer,          intent(in)  :: nBas, nOrb
+  double precision, intent(in)  :: C(nBas,nOrb)
+  double precision, intent(in)  :: M_AOs(nBas,nBas)
 
-  integer,intent(in)            :: nBas
+  double precision, intent(out) :: M_MOs(nOrb,nOrb)
-  double precision,intent(in)   :: C(nBas,nBas)
-  double precision,intent(in)   :: A(nBas,nBas)
 
-! Local variables
+  double precision, allocatable :: AC(:,:)
 
-  double precision,allocatable  :: AC(:,:)
+  allocate(AC(nBas,nOrb))
 
-! Output variables
+  !AC = matmul(M_AOs, C)
+  !M_MOs = matmul(transpose(C), AC)
 
-  double precision,intent(out)  :: B(nBas,nBas)
+  call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, &
+             M_AOs(1,1), nBas, C(1,1), nBas,   &
+             0.d0, AC(1,1), nBas)
 
-  allocate(AC(nBas,nBas))
+  call dgemm("T", "N", nOrb, nOrb, nBas, 1.d0, &
+             C(1,1), nBas, AC(1,1), nBas,      &
+             0.d0, M_MOs(1,1), nOrb)
 
-  AC = matmul(A,C)
+  deallocate(AC)
-  B  = matmul(transpose(C),AC)
 
 end subroutine 

src/AOtoMO/AOtoMO_ERI_RHF.f90

@@ -1,4 +1,7 @@
-subroutine AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+
+! ---
+
+subroutine AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
 ! AO to MO transformation of two-electron integrals via the semi-direct O(N^5) algorithm
 
@@ -7,32 +10,51 @@ subroutine AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(in)   :: c(nBas,nBas)
+  double precision,intent(in)   :: c(nBas,nOrb)
 
 ! Local variables
 
-  double precision,allocatable  :: scr(:,:,:,:)
+  double precision,allocatable  :: a1(:,:,:,:)
-  integer                       :: mu,nu,la,si
+  double precision,allocatable  :: a2(:,:,:,:)
-  integer                       :: i,j,k,l
 
 ! Output variables
 
-  double precision,intent(out)  :: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(out)  :: ERI_MO(nOrb,nOrb,nOrb,nOrb)
 
 ! Memory allocation
 
-  allocate(scr(nBas,nBas,nBas,nBas))
+  allocate(a2(nBas,nBas,nBas,nOrb))
+  allocate(a1(nBas,nBas,nOrb,nOrb))
 
 ! Four-index transform via semi-direct O(N^5) algorithm
 
-  call dgemm('T','N',nBas**3,nBas,nBas,1d0,ERI_AO,nBas,c(1,1),size(c,1),0d0,scr,nBas**3)
+  call dgemm( 'T', 'N', nBas*nBas*nBas, nOrb, nBas, 1.d0 &
-  
+            , ERI_AO(1,1,1,1), nBas, c(1,1), nBas        &
-  call dgemm('T','N',nBas**3,nBas,nBas,1d0,scr,nBas,c(1,1),size(c,1),0d0,ERI_MO,nBas**3)
+            , 0.d0, a2(1,1,1,1), nBas*nBas*nBas)
 
-  call dgemm('T','N',nBas**3,nBas,nBas,1d0,ERI_MO,nBas,c(1,1),size(c,1),0d0,scr,nBas**3)
+  call dgemm( 'T', 'N', nBas*nBas*nOrb, nOrb, nBas, 1.d0 &
+            , a2(1,1,1,1), nBas, c(1,1), nBas            &
+            , 0.d0, a1(1,1,1,1), nBas*nBas*nOrb)
 
-  call dgemm('T','N',nBas**3,nBas,nBas,1d0,scr,nBas,c(1,1),size(c,1),0d0,ERI_MO,nBas**3)
+  deallocate(a2)
+  allocate(a2(nBas,nOrb,nOrb,nOrb))
+
+  call dgemm( 'T', 'N', nBas*nOrb*nOrb, nOrb, nBas, 1.d0 &
+            , a1(1,1,1,1), nBas, c(1,1), nBas            &
+            , 0.d0, a2(1,1,1,1), nBas*nOrb*nOrb)
+
+  deallocate(a1)
+
+  call dgemm( 'T', 'N', nOrb*nOrb*nOrb, nOrb, nBas, 1.d0 &
+            , a2(1,1,1,1), nBas, c(1,1), nBas            &
+            , 0.d0, ERI_MO(1,1,1,1), nOrb*nOrb*nOrb)
+
+  deallocate(a2)
 
 end subroutine 
+
+
+
+

src/AOtoMO/MOtoAO.f90

@@ -1,31 +1,39 @@
-subroutine MOtoAO(nBas,S,C,B,A)
+subroutine MOtoAO(nBas, nOrb, S, C, M_MOs, M_AOs)
 
-! Perform MO to AO transformation of a matrix A for a given metric S
+  ! Perform MO to AO transformation of a matrix M_AOs for a given metric S
-! and coefficients c
+  ! and coefficients c
+  ! 
+  ! M_AOs = S C M_MOs (S C).T
 
   implicit none
 
-! Input variables
+  integer,          intent(in)  :: nBas, nOrb
+  double precision, intent(in)  :: S(nBas,nBas)
+  double precision, intent(in)  :: C(nBas,nOrb)
+  double precision, intent(in)  :: M_MOs(nOrb,nOrb)
+  double precision, intent(out) :: M_AOs(nBas,nBas)
 
-  integer,intent(in)            :: nBas
+  double precision, allocatable :: SC(:,:),BSC(:,:)
-  double precision,intent(in)   :: S(nBas,nBas)
-  double precision,intent(in)   :: C(nBas,nBas)
-  double precision,intent(in)   :: B(nBas,nBas)
 
-! Local variables
 
-  double precision,allocatable  :: SC(:,:),BSC(:,:)
+  allocate(SC(nBas,nOrb), BSC(nOrb,nBas))
 
-! Output variables
+  !SC  = matmul(S, C)
+  !BSC = matmul(M_MOs, transpose(SC))
+  !M_AOs = matmul(SC, BSC)
 
-  double precision,intent(out)  :: A(nBas,nBas)
+  call dgemm("N", "N", nBas, nOrb, nBas, 1.d0, &
+             S(1,1), nBas, C(1,1), nBas,       &
+             0.d0, SC(1,1), nBas)
 
-! Memory allocation
+  call dgemm("N", "T", nOrb, nBas, nOrb, 1.d0, &
+             M_MOs(1,1), nOrb, SC(1,1), nBas,  &
+             0.d0, BSC(1,1), nOrb)
 
-  allocate(SC(nBas,nBas),BSC(nBas,nBas))
+  call dgemm("N", "N", nBas, nBas, nOrb, 1.d0, &
+             SC(1,1), nBas, BSC(1,1), nOrb,    &
+             0.d0, M_AOs(1,1), nBas)
 
-  SC  = matmul(S,C)
+  deallocate(SC, BSC)
-  BSC = matmul(B,transpose(SC))
-  A   = matmul(SC,BSC)
 
 end subroutine 

src/CC/RCC.f90

@@ -1,5 +1,8 @@
-subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & 
+
-               maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+! ---
+
+subroutine RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & 
+               maxSCF, thresh, max_diis, nBas, nOrb, nC, nO, nV, nR, Hc, ERI_AO, ERI_MO, ENuc, ERHF, eHF, cHF)
 
 ! Coupled-cluster module
 
@@ -24,15 +27,18 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   integer,intent(in)            :: max_diis
   double precision,intent(in)   :: thresh
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   double precision,intent(in)   :: ENuc
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
+  double precision,intent(in)   :: Hc(nBas,nBas)
+  double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: ERI_MO(nOrb,nOrb,nOrb,nOrb)
 
 ! Local variables
 
@@ -45,11 +51,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(doCCD) then
 
     call wall_time(start_CC)
-    call CCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call CCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -61,12 +67,12 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(doDCD) then
 
     call wall_time(start_CC)
-    call DCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR, & 
+    call DCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR, &
-             ERI,ENuc,ERHF,eHF)
+             ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for DCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for DCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -80,11 +86,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(doCCSD) then
 
     call wall_time(start_CC)
-    call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call CCSD(dotest,maxSCF,thresh,max_diis,doCCSDT,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CCSD or CCSD(T)= ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CCSD or CCSD(T)= ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -96,11 +102,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(dodrCCD) then
 
     call wall_time(start_CC)
-    call drCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call drCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for direct ring CCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for direct ring CCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -112,11 +118,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(dorCCD) then
 
     call wall_time(start_CC)
-    call rCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call rCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for rCCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for rCCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -128,11 +134,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(docrCCD) then
 
     call wall_time(start_CC)
-    call crCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call crCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for crossed-ring CCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for crossed-ring CCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -144,11 +150,11 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(dolCCD) then
 
     call wall_time(start_CC)
-    call lCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call lCCD(dotest,maxSCF,thresh,max_diis,nOrb,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ladder CCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ladder CCD = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -160,11 +166,13 @@ subroutine RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,d
   if(dopCCD) then
 
     call wall_time(start_CC)
-    call pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call pCCD(dotest, maxSCF, thresh, max_diis, nBas, nOrb, &
+              nC, nO, nV, nR, Hc, ERI_AO, ENuc, ERHF, eHF, cHF)
+
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pair CCD = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pair CCD = ',t_CC,' seconds'
     write(*,*)
 
   end if

src/CC/pCCD.f90

@@ -1,4 +1,8 @@
-subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+
+! ---
+
+subroutine pCCD(dotest, maxIt, thresh, max_diis, nBas, nOrb, &
+                nC, nO, nV, nR, Hc, ERI_AO, ENuc, ERHF, eHF, cHF)
 
 ! pair CCD module
 
@@ -8,22 +12,29 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF
 
   logical,intent(in)            :: dotest
 
-  integer,intent(in)            :: maxSCF
+  integer,intent(in)            :: maxIt
   integer,intent(in)            :: max_diis
   double precision,intent(in)   :: thresh
 
-  integer,intent(in)            :: nBas,nC,nO,nV,nR
+  integer,intent(in)            :: nBas, nOrb, nC, nO, nV, nR
   double precision,intent(in)   :: ENuc,ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
+  double precision,intent(in)   :: Hc(nBas,nBas)
+  double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
 
 ! Local variables
 
+  integer                       :: p,q,r,s,t,u,w
+  integer                       :: pq,rs
   integer                       :: i,j,a,b
 
-  integer                       :: nSCF
+  integer                       :: nItAmp
-  double precision              :: Conv
+  integer                       :: nItOrb
-  double precision              :: ECC,EcCC
+  double precision              :: CvgAmp
+  double precision              :: CvgOrb
+  double precision              :: ECC
+  double precision              :: EcCC
 
   double precision,allocatable  :: eO(:)
   double precision,allocatable  :: eV(:)
@@ -35,184 +46,697 @@ subroutine pCCD(dotest,maxSCF,thresh,max_diis,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF
   double precision,allocatable  :: OVVO(:,:)
   double precision,allocatable  :: VVVV(:,:)
 
-  double precision,allocatable  :: y(:,:)
+  double precision,allocatable  :: yO(:,:)
+  double precision,allocatable  :: yV(:,:)
 
-  double precision,allocatable  :: r(:,:)
+  double precision,allocatable  :: r2(:,:)
-  double precision,allocatable  :: t(:,:)
+  double precision,allocatable  :: t2(:,:)
+  double precision,allocatable  :: z2(:,:)
 
+  double precision,allocatable  :: rdm1(:,:)
+  double precision,allocatable  :: rdm2(:,:,:,:)
+  double precision,allocatable  :: xOO(:,:)
+  double precision,allocatable  :: xVV(:,:)
+  double precision,allocatable  :: xOV(:,:)
+  double precision              :: tr_1rdm
+  double precision              :: tr_2rdm
+
+  double precision              :: E1,E2
+  double precision,allocatable  :: c(:,:)
+  double precision,allocatable  :: h(:,:)
+  double precision,allocatable  :: ERI_MO(:,:,:,:)
+  double precision,allocatable  :: grad(:)
+  double precision,allocatable  :: tmp(:,:,:,:)
+  double precision,allocatable  :: hess(:,:)
+  double precision,allocatable  :: hessInv(:,:)
+  double precision,allocatable  :: Kap(:,:)
+  double precision,allocatable  :: ExpKap(:,:)
+
+  integer                       :: O,V,N
   integer                       :: n_diis
   double precision              :: rcond
-  double precision,allocatable  :: error_diis(:,:)
+  double precision,allocatable  :: err_diis(:,:)
-  double precision,allocatable  :: t_diis(:,:)
+  double precision,allocatable  :: t2_diis(:,:)
+  double precision,allocatable  :: z2_diis(:,:)
   double precision,external     :: trace_matrix
+  double precision,external     :: Kronecker_delta
           
 ! Hello world
 
   write(*,*)
-  write(*,*)'**************************************'
+  write(*,*)'*******************************'
-  write(*,*)'|     pair CCD calculation           |'
+  write(*,*)'* Restricted pCCD Calculation *'
-  write(*,*)'**************************************'
+  write(*,*)'*******************************'
   write(*,*)
 
-! Form energy denominator
+! Useful quantities
 
-  allocate(eO(nO-nC),eV(nV-nR),delta_OV(nO-nC,nV-nR))
+  O = nO - nC
+  V = nV - nR
+  N = O + V ! nOrb - nC - nR
 
-  eO(:) = eHF(nC+1:nO)
+  !------------------------------------!
-  eV(:) = eHF(nO+1:nBas-nR)
+  ! Star Loop for orbital optimization !
+  !------------------------------------!
 
-  call form_delta_OV(nC,nO,nV,nR,eO,eV,delta_OV)
+  allocate(ERI_MO(N,N,N,N))
+  allocate(c(nBas,N), h(N,N))
+  allocate(eO(O), eV(V), delta_OV(O,V))
+  allocate(OOOO(O,O), OOVV(O,V), OVOV(O,V), OVVO(O,V), VVVV(V,V))
 
-! Create integral batches
+  do i = 1, N
+    c(:,i) = cHF(:,nC+i)
+  enddo
 
-  allocate(OOOO(nO-nC,nO-nC),OOVV(nO-nC,nV-nR),OVOV(nO-nC,nV-nR),OVVO(nO-nC,nV-nR),VVVV(nV-nR,nV-nR))
+  CvgOrb = 1d0
+  nItOrb = 0
 
-  do i=1,nO-nC
-    do j=1,nO-nC
-      OOOO(i,j) = ERI(nC+i,nC+i,nC+j,nC+j)
-    end do
-  end do
-
-  do i=1,nO-nC
-    do a=1,nV-nR
-      OOVV(i,a) = ERI(nC+i,nC+i,nO+a,nO+a)
-      OVOV(i,a) = ERI(nC+i,nO+a,nC+i,nO+a)
-      OVVO(i,a) = ERI(nC+i,nO+a,nO+a,nC+i)
-    end do
-  end do
-
-  do a=1,nV-nR
-    do b=1,nV-nR
-      VVVV(a,b) = ERI(nO+a,nO+a,nO+b,nO+b)
-    end do
-  end do
-
-! MP2 guess amplitudes
-
-  allocate(t(nO-nC,nV-nR))
-
-  t(:,:) = -0.5d0*OOVV(:,:)/delta_OV(:,:)
-
-  EcCC = 0d0
-  do i=1,nO-nC
-    do a=1,nV-nR
-      EcCC = EcCC + OOVV(i,a)*t(i,a)
-    end do
-  end do
-
-! Memory allocation for DIIS
-
-  allocate(error_diis((nO-nC)*(nV-nR),max_diis),t_diis((nO-nC)*(nV-nR),max_diis))
-
-! Initialization
-
-  allocate(r(nO-nC,nV-nR),y(nO-nC,nO-nC))
-
-  Conv = 1d0
-  nSCF = 0
-
-  n_diis          = 0
-  t_diis(:,:)     = 0d0
-  error_diis(:,:) = 0d0
-
-!------------------------------------------------------------------------
-! Main SCF loop
-!------------------------------------------------------------------------
   write(*,*)
   write(*,*)'----------------------------------------------------'
-  write(*,*)'| pair CCD calculation                             |'
+  write(*,*)'| Orbital Optimization for pCCD                     |'
-  write(*,*)'----------------------------------------------------'
-  write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') &
-            '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|'
   write(*,*)'----------------------------------------------------'
 
-  do while(Conv > thresh .and. nSCF < maxSCF)
+  do while(CvgOrb > thresh .and. nItOrb < 1)
 
-  ! Increment 
+    nItOrb = nItOrb + 1
 
-    nSCF = nSCF + 1
+    ! Transform integrals
 
-  ! Form intermediate array
+    h = matmul(transpose(c), matmul(Hc, c))
-    
-   y(:,:) = 0d0
-   do i=1,nO-nC
-     do j=1,nO-nC
-       do b=1,nV-nR
-         y(i,j) = y(i,j) + OOVV(j,b)*t(i,b)
-       end do
-     end do
-   end do
-    
-   ! Compute residual
 
-    do i=1,nO-nC
+    call AOtoMO_ERI_RHF(nBas, N, c(1,1), ERI_AO(1,1,1,1), ERI_MO(1,1,1,1))
-      do a=1,nV-nR
 
-        r(i,a) = OOVV(i,a) + 2d0*delta_OV(i,a)*t(i,a) & 
+    ! Form energy denominator
-               - 2d0*(2d0*OVOV(i,a) - OVVO(i,a) - OOVV(i,a)*t(i,a))*t(i,a)
 
-        do j=1,nO-nC
+    eO(:) = eHF(nC+1:nO)
-          r(i,a) = r(i,a) - 2d0*OOVV(j,a)*t(j,a)*t(i,a) + OOOO(j,i)*t(j,a) + y(i,j)*t(j,a) 
+    eV(:) = eHF(nO+1:nOrb-nR)
-        end do 
-
-        do b=1,nV-nR
-          r(i,a) = r(i,a) - 2d0*OOVV(i,b)*t(i,b)*t(i,a) + VVVV(a,b)*t(i,b)
-        end do 
 
+    do i=1,O
+      do a=1,V
+        delta_OV(i,a) = eV(a) - eO(i)
       end do
     end do
 
-   ! Check convergence 
+    ! Create integral batches
 
-    Conv = maxval(abs(r(:,:)))
+    do i=1,O
+      do j=1,O
+        OOOO(i,j) = ERI_MO(i,i,j,j)
+      end do
+    end do
+ 
+    do i=1,O
+      do a=1,V
+        OOVV(i,a) = ERI_MO(i,i,O+a,O+a)
+        OVOV(i,a) = ERI_MO(i,O+a,i,O+a)
+        OVVO(i,a) = ERI_MO(i,O+a,O+a,i)
+      end do
+    end do
+ 
+    do a=1,V
+      do b=1,V
+        VVVV(a,b) = ERI_MO(O+a,O+a,O+b,O+b)
+      end do
+    end do
+
+    !----------------------------!
+    ! Star Loop for t amplitudes !
+    !----------------------------!
+ 
+    allocate(t2(O,V),r2(O,V),yO(O,O))
+    allocate(err_diis(O*V,max_diis),t2_diis(O*V,max_diis))
+
+    CvgAmp = 1d0
+    nItAmp = 0
+    ECC    = ERHF
+    EcCC   = 0d0
+ 
+    n_diis        = 0
+    t2(:,:)       = 0d0
+    t2_diis(:,:)  = 0d0
+    err_diis(:,:) = 0d0
+ 
+    write(*,*)
+    write(*,*)'----------------------------------------------------'
+    write(*,*)'| pCCD calculation: t amplitudes                   |'
+    write(*,*)'----------------------------------------------------'
+    write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') &
+              '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|'
+    write(*,*)'----------------------------------------------------'
+ 
+    do while(CvgAmp > thresh .and. nItAmp < maxIt)
+ 
+    ! Increment 
+ 
+      nItAmp = nItAmp + 1
+ 
+    ! Form intermediate array
+      
+     yO(:,:) = matmul(t2,transpose(OOVV))
+      
+     ! Compute residual
+ 
+      r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*t2(:,:) & 
+              - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - OOVV(:,:)*t2(:,:))*t2(:,:)
+ 
+      do i=1,O
+        do a=1,V
+ 
+          do j=1,O
+            r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*t2(i,a) + OOOO(j,i)*t2(j,a) + yO(i,j)*t2(j,a) 
+          end do 
+ 
+          do b=1,V
+            r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*t2(i,a) + VVVV(a,b)*t2(i,b)
+          end do 
+ 
+        end do
+      end do
+ 
+      ! Check convergence 
+ 
+      CvgAmp = maxval(abs(r2(:,:)))
+    
+      ! Update amplitudes
+ 
+      t2(:,:) = t2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:)
+ 
+      ! Compute correlation energy
+ 
+      EcCC = 0d0
+      do i=1,O
+        do a=1,V
+          EcCC = EcCC + OOVV(i,a)*t2(i,a) 
+        end do
+      end do
+ 
+      ! Dump results
+ 
+      ECC = ERHF + EcCC
+ 
+      ! DIIS extrapolation
+ 
+      if(max_diis > 1) then
+ 
+        n_diis = min(n_diis+1,max_diis)
+        call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,err_diis,t2_diis,-0.5d0*r2/delta_OV,t2)
+ 
+      end if
+ 
+      write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') &
+        '|',nItAmp,'|',ECC+ENuc,'|',EcCC,'|',CvgAmp,'|'
+ 
+    end do
+    write(*,*)'----------------------------------------------------'
+
+    !---------------------------!
+    ! End Loop for t amplitudes !
+    !---------------------------!
+ 
+    deallocate(r2,yO)
+    deallocate(err_diis,t2_diis)
+
+    ! Did it actually converge?
+ 
+    if(nItAmp == maxIt) then
+ 
+      write(*,*)
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+      write(*,*)'! Convergence failed for t ampitudes !'
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+ 
+      stop
   
-   ! Update amplitudes
+    end if
+ 
+    !-----------------------------!
+    ! Start Loop for z amplitudes !
+    !-----------------------------!
+ 
+    allocate(z2(O,V),r2(O,V),yO(O,O),yV(V,V))
+    allocate(err_diis(O*V,max_diis),z2_diis(O*V,max_diis))
 
-   t(:,:) = t(:,:) - 0.5d0*r(:,:)/delta_OV(:,:)
+    CvgAmp = 1d0
-
+    nItAmp = 0
-   ! Compute correlation energy
+ 
-
+    n_diis        = 0
-    EcCC = 0d0
+    z2_diis(:,:)  = 0d0
-    do i=1,nO-nC    
+    err_diis(:,:) = 0d0
-      do a=1,nV-nR
-        EcCC = EcCC + OOVV(i,a)*t(i,a)
-     end do
-   end do
-
-   ! Dump results
-
-    ECC = ERHF + EcCC
-
-    ! DIIS extrapolation
-
-!   n_diis = min(n_diis+1,max_diis)
-!   call DIIS_extrapolation(rcond,nO*nV,nO*nV,n_diis,error_diis,t_diis,-0.5d0*r/delta_OV,t)
-
-    !  Reset DIIS if required
-
-!   if(abs(rcond) < 1d-15) n_diis = 0
-
-    write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') &
-      '|',nSCF,'|',ECC+ENuc,'|',EcCC,'|',Conv,'|'
-
-  end do
-  write(*,*)'----------------------------------------------------'
-!------------------------------------------------------------------------
-! End of SCF loop
-!------------------------------------------------------------------------
-
-! Did it actually converge?
-
-  if(nSCF == maxSCF) then
 
     write(*,*)
-    write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+    write(*,*)'----------------------------------------------------'
-    write(*,*)'                 Convergence failed                 '
+    write(*,*)'| pCCD calculation: z amplitudes                   |'
-    write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+    write(*,*)'----------------------------------------------------'
+    write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') &
+              '|','#','|','E(pCCD)','|','Ec(pCCD)','|','Conv','|'
+    write(*,*)'----------------------------------------------------'
+ 
+    do while(CvgAmp > thresh .and. nItAmp < maxIt)
+ 
+    ! Increment 
+ 
+      nItAmp = nItAmp + 1
+ 
+    ! Form intermediate array
+    
+     yO(:,:) = matmul(OOVV,transpose(t2))
+     yV(:,:) = matmul(transpose(OOVV),t2)
+ 
+     ! Compute residual
+ 
+      r2(:,:) = OOVV(:,:) + 2d0*delta_OV(:,:)*z2(:,:) &
+              - 2d0*(2d0*OVOV(:,:) - OVVO(:,:) - 2d0*OOVV(:,:)*t2(:,:))*z2(:,:)
+ 
+      do i=1,O
+        do a=1,V
+ 
+          do j=1,O
+            r2(i,a) = r2(i,a) - 2d0*OOVV(j,a)*t2(j,a)*z2(i,a) - 2d0*OOVV(i,a)*z2(j,a)*t2(j,a) & 
+                              + OOOO(i,j)*z2(j,a) + yO(i,j)*z2(j,a)
+          end do
+ 
+          do b=1,V
+            r2(i,a) = r2(i,a) - 2d0*OOVV(i,b)*t2(i,b)*z2(i,a) - 2d0*OOVV(i,a)*z2(i,b)*t2(i,b) & 
+                              + VVVV(b,a)*z2(i,b) + yV(a,b)*z2(i,b)
+          end do
+ 
+        end do
+      end do
+ 
+     ! Check convergence 
+ 
+      CvgAmp = maxval(abs(r2(:,:)))
+    
+     ! Update amplitudes
+ 
+     z2(:,:) = z2(:,:) - 0.5d0*r2(:,:)/delta_OV(:,:)
+ 
+     ! DIIS extrapolation
+ 
+     if(max_diis > 1) then
+ 
+       n_diis = min(n_diis+1,max_diis)
+       call DIIS_extrapolation(rcond,O*V,O*V,n_diis,err_diis,z2_diis,-0.5d0*r2/delta_OV,z2)
+ 
+      end if
+ 
+      write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') &
+        '|',nItAmp,'|',ECC+ENuc,'|',EcCC,'|',CvgAmp,'|'
+ 
+    end do
+    write(*,*)'----------------------------------------------------'
+    write(*,*)
 
-    stop
+    !---------------------------!
+    ! End Loop for z ampltiudes !
+    !---------------------------!
 
-  end if
+    deallocate(r2,yO,yV)
+    deallocate(err_diis,z2_diis)
+ 
+    ! Did it actually converge?
+ 
+    if(nItAmp == maxIt) then
+ 
+      write(*,*)
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+      write(*,*)'! Convergence failed for z ampltiudes !'
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+ 
+      stop
+  
+    end if
+ 
+    !--------------------------!
+    ! Compute density matrices !
+    !--------------------------!
+ 
+    allocate(rdm1(N,N),rdm2(N,N,N,N))
+    allocate(xOO(O,O),xVV(V,V),xOV(O,V))
+
+    xOO(:,:) = matmul(t2,transpose(z2))
+    xVV(:,:) = matmul(transpose(z2),t2)
+    xOV(:,:) = matmul(t2,matmul(transpose(z2),t2))
+
+    ! Form 1RDM
+ 
+    rdm1(:,:) = 0d0
+ 
+    do i=1,O
+      rdm1(i,i) = 2d0*(1d0 - xOO(i,i))
+    end do
+ 
+    do a=1,V
+      rdm1(O+a,O+a) = 2d0*xVV(a,a)
+    end do
+ 
+    ! Check 1RDM
+ 
+    tr_1rdm = trace_matrix(N,rdm1)
+    write(*,'(A25,F16.10)') ' --> Trace of the 1RDM = ',tr_1rdm
+ 
+    if( abs(dble(2*O) - tr_1rdm) > thresh ) & 
+    write(*,*) ' !!! Your 1RDM seems broken !!! '
+    write(*,*)
+ 
+    ! write(*,*) '1RDM is diagonal at the pCCD level:'
+    ! call matout(N,N,rdm1)
+ 
+    ! Form 2RM
+ 
+    rdm2(:,:,:,:) = 0d0
+ 
+    ! iijj
+ 
+    do i=1,O
+      do j=1,O
+        rdm2(i,i,j,j) = 2d0*xOO(i,j)
+      end do
+    end do
+ 
+    ! iiaa
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(i,i,O+a,O+a) = 2d0*(t2(i,a) + xOV(i,a) - 2d0*t2(i,a)*(xVV(a,a) + xOO(i,i) - t2(i,a)*z2(i,a)))
+      end do
+    end do
+ 
+    ! aaii
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(O+a,O+a,i,i) = 2d0*z2(i,a)
+      end do
+    end do
+ 
+    ! aabb
+ 
+    do a=1,V
+      do b=1,V
+        rdm2(O+a,O+a,O+b,O+b) = 2d0*xVV(a,b)
+      end do
+    end do
+ 
+    ! ijij
+ 
+    do i=1,O
+      do j=1,O
+        rdm2(i,j,i,j) = 4d0*(1d0 - xOO(i,i) - xOO(j,j))
+      end do
+    end do
+ 
+    ! ijji
+ 
+    do i=1,O
+      do j=1,O
+        rdm2(i,j,j,i) = - 2d0*(1d0 - xOO(i,i) - xOO(j,j))
+      end do
+    end do
+ 
+    ! iiii
+ 
+    do i=1,O
+      rdm2(i,i,i,i) = 2d0*(1d0 - xOO(i,i))
+    end do
+ 
+    ! iaia
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(i,O+a,i,O+a) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a))
+      end do
+    end do
+ 
+    ! iaai
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(i,O+a,O+a,i) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a))
+      end do
+    end do
+ 
+    ! aiai
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(O+a,i,O+a,i) = 4d0*(xVV(a,a) - t2(i,a)*z2(i,a))
+      end do
+    end do
+ 
+    ! aiia
+ 
+    do i=1,O
+      do a=1,V
+        rdm2(O+a,i,i,O+a) = - 2d0*(xVV(a,a) - t2(i,a)*z2(i,a))
+      end do
+    end do
+ 
+    ! abab
+ 
+    do a=1,V
+      rdm2(O+a,O+a,O+a,O+a) = 2d0*xVV(a,a)
+    end do
+ 
+    ! Check 2RDM
+ 
+    tr_2rdm = trace_matrix(N**2,rdm2)
+    write(*,'(A25,F16.10)') ' --> Trace of the 2RDM = ',tr_2rdm
+ 
+    if( abs(dble(2*O*(2*O-1)) - tr_2rdm) > thresh ) & 
+    write(*,*) ' !!! Your 2RDM seems broken !!! '
+    write(*,*)
+ 
+    ! write(*,*) '2RDM is not diagonal at the pCCD level:'
+    ! call matout(N**2,N**2,rdm2)
+
+    deallocate(xOO,xVV,xOV)
+    deallocate(t2,z2)
+ 
+    ! Compute electronic energy
+ 
+    E1 = 0d0
+    E2 = 0d0
+ 
+    do p=1,N
+      do q=1,N
+        E1 = E1 + rdm1(p,q)*h(p,q)
+        do r=1,N
+          do s=1,N
+            E2 = E2 + rdm2(p,q,r,s)*ERI_MO(p,q,r,s)
+          end do
+        end do
+      end do
+    end do
+ 
+    E2 = 0.5d0*E2
+ 
+    write(*,'(A25,F16.10)') ' One-electron energy = ',E1
+    write(*,'(A25,F16.10)') ' Two-electron energy = ',E2
+    write(*,'(A25,F16.10)') ' Electronic   energy = ',E1 + E2
+    write(*,'(A25,F16.10)') ' Total        energy = ',E1 + E2 + ENuc
+    write(*,*)
+ 
+    !--------------------------!
+    ! Compute orbital gradient !
+    !--------------------------!
+ 
+    allocate(grad(N**2))
+ 
+    grad(:) = 0d0
+ 
+    pq = 0
+    do p=1,N
+      do q=1,N
+ 
+        pq = pq + 1
+ 
+        do r=1,N
+          grad(pq) = grad(pq) + h(r,p)*rdm1(r,q)  - h(q,r)*rdm1(p,r)
+        end do
+ 
+        do r=1,N
+          do s=1,N
+            do t=1,N
+              grad(pq) = grad(pq) + (ERI_MO(r,s,p,t)*rdm2(r,s,q,t) - ERI_MO(q,t,r,s)*rdm2(p,t,r,s))
+            end do
+          end do
+        end do
+ 
+      end do
+    end do
+ 
+    write(*,*) 'Orbital gradient at the pCCD level:'
+    call matout(N,N,grad)
+    write(*,*)
+ 
+   ! Check convergence of orbital optimization
+ 
+    CvgOrb = maxval(abs(grad))
+    write(*,*) ' Iteration',nItOrb,'for pCCD orbital optimization'
+    write(*,*) ' Convergence of orbital gradient = ',CvgOrb
+    write(*,*)
+  
+    !-------------------------!
+    ! Compute orbital Hessian !
+    !-------------------------!
+ 
+    allocate(hess(N**2,N**2),tmp(N,N,N,N))
+ 
+    tmp(:,:,:,:) = 0d0
+ 
+    do p=1,N
+      do q=1,N
+ 
+        do r=1,N
+          do s=1,N
+ 
+            tmp(p,q,r,s) = - h(s,p)*rdm1(r,q) - h(q,r)*rdm1(p,s)
+            
+            do u=1,N
+ 
+              tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*(                          &
+                  Kronecker_delta(q,r)*(h(u,p)*rdm1(u,s) + h(s,u)*rdm1(p,u)) &
+                + Kronecker_delta(p,s)*(h(u,r)*rdm1(u,q) + h(q,u)*rdm1(r,u)) )
+ 
+            end do
+ 
+            do u=1,N
+              do w=1,N
+ 
+              tmp(p,q,r,s) = tmp(p,q,r,s) + ERI_MO(u,w,p,r)*rdm2(u,w,q,s) + ERI_MO(q,s,u,w)*rdm2(p,r,u,w)
+ 
+              end do
+            end do
+ 
+            do t=1,N
+              do u=1,N
+ 
+              tmp(p,q,r,s) = tmp(p,q,r,s) - (                                   &
+                  ERI_MO(s,t,p,u)*rdm2(r,t,q,u) + ERI_MO(t,s,p,u)*rdm2(t,r,q,u) &
+                + ERI_MO(q,u,r,t)*rdm2(p,u,s,t) + ERI_MO(q,u,t,r)*rdm2(p,u,t,s) )
+ 
+              end do
+            end do
+ 
+            do t=1,N
+              do u=1,N
+                do w=1,N
+ 
+                  tmp(p,q,r,s) = tmp(p,q,r,s) + 0.5d0*(                                                    & 
+                      Kronecker_delta(q,r)*(ERI_MO(u,w,p,t)*rdm2(u,w,s,t) + ERI_MO(s,t,u,w)*rdm2(p,t,u,w)) &
+                    + Kronecker_delta(p,s)*(ERI_MO(q,t,u,w)*rdm2(r,t,u,w) + ERI_MO(u,w,r,t)*rdm2(u,w,q,t)) )
+ 
+                end do
+              end do
+            end do
+ 
+          end do
+        end do
+ 
+      end do
+    end do
+ 
+    ! Flatten Hessian matrix and add permutations
+ 
+    pq = 0
+    do p=1,N
+      do q=1,N
+ 
+        pq = pq + 1
+     
+        rs = 0
+        do r=1,N
+          do s=1,N
+ 
+            rs = rs + 1
+ 
+            hess(pq,rs) = tmp(p,r,q,s) - tmp(r,p,q,s) - tmp(p,r,s,q) + tmp(r,p,s,q)
+!!          hess(pq,rs) = tmp(p,q,r,s) - tmp(q,p,r,s) - tmp(p,q,s,r) + tmp(q,p,s,r)
+ 
+          end do
+        end do
+ 
+      end do
+    end do
+
+    deallocate(rdm1,rdm2,tmp)
+ 
+    allocate(hessInv(N**2,N**2))
+ 
+    call inverse_matrix(N**2,hess,hessInv)
+
+    deallocate(hess)
+ 
+    allocate(Kap(N,N))
+ 
+    Kap(:,:) = 0d0
+ 
+    pq = 0
+    do p=1,N
+      do q=1,N
+ 
+        pq = pq + 1
+ 
+        rs = 0
+        do r=1,N
+          do s=1,N
+ 
+            rs = rs + 1
+ 
+              Kap(p,q) = Kap(p,q) - hessInv(pq,rs)*grad(rs)
+ 
+          end do
+        end do
+ 
+      end do
+    end do
+ 
+    deallocate(hessInv,grad)
+
+    write(*,*) 'kappa'
+    call matout(N,N,Kap)
+    write(*,*)
+ 
+    allocate(ExpKap(N,N))
+    call matrix_exponential(N,Kap,ExpKap)
+    deallocate(Kap)
+ 
+    write(*,*) 'e^kappa'
+    call matout(N, N, ExpKap)
+    write(*,*)
+ 
+    write(*,*) 'Old orbitals'
+    call matout(nBas, N, c)
+    write(*,*)
+ 
+    c = matmul(c, ExpKap)
+    deallocate(ExpKap)
+ 
+    write(*,*) 'Rotated orbitals'
+    call matout(nBas, N, c)
+    write(*,*)
+
+  end do
+
+  !-----------------------------------!
+  ! End Loop for orbital optimization !
+  !-----------------------------------!
+
+    ! Did it actually converge?
+
+    if(nItOrb == maxIt) then
+
+      write(*,*)
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+      write(*,*)'! Convergence failed for orbital optimization !'
+      write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+
+      stop
+
+    end if
+
+! Testing zone
 
   if(dotest) then
 

src/CI/RCI.f90

@@ -1,5 +1,8 @@
-subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,nO,nV,nR,nS,ERI,dipole_int, &
+
-               epsHF,EHF,cHF,S)
+! ---
+
+subroutine RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nOrb, &
+               nC, nO, nV, nR, nS, ERI, dipole_int, epsHF, EHF)
 
 ! Configuration interaction module
 
@@ -18,18 +21,16 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n
 
   logical,intent(in)            :: singlet
   logical,intent(in)            :: triplet
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   integer,intent(in)            :: nS
   double precision,intent(in)   :: EHF
-  double precision,intent(in)   :: epsHF(nBas)
+  double precision,intent(in)   :: epsHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: ERI(nOrb,nOrb,nOrb,nOrb)
-  double precision,intent(in)   :: S(nBas,nBas)
+  double precision,intent(in)   :: dipole_int(nOrb,nOrb,ncart)
-  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
-  double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
 
 ! Local variables
 
@@ -42,11 +43,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n
   if(doCIS) then
 
     call wall_time(start_CI)
-    call RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF)
+    call RCIS(dotest,singlet,triplet,doCIS_D,nOrb,nC,nO,nV,nR,nS,ERI,dipole_int,epsHF)
     call wall_time(end_CI)
 
     t_CI = end_CI - start_CI
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CIS = ',t_CI,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CIS = ',t_CI,' seconds'
     write(*,*)
 
   end if
@@ -58,11 +59,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n
   if(doCID) then
 
     call wall_time(start_CI)
-    call CID(dotest,singlet,triplet,nBas,nC,nO,nV,nR,ERI,epsHF,EHF)
+    call CID(dotest,singlet,triplet,nOrb,nC,nO,nV,nR,ERI,epsHF,EHF)
     call wall_time(end_CI)
 
     t_CI = end_CI - start_CI
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CID = ',t_CI,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CID = ',t_CI,' seconds'
     write(*,*)
 
   end if
@@ -74,11 +75,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n
   if(doCISD) then
 
     call wall_time(start_CI)
-    call CISD(dotest,singlet,triplet,nBas,nC,nO,nV,nR,ERI,epsHF,EHF)
+    call CISD(dotest,singlet,triplet,nOrb,nC,nO,nV,nR,ERI,epsHF,EHF)
     call wall_time(end_CI)
 
     t_CI = end_CI - start_CI
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CISD = ',t_CI,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CISD = ',t_CI,' seconds'
     write(*,*)
 
   end if
@@ -91,11 +92,11 @@ subroutine RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,n
 
     call wall_time(start_CI)
     write(*,*) ' FCI is not yet implemented! Sorry.'
-!   call FCI(nBas,nC,nO,nV,nR,ERI,epsHF)
+!   call FCI(nOrb,nC,nO,nV,nR,ERI,epsHF)
     call wall_time(end_CI)
 
     t_CI = end_CI - start_CI
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for FCI = ',t_CI,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for FCI = ',t_CI,' seconds'
     write(*,*)
 
   end if

src/CI/RCIS.f90

@@ -41,7 +41,7 @@ subroutine RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_in
 
 ! Memory allocation
 
-  allocate(A(nS,nS),Om(nS))
+  allocate(A(nS,nS), Om(nS))
 
 ! Compute CIS matrix
 
@@ -117,4 +117,6 @@ subroutine RCIS(dotest,singlet,triplet,doCIS_D,nBas,nC,nO,nV,nR,nS,ERI,dipole_in
 
   end if
 
+  deallocate(A, Om)
+
 end subroutine 

src/GF/RG0F2.f90

@@ -51,7 +51,7 @@ subroutine RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,
 
 ! Memory allocation
 
-  allocate(SigC(nBas),Z(nBas),eGFlin(nBas),eGF(nBas))
+  allocate(SigC(nBas), Z(nBas), eGFlin(nBas), eGF(nBas))
 
 ! Frequency-dependent second-order contribution
 
@@ -133,4 +133,6 @@ subroutine RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,
 
   end if
 
+  deallocate(SigC, Z, eGFlin, eGF)
+
 end subroutine 

src/GF/RGF.f90

@@ -1,7 +1,10 @@
-subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,maxSCF,thresh,max_diis, &
+
-               dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,eta,regularize,            & 
+! ---
-               nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,EHF,S,X,T,V,Hc,ERI_AO,ERI,                 & 
+
-               dipole_int_AO,dipole_int,PHF,cHF,epsHF)
+subroutine RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm, maxSCF,         &
+               thresh, max_diis, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, linearize,     &
+               eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, EHF, &
+               S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF)
 
 ! Green's function module
 
@@ -39,7 +42,7 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
@@ -47,18 +50,18 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   integer,intent(in)            :: nS
 
   double precision,intent(in)   :: EHF
-  double precision,intent(in)   :: epsHF(nBas)
+  double precision,intent(in)   :: epsHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
@@ -71,12 +74,13 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   if(doG0F2) then
 
     call wall_time(start_GF)
-    call RG0F2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,linearize,eta,regularize, & 
+    call RG0F2(dotest, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, &
-               nBas,nC,nO,nV,nR,nS,ENuc,EHF,ERI,dipole_int,epsHF)
+               linearize, eta, regularize, nOrb, nC, nO, nV, nR, nS, &
+               ENuc, EHF, ERI_MO, dipole_int_MO, epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds'
     write(*,*)
 
   end if
@@ -89,12 +93,12 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
 
     call wall_time(start_GF)
     call evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis, & 
-                singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,EHF, & 
+                singlet,triplet,linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,EHF, & 
-                ERI,dipole_int,epsHF)
+                ERI_MO,dipole_int_MO,epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds'
     write(*,*)
 
   end if
@@ -106,12 +110,14 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   if(doqsGF2) then 
 
     call wall_time(start_GF)
-    call qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc, & 
+    call qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA,    &
-                nBas,nC,nO,nV,nR,nS,EHF,S,X,T,V,Hc,ERI_AO,ERI,dipole_int_AO,dipole_int,PHF,cHF,epsHF)
+                dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc,  &
+                rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, EHF, S, &
+                X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGF2 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGF2 = ',t_GF,' seconds'
     write(*,*)
 
  end if
@@ -123,11 +129,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   if(doufG0F02) then 
 
     call wall_time(start_GF)
-    call ufRG0F02(dotest,nBas,nC,nO,nV,nR,nS,ENuc,EHF,ERI,epsHF)
+    call ufRG0F02(dotest, nOrb, nC, nO, nV, nR, nS, ENuc, EHF, ERI_MO, epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0F02 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0F02 = ',t_GF,' seconds'
     write(*,*)
 
   end if
@@ -139,11 +145,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   if(doG0F3) then
 
     call wall_time(start_GF)
-    call RG0F3(dotest,renorm,nBas,nC,nO,nV,nR,ERI,epsHF)
+    call RG0F3(dotest, renorm, nOrb, nC, nO, nV, nR, ERI_MO, epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF3 = ',t_GF,' seconds'
     write(*,*)
 
   end if
@@ -155,11 +161,11 @@ subroutine RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm,max
   if(doevGF3) then
 
     call wall_time(start_GF)
-    call evRGF3(dotest,maxSCF,thresh,max_diis,renorm,nBas,nC,nO,nV,nR,ERI,epsHF)
+    call evRGF3(dotest, maxSCF, thresh, max_diis, renorm, nOrb, nC, nO, nV, nR, ERI_MO, epsHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF3 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF3 = ',t_GF,' seconds'
     write(*,*)
 
   end if

src/GF/evRGF2.f90

@@ -62,7 +62,7 @@ subroutine evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis,si
 
 ! Memory allocation
 
-  allocate(SigC(nBas),Z(nBas),eGF(nBas),eOld(nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis))
+  allocate(SigC(nBas), Z(nBas), eGF(nBas), eOld(nBas), error_diis(nBas,max_diis), e_diis(nBas,max_diis))
 
 ! Initialization
 
@@ -189,4 +189,6 @@ subroutine evRGF2(dotest,dophBSE,doppBSE,TDA,dBSE,dTDA,maxSCF,thresh,max_diis,si
 
   end if
 
+  deallocate(SigC, Z, eGF, eOld, error_diis, e_diis)
+
 end subroutine 

src/GF/print_qsRGF2.f90

@@ -1,4 +1,8 @@
-subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ,Ex,Ec,EqsGF,dipole)
+
+! ---
+
+subroutine print_qsRGF2(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGF, c, &
+                        SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF, dipole)
 
 ! Print one-electron energies and other stuff for qsGF2
 
@@ -7,17 +11,17 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ,
 
 ! Input variables
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO
   integer,intent(in)                 :: nSCF
   double precision,intent(in)        :: ENuc
   double precision,intent(in)        :: Conv
   double precision,intent(in)        :: thresh
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: eGF(nBas)
+  double precision,intent(in)        :: eGF(nOrb)
-  double precision,intent(in)        :: c(nBas)
+  double precision,intent(in)        :: c(nBas,nOrb)
-  double precision,intent(in)        :: SigC(nBas,nBas)
+  double precision,intent(in)        :: SigC(nOrb,nOrb)
-  double precision,intent(in)        :: Z(nBas)
+  double precision,intent(in)        :: Z(nOrb)
   double precision,intent(in)        :: ET
   double precision,intent(in)        :: EV
   double precision,intent(in)        :: EJ
@@ -53,7 +57,7 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ,
             '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|'
   write(*,*)'-------------------------------------------------------------------------------'
 
-  do q=1,nBas
+  do q = 1, nOrb
     write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') &
     '|',q,'|',eHF(q)*HaToeV,'|',SigC(q,q)*HaToeV,'|',Z(q),'|',eGF(q)*HaToeV,'|'
   end do
@@ -102,12 +106,12 @@ subroutine print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigC,Z,ENuc,ET,EV,EJ,
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A32)') ' qsGF2 MO coefficients'
     write(*,'(A50)') '---------------------------------------'
-    call matout(nBas,nBas,c)
+    call matout(nBas, nOrb, c)
     write(*,*)
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A32)') ' qsGF2 MO energies'
     write(*,'(A50)') '---------------------------------------'
-    call matout(nBas,1,eGF)
+    call matout(nOrb, 1, eGF)
     write(*,*)
 
   end if

src/GF/qsRGF2.f90

@@ -1,6 +1,10 @@
-subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet, & 
+
-                eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, &
+! ---
-                S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+
+subroutine qsRGF2(dotest, maxSCF, thresh, max_diis, dophBSE, doppBSE, TDA,   &
+                  dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, &
+                  rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF,  &
+                  S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Perform a quasiparticle self-consistent GF2 calculation
 
@@ -29,25 +33,25 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas,nC,nO,nV,nR,nS
+  integer,intent(in)            :: nBas,nOrb,nC,nO,nV,nR,nS
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: ispin
   integer                       :: n_diis
   double precision              :: EqsGF2
@@ -94,7 +98,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
 
 ! Stuff 
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! TDA 
 
@@ -105,9 +109,27 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
 
 ! Memory allocation
 
-  allocate(eGF(nBas),eOld(nbas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), &
+  allocate(eGF(nOrb))
-           J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),Z(nBas),                      & 
+  allocate(eOld(nOrb))
-           error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+
+  allocate(c(nBas,nOrb))
+
+  allocate(cp(nOrb,nOrb))
+  allocate(Fp(nOrb,nOrb))
+
+  allocate(P(nBas,nBas))
+  allocate(F(nBas,nBas))
+  allocate(J(nBas,nBas))
+  allocate(K(nBas,nBas))
+  allocate(error(nBas,nBas))
+
+  allocate(Z(nOrb))
+  allocate(SigC(nOrb,nOrb))
+
+  allocate(SigCp(nBas,nBas))
+
+  allocate(error_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
 
 ! Initialization
   
@@ -117,7 +139,7 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
   Conv            = 1d0
   P(:,:)          = PHF(:,:)
   eOld(:)         = eHF(:)
-  eGF(:)         = eHF(:)
+  eGF(:)          = eHF(:)
   c(:,:)          = cHF(:,:)
   F_diis(:,:)     = 0d0
   error_diis(:,:) = 0d0
@@ -135,25 +157,25 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
 
     ! Buid Hartree matrix
 
-    call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J)
+    call Hartree_matrix_AO_basis(nBas, P, ERI_AO, J)
 
     ! Compute exchange part of the self-energy 
 
-    call exchange_matrix_AO_basis(nBas,P,ERI_AO,K)
+    call exchange_matrix_AO_basis(nBas, P, ERI_AO, K)
 
     ! AO to MO transformation of two-electron integrals
 
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
     ! Compute self-energy and renormalization factor
 
     if(regularize) then
 
-      call GF2_reg_self_energy(eta,nBas,nC,nO,nV,nR,eGF,ERI_MO,SigC,Z)
+      call GF2_reg_self_energy(eta, nOrb, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z)
 
     else
 
-      call GF2_self_energy(eta,nBas,nC,nO,nV,nR,eGF,ERI_MO,SigC,Z)
+      call GF2_self_energy(eta, nOrb, nC, nO, nV, nR, eGF, ERI_MO, SigC, Z)
 
     end if
 
@@ -161,36 +183,47 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
    
     SigC = 0.5d0*(SigC + transpose(SigC))
 
-    call MOtoAO(nBas,S,c,SigC,SigCp)
+    call MOtoAO(nBas, nOrb, S, c, SigC, SigCp)
  
     ! Solve the quasi-particle equation
 
     F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + SigCp(:,:)
+    if(nBas .ne. nOrb) then
+      call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1))
+      call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1))
+    endif
 
     ! Compute commutator and convergence criteria
 
-    error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F)
+    error = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F)
 
     ! DIIS extrapolation 
 
-    n_diis = min(n_diis+1,max_diis)
+    n_diis = min(n_diis+1, max_diis)
     if(abs(rcond) > 1d-7) then
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F)
     else
       n_diis = 0
     end if
 
     ! Diagonalize Hamiltonian in AO basis
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    if(nBas .eq. nOrb) then
-    cp(:,:) = Fp(:,:)
+      Fp = matmul(transpose(X), matmul(F, X))
-    call diagonalize_matrix(nBas,cp,eGF)
+      cp(:,:) = Fp(:,:)
-    c = matmul(X,cp)
+      call diagonalize_matrix(nOrb, cp, eGF)
-    SigCp = matmul(transpose(c),matmul(SigCp,c))
+      c = matmul(X, cp)
+    else
+      Fp = matmul(transpose(c), matmul(F, c))
+      cp(:,:) = Fp(:,:)
+      call diagonalize_matrix(nOrb, cp, eGF)
+      c = matmul(c, cp)
+    endif
+
 
     ! Compute new density matrix in the AO basis
 
-    P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
+    P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO)))
 
     ! Save quasiparticles energy for next cycle
 
@@ -203,23 +236,23 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
 
     ! Kinetic energy
 
-    ET = trace_matrix(nBas,matmul(P,T))
+    ET = trace_matrix(nBas, matmul(P, T))
 
     ! Potential energy
 
-    EV = trace_matrix(nBas,matmul(P,V))
+    EV = trace_matrix(nBas, matmul(P, V))
 
     ! Hartree energy
 
-    EJ = 0.5d0*trace_matrix(nBas,matmul(P,J))
+    EJ = 0.5d0*trace_matrix(nBas, matmul(P, J))
 
     ! Exchange energy
 
-    Ex = 0.25d0*trace_matrix(nBas,matmul(P,K))
+    Ex = 0.25d0*trace_matrix(nBas, matmul(P, K))
 
     ! Correlation energy
 
-    call RMP2(.false.,regularize,nBas,nC,nO,nV,nR,ERI_MO,ENuc,EqsGF2,eGF,Ec)
+    call RMP2(.false., regularize, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, EqsGF2, eGF, Ec)
 
     ! Total energy
 
@@ -230,8 +263,9 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
     ! Print results
     !------------------------------------------------------------------------
 
-    call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole)
+    call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole)
-    call print_qsRGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF,c,SigCp,Z,ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,dipole)
+    call print_qsRGF2(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGF, &
+                      c, SigC, Z, ENuc, ET, EV, EJ, Ex, Ec, EqsGF2, dipole)
 
   end do
 !------------------------------------------------------------------------
@@ -248,19 +282,21 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, error, error_diis, F_diis)
     stop
 
   end if
 
 ! Deallocate memory
 
-  deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,Z,error,error_diis,F_diis)
+  deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, error, error_diis, F_diis)
 
 ! Perform BSE calculation
 
   if(dophBSE) then
 
-    call GF2_phBSE2(TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGF,EcBSE)
+    call GF2_phBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, nC, nO, &
+                    nV, nR, nS, ERI_MO, dipole_int_MO, eGF, EcBSE)
 
     write(*,*)
     write(*,*)'-------------------------------------------------------------------------------'
@@ -278,7 +314,8 @@ subroutine qsRGF2(dotest,maxSCF,thresh,max_diis,dophBSE,doppBSE,TDA,dBSE,dTDA,si
 
   if(doppBSE) then
 
-    call GF2_ppBSE2(TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,ERI_MO,dipole_int_MO,eGF,EcBSE)
+    call GF2_ppBSE2(TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, &
+                    nC, nO, nV, nR, ERI_MO, dipole_int_MO, eGF, EcBSE)
 
     write(*,*)
     write(*,*)'-------------------------------------------------------------------------------'

src/GF/qsUGF2.f90

@@ -197,7 +197,7 @@ subroutine qsUGF2(dotest,maxSCF,thresh,max_diis,BSE,TDA,dBSE,dTDA,spin_conserved
     end do
 
     do is=1,nspin
-      call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
+      call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
     end do
  
     ! Solve the quasi-particle equation

src/GT/GTpp_excitation_density.f90

@@ -2,6 +2,12 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1
 
 ! Compute excitation densities for T-matrix self-energy
 
+  ! TODO
+  ! debug DGEMM for nC != 0
+  !             and nR != 0
+
+
+
   implicit none
 
 ! Input variables
@@ -33,6 +39,10 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1
   double precision,intent(out)  :: rho1(nBas,nBas,nVV)
   double precision,intent(out)  :: rho2(nBas,nBas,nOO)
 
+  integer                       :: dim_1, dim_2
+  double precision, allocatable :: ERI_1(:,:,:)
+  double precision, allocatable :: ERI_2(:,:,:)
+
 ! Initialization
 
   rho1(:,:,:) = 0d0
@@ -44,11 +54,10 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1
 
   if(ispin == 1) then
 
-     !$OMP PARALLEL &
+    !$OMP PARALLEL DEFAULT(NONE)                                         &
-     !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) &
+    !$OMP          PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) &
-     !$OMP PRIVATE(q,p,ab,cd,kl,ij) &
+    !$OMP          SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2)
-     !$OMP DEFAULT(NONE)
+    !$OMP DO COLLAPSE(2)
-     !$OMP DO
 
      do q=nC+1,nBas-nR
         do p=nC+1,nBas-nR
@@ -113,8 +122,8 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1
 
         end do
      end do
-     !$OMP END DO
+    !$OMP END DO
-     !$OMP END PARALLEL
+    !$OMP END PARALLEL
   end if
 
 !----------------------------------------------
@@ -123,138 +132,265 @@ subroutine GTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho1
 
   if(ispin == 2 .or. ispin == 4) then
 
-    do q=nC+1,nBas-nR
+    dim_1 = (nBas - nO) * (nBas - nO - 1) / 2
-      do p=nC+1,nBas-nR
+    dim_2 = nO * (nO - 1) / 2
- 
+
-!       do ab=1,nVV
+    if((dim_1 .eq. 0) .or. (dim_2 .eq. 0)) then
-        ab = 0
+
-        do a=nO+1,nBas-nR
+      !$OMP PARALLEL DEFAULT(NONE)                                         &
-          do b=a+1,nBas-nR
+      !$OMP          PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) &
-          ab = ab + 1
+      !$OMP          SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2)
- 
+      !$OMP DO COLLAPSE(2)
-          cd = 0
+      do q = nC+1, nBas-nR
-          do c=nO+1,nBas-nR
+        do p = nC+1, nBas-nR
-            do d=c+1,nBas-nR
+   
-              cd = cd + 1
+          ab = 0
-              rho1(p,q,ab) = rho1(p,q,ab) & 
+  
-                           + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) 
+          do a = nO+1, nBas-nR
-            end do
+            do b = a+1, nBas-nR
-          end do
+  
- 
+            ab = ab + 1
-          kl = 0
+   
-          do k=nC+1,nO
+            cd = 0
-            do l=k+1,nO
+            do c = nO+1, nBas-nR
-              kl = kl + 1
+              do d = c+1, nBas-nR
-              rho1(p,q,ab) = rho1(p,q,ab) & 
+  
-                           + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) 
+                cd = cd + 1
-            end do
+  
-          end do
+                rho1(p,q,ab) = rho1(p,q,ab) & 
- 
+                             + (ERI(p,q,c,d) - ERI(p,q,d,c))*X1(cd,ab) 
-        end do
+              end do ! d
-        end do
+            end do ! c
- 
+   
-!       do ij=1,nOO
+            kl = 0
+            do k = nC+1, nO
+              do l = k+1, nO
+  
+                kl = kl + 1
+  
+                rho1(p,q,ab) = rho1(p,q,ab) & 
+                             + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y1(kl,ab) 
+              end do ! l
+            end do ! k 
+          end do ! b
+        end do ! a
+   
         ij = 0
-        do i=nC+1,nO
+        do i = nC+1, nO
-          do j=i+1,nO
+          do j = i+1, nO
-          ij = ij + 1
+  
- 
+            ij = ij + 1
+            
+            cd = 0
+            
+            do c = nO+1, nBas-nR
+              do d = c+1, nBas-nR
+            
+                cd = cd + 1
+            
+                rho2(p,q,ij) = rho2(p,q,ij) & 
+                             + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) 
+              end do ! d
+            end do ! c
+            
+            kl = 0
+            do k = nC+1, nO
+              do l = k+1, nO
+            
+                kl = kl + 1
+            
+                rho2(p,q,ij) = rho2(p,q,ij) & 
+                             + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) 
+              end do ! l
+            end do ! k
+          end do ! j
+        end do ! i
+      end do ! p
+    end do ! q
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    else
+
+      allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2))
+      ERI_1 = 0.d0
+      ERI_2 = 0.d0
+  
+      !$OMP PARALLEL DEFAULT(NONE)                     &
+      !$OMP          PRIVATE(p, q, c, d, cd, k, l, kl) &
+      !$OMP          SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI)
+      !$OMP DO COLLAPSE(2)
+      do q = nC+1, nBas-nR
+        do p = nC+1, nBas-nR
           cd = 0
-          do c=nO+1,nBas-nR
+          do c = nO+1, nBas-nR
-            do d=c+1,nBas-nR
+            do d = c+1, nBas-nR
               cd = cd + 1
-              rho2(p,q,ij) = rho2(p,q,ij) & 
+              ERI_1(p,q,cd) = ERI(p,q,c,d) - ERI(p,q,d,c)
-                           + (ERI(p,q,c,d) - ERI(p,q,d,c))*X2(cd,ij) 
+            enddo
-            end do
+          enddo
-          end do
- 
           kl = 0
-          do k=nC+1,nO
+          do k = nC+1, nO
-            do l=k+1,nO
+            do l = k+1, nO
               kl = kl + 1
-              rho2(p,q,ij) = rho2(p,q,ij) & 
+              ERI_2(p,q,kl) = ERI(p,q,k,l) - ERI(p,q,l,k)
-                           + (ERI(p,q,k,l) - ERI(p,q,l,k))*Y2(kl,ij) 
             end do
           end do
- 
+        enddo
-        end do
+      enddo
-        end do
+      !$OMP END DO
+      !$OMP END PARALLEL
+  
+      call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, &
+                 ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, &
+                 0.d0, rho1(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, &
+                 ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, &
+                 1.d0, rho1(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, &
+                 ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, &
+                 0.d0, rho2(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, &
+                 ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, &
+                 1.d0, rho2(1,1,1), nBas*nBas)
+  
+      deallocate(ERI_1, ERI_2)
 
-      end do
+    endif
-    end do
+  endif
-
-  end if
 
 !----------------------------------------------
 ! alpha-beta block
 !----------------------------------------------
 
   if(ispin == 3) then
-     
-     !$OMP PARALLEL &
-     !$OMP SHARED(nC,nBas,nR,nO,nVV,nOO,rho1,rho2,ERI,X1,Y1,X2,Y2) &
-     !$OMP PRIVATE(q,p,ab,cd,kl,ij,c,d,k,l) &
-     !$OMP DEFAULT(NONE)
-     !$OMP DO
-     
-     do q=nC+1,nBas-nR
-        do p=nC+1,nBas-nR
- 
-           ! do ab=1,nVV
-           ab = 0
-           do a=nO+1,nBas-nR
-              do b=nO+1,nBas-nR
-                 ab = ab + 1
- 
-                 cd = 0
-                 do c=nO+1,nBas-nR
-                    do d=nO+1,nBas-nR
-                       cd = cd + 1
-                       rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) 
-                    end do
-                 end do
- 
-                 kl = 0
-                 do k=nC+1,nO
-                    do l=nC+1,nO
-                       kl = kl + 1
-                       rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) 
-                    end do
-                 end do
- 
-              end do
-           end do
- 
-        ! do ij=1,nOO
-           ij = 0
-           do i=nC+1,nO
-              do j=nC+1,nO
-                 ij = ij + 1
-             
-                 cd = 0
-                 do c=nO+1,nBas-nR
-                    do d=nO+1,nBas-nR
-                       cd = cd + 1
-                       rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) 
-                    end do
-                 end do
- 
-                 kl = 0
-                 do k=nC+1,nO
-                    do l=nC+1,nO
-                       kl = kl + 1
-                       rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) 
-                    end do
-                 end do
- 
-              end do
-           end do
-       
-        end do
-     end do
-     !$OMP END DO
-     !$OMP END PARALLEL
 
-  end if
+    dim_1 = (nBas - nO) * (nBas - nO)
+    dim_2 = nO * nO
+
+    if((dim_1 .eq. 0) .or. (dim_2 .eq. 0)) then
+
+      !$OMP PARALLEL DEFAULT(NONE)                                         &
+      !$OMP          PRIVATE(p, q, a, b, ab, c, d, cd, i, j, ij, k, l, kl) &
+      !$OMP          SHARED(nC, nBas, nR, nO, rho1, rho2, ERI, X1, Y1, X2, Y2)
+      !$OMP DO COLLAPSE(2)
+       
+      do q = nC+1, nBas-nR
+        do p = nC+1, nBas-nR
+   
+          ab = 0
+          do a = nO+1, nBas-nR
+            do b = nO+1, nBas-nR
+  
+              ab = ab + 1
+   
+              cd = 0
+              do c = nO+1, nBas-nR
+                do d = nO+1, nBas-nR
+  
+                  cd = cd + 1
+  
+                  rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,c,d)*X1(cd,ab) 
+                end do
+              end do
+   
+              kl = 0
+              do k = nC+1, nO
+                do l = nC+1, nO
+  
+                  kl = kl + 1
+  
+                  rho1(p,q,ab) = rho1(p,q,ab) + ERI(p,q,k,l)*Y1(kl,ab) 
+                end do
+              end do
+            end do
+          end do
+   
+          ij = 0
+          do i = nC+1, nO
+            do j = nC+1, nO
+  
+              ij = ij + 1
+               
+              cd = 0
+              do c = nO+1, nBas-nR
+                do d = nO+1, nBas-nR
+  
+                  cd = cd + 1
+  
+                  rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,c,d)*X2(cd,ij) 
+                end do
+              end do
+   
+              kl = 0
+              do k = nC+1, nO
+                do l = nC+1, nO
+  
+                  kl = kl + 1
+  
+                  rho2(p,q,ij) = rho2(p,q,ij) + ERI(p,q,k,l)*Y2(kl,ij) 
+                end do
+              end do
+            end do
+          end do
+        end do
+      end do
+      !$OMP END DO
+      !$OMP END PARALLEL
+
+    else
+
+      allocate(ERI_1(nBas,nBas,dim_1), ERI_2(nBas,nBas,dim_2))
+      ERI_1 = 0.d0
+      ERI_2 = 0.d0
+  
+      !$OMP PARALLEL DEFAULT(NONE)                     &
+      !$OMP          PRIVATE(p, q, c, d, cd, k, l, kl) &
+      !$OMP          SHARED(nC, nBas, nR, nO, ERI_1, ERI_2, ERI)
+      !$OMP DO COLLAPSE(2)
+      do q = nC+1, nBas-nR
+        do p = nC+1, nBas-nR
+          cd = 0
+          do c = nO+1, nBas-nR
+            do d = nO+1, nBas-nR
+              cd = cd + 1
+              ERI_1(p,q,cd) = ERI(p,q,c,d)
+            enddo
+          enddo
+          kl = 0
+          do k = nC+1, nO
+            do l = nC+1, nO
+              kl = kl + 1
+              ERI_2(p,q,kl) = ERI(p,q,k,l)
+            end do
+          end do
+        enddo
+      enddo
+      !$OMP END DO
+      !$OMP END PARALLEL
+  
+      call dgemm("N", "N", nBas*nBas, dim_1, dim_1, 1.d0, &
+                 ERI_1(1,1,1), nBas*nBas, X1(1,1), dim_1, &
+                 0.d0, rho1(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_1, dim_2, 1.d0, &
+                 ERI_2(1,1,1), nBas*nBas, Y1(1,1), dim_2, &
+                 1.d0, rho1(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_2, dim_1, 1.d0, &
+                 ERI_1(1,1,1), nBas*nBas, X2(1,1), dim_1, &
+                 0.d0, rho2(1,1,1), nBas*nBas)
+  
+      call dgemm("N", "N", nBas*nBas, dim_2, dim_2, 1.d0, &
+                 ERI_2(1,1,1), nBas*nBas, Y2(1,1), dim_2, &
+                 1.d0, rho2(1,1,1), nBas*nBas)
+  
+      deallocate(ERI_1, ERI_2)
+
+    endif
+  endif
 
 end subroutine 

src/GT/RG0T0pp.f90

@@ -64,6 +64,7 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
   double precision,allocatable  :: eGT(:)
   double precision,allocatable  :: eGTlin(:)
 
+
 ! Output variables
 
 ! Hello world
@@ -122,9 +123,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 
   allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
 
+  call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp)
+  call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp)
   if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp)
-                 call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI,Cpp)
-                 call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI,Dpp)
 
   call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin))
 
@@ -145,9 +146,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 
   allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
 
+  call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp)
+  call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp)
   if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp)
-                 call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI,Cpp)
-                 call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI,Dpp)
 
   call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin))
 
@@ -162,10 +163,12 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 
 ! iblock = 1
   iblock = 3
+
   call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s)
 
 ! iblock = 2
   iblock = 4
+
   call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t)
 
 !----------------------------------------------
@@ -183,7 +186,7 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 !----------------------------------------------
 ! Solve the quasi-particle equation
 !----------------------------------------------
-  
+
   eGTlin(:) = eHF(:) + Z(:)*Sig(:)
 
   if(linearize) then
@@ -218,9 +221,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 
   allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
 
+  call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp)
+  call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp)
   if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp)
-                 call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp)
-                 call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp)
 
   call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin))
 
@@ -232,9 +235,9 @@ subroutine RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,d
 
   allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
 
+  call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp)
+  call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp)
   if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp)
-                 call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp)
-                 call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp)
 
   call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin))
 

src/GT/RGT.f90

@@ -1,7 +1,11 @@
-subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,maxSCF,thresh,max_diis, &
+
-               doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet,     &
+! ---
-               linearize,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,               &
+
-               ERI_AO,ERI_MO,dipole_int_AO,dipole_int,PHF,cHF,eHF)
+subroutine RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh, &
+               maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2,   &
+               doppBSE, TDA_T, TDA, dBSE, dTDA, singlet, triplet, linearize, eta, regularize,  &
+               nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T,  &
+               V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! T-matrix module
 
@@ -44,7 +48,7 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
@@ -52,18 +56,18 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
   integer,intent(in)            :: nS
 
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(in)   :: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 
 ! Local variables 
@@ -78,11 +82,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
     
     call wall_time(start_GT)
     call RG0T0pp(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, &
-                linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+                linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GT)
   
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0pp = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0T0pp = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -95,11 +99,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
     
     call wall_time(start_GT)
     call evRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet, &
-                 linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+                 linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GT)
   
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGTpp = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGTpp = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -111,13 +115,13 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
   if(doqsGTpp) then 
 
     call wall_time(start_GT)
-    call qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,dBSE,dTDA,singlet,triplet,       &
+    call qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA, dBSE, &
-                 eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int, & 
+                 dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO,  &
-                 PHF,cHF,eHF)
+                 nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GT)
 
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGTpp = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGTpp = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -129,11 +133,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
   if(doufG0T0pp) then
     
     call wall_time(start_GT)
-    call ufG0T0pp(dotest,TDA_T,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF)
+    call ufG0T0pp(dotest,TDA_T,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF)
     call wall_time(end_GT)
   
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0T0pp = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0T0pp = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -146,11 +150,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
     
     call wall_time(start_GT)
     call RG0T0eh(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE,singlet,triplet, &
-                 linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+                 linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GT)
   
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0eh = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0T0eh = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -163,11 +167,11 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
 
     call wall_time(start_GT)
     call evRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,doppBSE, &
-                 singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+                 singlet,triplet,linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GT)
 
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGTeh = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGTeh = ',t_GT,' seconds'
     write(*,*)
 
   end if
@@ -179,13 +183,14 @@ subroutine RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,do
   if(doqsGTeh) then 
 
     call wall_time(start_GT)
-    call qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA,dBSE,dTDA,singlet,triplet, &
+    call qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, &
-                 eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int,    & 
+                 dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc,  &
-                 PHF,cHF,eHF)
+                 ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, &
+                 Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GT)
 
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGTeh = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGTeh = ',t_GT,' seconds'
     write(*,*)
 
   end if

src/GT/print_qsRGTeh.f90

@@ -1,4 +1,8 @@
-subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole)
+
+! ---
+
+subroutine print_qsRGTeh(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, &
+                         Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole)
 
 ! Print one-electron energies and other stuff for qsGTeh
 
@@ -7,7 +11,7 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
 
 ! Input variables
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO
   integer,intent(in)                 :: nSCF
   double precision,intent(in)        :: ENuc
@@ -19,11 +23,11 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
   double precision,intent(in)        :: EcRPA(nspin)
   double precision,intent(in)        :: Conv
   double precision,intent(in)        :: thresh
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: eGT(nBas)
+  double precision,intent(in)        :: eGT(nOrb)
-  double precision,intent(in)        :: c(nBas)
+  double precision,intent(in)        :: c(nBas,nOrb)
-  double precision,intent(in)        :: SigC(nBas,nBas)
+  double precision,intent(in)        :: SigC(nOrb,nOrb)
-  double precision,intent(in)        :: Z(nBas)
+  double precision,intent(in)        :: Z(nOrb)
   double precision,intent(in)        :: EqsGT
   double precision,intent(in)        :: dipole(ncart)
 
@@ -58,7 +62,7 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
             '|','#','|','e_HF (eV)','|','Sig_GTeh (eV)','|','Z','|','e_GTeh (eV)','|'
   write(*,*)'-------------------------------------------------------------------------------'
 
-  do p=1,nBas
+  do p=1,nOrb
     write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') &
     '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|'
   end do
@@ -109,13 +113,13 @@ subroutine print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
       write(*,'(A50)') '---------------------------------------'
       write(*,'(A32)') ' qsGTeh MO coefficients'
       write(*,'(A50)') '---------------------------------------'
-      call matout(nBas,nBas,c)
+      call matout(nBas, nOrb, c)
       write(*,*)
     end if
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A32)') ' qsGTeh MO energies'
     write(*,'(A50)') '---------------------------------------'
-    call vecout(nBas,eGT)
+    call vecout(nOrb, eGT)
     write(*,*)
 
   end if

src/GT/print_qsRGTpp.f90

@@ -1,4 +1,8 @@
-subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole)
+
+! ---
+
+subroutine print_qsRGTpp(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, SigC, Z, &
+                         ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole)
 
 ! Print one-electron energies and other stuff for qsGT
 
@@ -7,7 +11,7 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
 
 ! Input variables
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO
   integer,intent(in)                 :: nSCF
   double precision,intent(in)        :: ENuc
@@ -19,11 +23,11 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
   double precision,intent(in)        :: EcRPA(nspin)
   double precision,intent(in)        :: Conv
   double precision,intent(in)        :: thresh
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: eGT(nBas)
+  double precision,intent(in)        :: eGT(nOrb)
-  double precision,intent(in)        :: c(nBas)
+  double precision,intent(in)        :: c(nBas,nOrb)
-  double precision,intent(in)        :: SigC(nBas,nBas)
+  double precision,intent(in)        :: SigC(nOrb,nOrb)
-  double precision,intent(in)        :: Z(nBas)
+  double precision,intent(in)        :: Z(nOrb)
   double precision,intent(in)        :: EqsGT
   double precision,intent(in)        :: dipole(ncart)
 
@@ -58,7 +62,7 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
             '|','#','|','e_HF (eV)','|','Sig_GTpp (eV)','|','Z','|','e_GTpp (eV)','|'
   write(*,*)'-------------------------------------------------------------------------------'
 
-  do p=1,nBas
+  do p=1,nOrb
     write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') &
     '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGT(p)*HaToeV,'|'
   end do
@@ -109,13 +113,13 @@ subroutine print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,SigC,Z,ENuc,ET,EV,EJ
       write(*,'(A50)') '---------------------------------------'
       write(*,'(A32)') ' qsGTpp MO coefficients'
       write(*,'(A50)') '---------------------------------------'
-      call matout(nBas,nBas,c)
+      call matout(nBas, nOrb, c)
       write(*,*)
     end if
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A32)') ' qsGTpp MO energies'
     write(*,'(A50)') '---------------------------------------'
-    call vecout(nBas,eGT)
+    call vecout(nOrb, eGT)
     write(*,*)
 
   end if

src/GT/qsRGTeh.f90

@@ -1,6 +1,10 @@
-subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_T,TDA, & 
+
-                   dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,  &
+! ---
-                   S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+
+subroutine qsRGTeh(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, &
+                   dophBSE2, TDA_T, TDA, dBSE, dTDA, singlet, triplet, eta, regularize, nNuc,  &
+                   ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, &
+                   Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Perform a quasiparticle self-consistent GTeh calculation
 
@@ -33,31 +37,31 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   integer,intent(in)            :: nS
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
   logical                       :: dRPA = .false.
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: ispin
   integer                       :: n_diis
   double precision              :: ET
@@ -113,7 +117,7 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
 ! Stuff 
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! TDA for T
 
@@ -131,9 +135,29 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
 ! Memory allocation
 
-  allocate(Aph(nS,nS),Bph(nS,nS),eGT(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), &
+  allocate(Aph(nS,nS), Bph(nS,nS), Om(nS), XpY(nS,nS), XmY(nS,nS))
-           J(nBas,nBas),K(nBas,nBas),Sig(nBas,nBas),Sigp(nBas,nBas),Z(nBas),Om(nS),XpY(nS,nS),XmY(nS,nS), & 
+
-           rhoL(nBas,nBas,nS),rhoR(nBas,nBas,nS),err(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(eGT(nOrb))
+  allocate(eOld(nOrb))
+  allocate(Z(nOrb))
+
+  allocate(c(nBas,nOrb))
+
+  allocate(cp(nOrb,nOrb))
+  allocate(Fp(nOrb,nOrb))
+  allocate(Sig(nOrb,nOrb))
+
+  allocate(P(nBas,nBas))
+  allocate(F(nBas,nBas))
+  allocate(J(nBas,nBas))
+  allocate(K(nBas,nBas))
+  allocate(Sigp(nBas,nBas))
+  allocate(err(nBas,nBas))
+
+  allocate(err_diis(nBas_Sq,max_diis), F_diis(nBas_Sq,max_diis))
+
+  allocate(rhoL(nOrb,nOrb,nS), rhoR(nOrb,nOrb,nS))
+
 
 ! Initialization
   
@@ -169,12 +193,12 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     ! AO to MO transformation of two-electron integrals
 
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
     ! Compute linear response
 
-    call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph)
+    call phLR_A(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,eGT,ERI_MO,Aph)
-    if(.not.TDA_T) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
+    if(.not.TDA_T) call phLR_B(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
 
     call phLR(TDA_T,nS,Aph,Bph,EcRPA,Om,XpY,XmY)
 
@@ -182,21 +206,25 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     ! Compute correlation part of the self-energy 
 
-    call GTeh_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR)
+    call GTeh_excitation_density(nOrb,nC,nO,nR,nS,ERI_MO,XpY,XmY,rhoL,rhoR)
 
-    if(regularize) call GTeh_regularization(nBas,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR)
+    if(regularize) call GTeh_regularization(nOrb,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR)
 
-    call GTeh_self_energy(eta,nBas,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z)
+    call GTeh_self_energy(eta,nOrb,nC,nO,nV,nR,nS,eGT,Om,rhoL,rhoR,EcGM,Sig,Z)
 
     ! Make correlation self-energy Hermitian and transform it back to AO basis
    
     Sig = 0.5d0*(Sig + transpose(Sig))
 
-    call MOtoAO(nBas,S,c,Sig,Sigp)
+    call MOtoAO(nBas, nOrb, S, c, Sig, Sigp)
  
     ! Solve the quasi-particle equation
 
     F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + Sigp(:,:)
+    if(nBas .ne. nOrb) then
+      call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1))
+      call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1))
+    endif
 
     ! Compute commutator and convergence criteria
 
@@ -207,17 +235,23 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
     if(max_diis > 1) then
 
       n_diis = min(n_diis+1,max_diis)
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,F)
 
     end if
 
     ! Diagonalize Hamiltonian in AO basis
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    if(nBas .eq. nOrb) then
-    cp(:,:) = Fp(:,:)
+      Fp = matmul(transpose(X), matmul(F, X))
-    call diagonalize_matrix(nBas,cp,eGT)
+      cp(:,:) = Fp(:,:)
-    c = matmul(X,cp)
+      call diagonalize_matrix(nOrb, cp, eGT)
-    Sigp = matmul(transpose(c),matmul(Sigp,c))
+      c = matmul(X, cp)
+    else
+      Fp = matmul(transpose(c), matmul(F, c))
+      cp(:,:) = Fp(:,:)
+      call diagonalize_matrix(nOrb, cp, eGT)
+      c = matmul(c, cp)
+    endif
 
     ! Compute new density matrix in the AO basis
 
@@ -255,7 +289,8 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
     ! Print results
 
     call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole)
-    call print_qsRGTeh(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,Sigp,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole)
+    call print_qsRGTeh(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGT, c, Sig, &
+                       Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGT, dipole)
 
   end do
 !------------------------------------------------------------------------
@@ -272,13 +307,15 @@ subroutine qsRGTeh(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, Om, XpY, XmY, rhoL, rhoR, err, err_diis, F_diis)
+
     stop
 
   end if
 
 ! Deallocate memory
 
-  deallocate(c,cp,P,F,Fp,J,K,Sig,Sigp,Z,Om,XpY,XmY,rhoL,rhoR,err,err_diis,F_diis)
+  deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, Om, XpY, XmY, rhoL, rhoR, err, err_diis, F_diis)
 
 ! Perform BSE calculation
 

src/GT/qsRGTpp.f90

@@ -1,6 +1,9 @@
-subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,TDA_T,TDA,          & 
+
-                   dBSE,dTDA,singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, &
+! ---
-                   S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+
+subroutine qsRGTpp(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, TDA_T, TDA,    &
+                   dBSE, dTDA, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, &
+                   nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Perform a quasiparticle self-consistent GT calculation
 
@@ -31,25 +34,26 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas,nC,nO,nV,nR,nS
+  integer,intent(in)            :: nBas, nOrb
+  integer,intent(in)            :: nC,nO,nV,nR,nS
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: ispin
   integer                       :: iblock
   integer                       :: n_diis
@@ -119,7 +123,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
 ! Stuff 
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! TDA for T
 
@@ -137,16 +141,30 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
 ! Memory allocation
 
-  allocate(eGT(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), &
+  allocate(eGT(nOrb))
-           J(nBas,nBas),K(nBas,nBas),Sig(nBas,nBas),Sigp(nBas,nBas),Z(nBas),        & 
+  allocate(eOld(nOrb))
-           error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(Z(nOrb))
 
-  allocate(Om1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),    &
+  allocate(c(nBas,nOrb))
-           Om2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs),    &
+
-           rho1s(nBas,nBas,nVVs),rho2s(nBas,nBas,nOOs), &
+  allocate(Fp(nOrb,nOrb))
-           Om1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),    &
+  allocate(cp(nOrb,nOrb))
-           Om2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt),    &
+  allocate(Sig(nOrb,nOrb))
-           rho1t(nBas,nBas,nVVt),rho2t(nBas,nBas,nOOt))
+
+  allocate(P(nBas,nBas))
+  allocate(F(nBas,nBas))
+  allocate(J(nBas,nBas))
+  allocate(K(nBas,nBas))
+  allocate(error(nBas,nBas))
+  allocate(Sigp(nBas,nBas))
+
+  allocate(error_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
+
+  allocate(Om1s(nVVs), X1s(nVVs,nVVs), Y1s(nOOs,nVVs), rho1s(nOrb,nOrb,nVVs))
+  allocate(Om2s(nOOs), X2s(nVVs,nOOs), Y2s(nOOs,nOOs), rho2s(nOrb,nOrb,nOOs))
+  allocate(Om1t(nVVt), X1t(nVVt,nVVt), Y1t(nOOt,nVVt), rho1t(nOrb,nOrb,nVVt))
+  allocate(Om2t(nOOt), X2t(nVVt,nOOt), Y2t(nOOt,nOOt), rho2t(nOrb,nOrb,nOOt))
 
 ! Initialization
   
@@ -182,7 +200,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     ! AO to MO transformation of two-electron integrals
 
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
     ! Compute linear response
 
@@ -191,9 +209,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
 
-    if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp)
+    call ppLR_C(iblock,nOrb,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp)
-                   call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp)
+    call ppLR_D(iblock,nOrb,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp)
-                   call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp)
+    if(.not.TDA_T) call ppLR_B(iblock,nOrb,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp)
 
     call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin))
 
@@ -204,9 +222,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
 
-    if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp)
+    call ppLR_C(iblock,nOrb,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp)
-                   call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp)
+    call ppLR_D(iblock,nOrb,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp)
-                   call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp)
+    if(.not.TDA_T) call ppLR_B(iblock,nOrb,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp)
 
     call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin))
 
@@ -217,29 +235,33 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     ! Compute correlation part of the self-energy 
 
-    iblock =  3
+    iblock = 3
-    call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s)
+    call GTpp_excitation_density(iblock,nOrb,nC,nO,nV,nR,nOOs,nVVs,ERI_MO,X1s,Y1s,rho1s,X2s,Y2s,rho2s)
 
-    iblock =  4
+    iblock = 4
-    call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t)
+    call GTpp_excitation_density(iblock,nOrb,nC,nO,nV,nR,nOOt,nVVt,ERI_MO,X1t,Y1t,rho1t,X2t,Y2t,rho2t)
 
     if(regularize) then 
-      call GTpp_regularization(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s)
+      call GTpp_regularization(eta,nOrb,nC,nO,nV,nR,nOOs,nVVs,eGT,Om1s,rho1s,Om2s,rho2s)
-      call GTpp_regularization(eta,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t)
+      call GTpp_regularization(eta,nOrb,nC,nO,nV,nR,nOOt,nVVt,eGT,Om1t,rho1t,Om2t,rho2t)
     end if 
 
-    call GTpp_self_energy(eta,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & 
+    call GTpp_self_energy(eta,nOrb,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,eGT,Om1s,rho1s,Om2s,rho2s, & 
                           Om1t,rho1t,Om2t,rho2t,EcGM,Sig,Z)
 
     ! Make correlation self-energy Hermitian and transform it back to AO basis
    
     Sig = 0.5d0*(Sig + transpose(Sig))
 
-    call MOtoAO(nBas,S,c,Sig,Sigp)
+    call MOtoAO(nBas, nOrb, S, c, Sig, Sigp)
  
     ! Solve the quasi-particle equation
 
     F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + Sigp(:,:)
+    if(nBas .ne. nOrb) then
+      call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1))
+      call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1))
+    endif
 
     ! Compute commutator and convergence criteria
 
@@ -249,22 +271,28 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
     n_diis = min(n_diis+1,max_diis)
     if(abs(rcond) > 1d-7) then 
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F)
     else
       n_diis = 0
     end if
 
     ! Diagonalize Hamiltonian in AO basis
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    if(nBas .eq. nOrb) then
-    cp(:,:) = Fp(:,:)
+      Fp = matmul(transpose(X), matmul(F, X))
-    call diagonalize_matrix(nBas,cp,eGT)
+      cp(:,:) = Fp(:,:)
-    c = matmul(X,cp)
+      call diagonalize_matrix(nOrb, cp, eGT)
-    Sigp = matmul(transpose(c),matmul(Sigp,c))
+      c = matmul(X, cp)
+    else
+      Fp = matmul(transpose(c), matmul(F, c))
+      cp(:,:) = Fp(:,:)
+      call diagonalize_matrix(nOrb, cp, eGT)
+      c = matmul(c, cp)
+    endif
 
     ! Compute new density matrix in the AO basis
 
-    P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
+    P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO)))
 
     ! Save quasiparticles energy for next cycle
 
@@ -298,7 +326,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
     ! Print results
 
     call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole)
-    call print_qsRGTpp(nBas,nO,nSCF,Conv,thresh,eHF,eGT,c,Sigp,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGT,dipole)
+    call print_qsRGTpp(nBas, nOrb, nO, nSCF, Conv, thresh, eHF,   &
+                       eGT, c, Sig, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, &
+                       EqsGT, dipole)
 
   end do
 !------------------------------------------------------------------------
@@ -315,19 +345,24 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, error, error_diis, F_diis)
+    deallocate(Om1s, X1s, Y1s, rho1s)
+    deallocate(Om2s, X2s, Y2s, rho2s)
+    deallocate(Om1t, X1t, Y1t, rho1t)
+    deallocate(Om2t, X2t, Y2t, rho2t)
     stop
 
   end if
 
 ! Deallocate memory
 
-  deallocate(c,cp,P,F,Fp,J,K,Sig,Sigp,Z,error,error_diis,F_diis)
+  deallocate(c, cp, P, F, Fp, J, K, Sig, Sigp, Z, error, error_diis, F_diis)
 
 ! Perform BSE calculation
 
   if(dophBSE) then
 
-    call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt,   &
+    call GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nOrb,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, &
                     Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t,Om2t,X2t,Y2t,rho1t,rho2t, &
                     ERI_MO,dipole_int_MO,eGT,eGT,EcBSE)
 
@@ -363,7 +398,7 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
       end if
 
-      call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS, &
+      call GTpp_phACFDT(exchange_kernel,doXBS,.false.,TDA_T,TDA,dophBSE,singlet,triplet,eta,nOrb,nC,nO,nV,nR,nS, &
                         nOOs,nVVs,nOOt,nVVt,Om1s,X1s,Y1s,Om2s,X2s,Y2s,rho1s,rho2s,Om1t,X1t,Y1t,     &
                         Om2t,X2t,Y2t,rho1t,rho2t,ERI_MO,eGT,eGT,EcBSE)
 
@@ -391,4 +426,9 @@ subroutine qsRGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,d
 
   end if
 
+  deallocate(Om1s, X1s, Y1s, rho1s)
+  deallocate(Om2s, X2s, Y2s, rho2s)
+  deallocate(Om1t, X1t, Y1t, rho1t)
+  deallocate(Om2t, X2t, Y2t, rho2t)
+
 end subroutine 

src/GT/qsUGTpp.f90

@@ -280,7 +280,7 @@ subroutine qsUGTpp(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,B
     end do
 
     do ispin=1,nspin
-      call MOtoAO(nBas,S,c(:,:,ispin),SigT(:,:,ispin),SigTp(:,:,ispin))
+      call MOtoAO(nBas,nBas,S,c(:,:,ispin),SigT(:,:,ispin),SigTp(:,:,ispin))
     end do
 
 ! Solve the quasi-particle equation

src/GW/GW_ppBSE.f90

@@ -66,6 +66,7 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,
 
   double precision,intent(out)  :: EcBSE(nspin)
 
+
 !---------------------------------
 ! Compute (singlet) RPA screening 
 !---------------------------------
@@ -76,10 +77,12 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,
   allocate(OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS), &
            Aph(nS,nS),Bph(nS,nS))
  
-                 call phLR_A(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,eW,ERI,Aph)
+  call phLR_A(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,eW,ERI,Aph)
+
   if(.not.TDA_W) call phLR_B(isp_W,dRPA_W,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph)
 
   call phLR(TDA_W,nS,Aph,Bph,EcRPA,OmRPA,XpY_RPA,XmY_RPA)
+
   call GW_excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA)
 
   deallocate(XpY_RPA,XmY_RPA,Aph,Bph)
@@ -108,13 +111,13 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,
 
     ! Compute BSE excitation energies
 
+    call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta)
+    call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta)
     if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta)
-                 call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta)
-                 call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta)
 
+    call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
+    call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
     if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp)
-                 call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
-                 call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
 
     Bpp(:,:) = Bpp(:,:) + KB_sta(:,:)
     Cpp(:,:) = Cpp(:,:) + KC_sta(:,:)
@@ -131,9 +134,9 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,
     if(dBSE) &
         call GW_ppBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,eW,eGW,ERI,dipole_int,OmRPA,rho_RPA, &
                                            Om1,X1,Y1,Om2,X2,Y2,KB_sta,KC_sta,KD_sta)
-    write(*,*) "Deallocate not done"
+
+
     deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,KB_sta,KC_sta,KD_sta)
-    write(*,*) "Deallocate done"
   end if
 
 !-------------------
@@ -160,14 +163,13 @@ subroutine GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,
 
     ! Compute BSE excitation energies
 
+    call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta)
+    call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta)
     if(.not.TDA) call GW_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,KB_sta)
-                 call GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,1d0,ERI,OmRPA,rho_RPA,KC_sta)
-                 call GW_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,1d0,ERI,OmRPA,rho_RPA,KD_sta)
-
 
+    call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
+    call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
     if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp)
-                 call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
-                 call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
 
     Bpp(:,:) = Bpp(:,:) + KB_sta(:,:)
     Cpp(:,:) = Cpp(:,:) + KC_sta(:,:)

src/GW/GW_ppBSE_static_kernel_C.f90

@@ -26,44 +26,186 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI
   double precision,external     :: Kronecker_delta
   double precision              :: chi
   double precision              :: eps
+  double precision              :: tmp_ab, lambda4, eta2
   integer                       :: a,b,c,d,ab,cd,m
+  integer                       :: a0, aa
+
+  double precision, allocatable :: Om_tmp(:)
+  double precision, allocatable :: tmp_m(:,:,:)
+  double precision, allocatable :: tmp(:,:,:,:)
 
 ! Output variables
 
   double precision,intent(out)  :: KC(nVV,nVV)
 
-! Initialization
-
-  KC(:,:) = 0d0
-
 !---------------!
 ! Singlet block !
 !---------------!
 
   if(ispin == 1) then
 
-    ab = 0
+    a0 = nBas - nR - nO
-    do a=nO+1,nBas-nR
+    lambda4 = 4.d0 * lambda
-      do b=a,nBas-nR
+    eta2 = eta * eta
-        ab = ab + 1
+
+    allocate(tmp_m(nBas,nBas,nS))
+    allocate(tmp(nBas,nBas,nBas,nBas))
+
+    !$OMP PARALLEL DEFAULT(NONE)         &
+    !$OMP          PRIVATE(m, c, a, eps) &
+    !$OMP          SHARED(nS, nBas, eta2, Om, rho, tmp_m)
+    !$OMP DO
+    do m = 1, nS
+      eps = Om(m) / (Om(m)*Om(m) + eta2)
+      do c = 1, nBas
+        do a = 1, nBas
+          tmp_m(a,c,m) = eps * rho(a,c,m)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0,       &
+               tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, &
+               0.d0, tmp(1,1,1,1), nBas*nBas)
+
+    deallocate(tmp_m)
+
+    !$OMP PARALLEL DEFAULT(NONE)                           &
+    !$OMP          PRIVATE(a, b, aa, ab, c, d, cd, tmp_ab) &
+    !$OMP          SHARED(nO, nBas, nR, nS, a0, lambda4, tmp, KC)
+    !$OMP DO
+    do a = nO+1, nBas-nR
+      aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO
+      do b = a, nBas-nR
+        ab = aa + b
+
+        tmp_ab = lambda4
+        if(a .eq. b) then
+          tmp_ab = 0.7071067811865475d0 * lambda4
+        endif
+
         cd = 0
-        do c=nO+1,nBas-nR
+        do c = nO+1, nBas-nR
-          do d=c,nBas-nR
+          do d = c, nBas-nR
             cd = cd + 1
 
-              chi = 0d0
+            KC(ab,cd) = -tmp_ab * (tmp(a,c,b,d) + tmp(a,d,b,c))
-              do m=1,nS
+            if(c .eq. d) then
-                eps = Om(m)**2 + eta**2
+              KC(ab,cd) = 0.7071067811865475d0 * KC(ab,cd)
-                chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps &
+            endif
-                          - rho(a,d,m)*rho(b,c,m)*Om(m)/eps
+          enddo
-              end do
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
 
-              KC(ab,cd) = 4d0*lambda*chi/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d)))
+    deallocate(tmp)
 
-          end do
+
-        end do
+!    do a=nO+1,nBas-nR
-      end do
+!      do b=a,nBas-nR
-    end do
+!        ab = ab + 1
+!        cd = 0
+!        do c=nO+1,nBas-nR
+!          do d=c,nBas-nR
+!            cd = cd + 1
+!
+!              chi = 0d0
+!              do m=1,nS
+!                eps = Om(m)**2 + eta**2
+!                chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps &
+!                          - rho(a,d,m)*rho(b,c,m)*Om(m)/eps
+!              end do
+
+
+!    --- --- ---
+!    OpenMP implementation
+!    --- --- ---
+!
+!    a0 = nBas - nR - nO
+!    lambda4 = 4.d0 * lambda
+!    eta2 = eta * eta
+!
+!    allocate(Om_tmp(nS))
+!
+!    !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp)
+!    !$OMP DO
+!    do m = 1, nS
+!      Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2)
+!    enddo
+!    !$OMP END DO
+!    !$OMP END PARALLEL
+!
+!    !$OMP PARALLEL DEFAULT(NONE)                              &
+!    !$OMP          PRIVATE(a, b, aa, ab, c, d, cd, m, tmp_ab) &
+!    !$OMP          SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC)
+!    !$OMP DO
+!    do a = nO+1, nBas-nR
+!      aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO
+!      do b = a, nBas-nR
+!        ab = aa + b
+!
+!        tmp_ab = lambda4
+!        if(a .eq. b) then
+!          tmp_ab = 0.7071067811865475d0 * lambda4
+!        endif
+!
+!        cd = 0
+!        do c = nO+1, nBas-nR
+!          do d = c, nBas-nR
+!            cd = cd + 1
+!
+!            KC(ab,cd) = 0d0
+!            do m = 1, nS
+!              KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) &
+!                                    - rho(a,d,m) * rho(b,c,m) * Om_tmp(m)
+!            end do
+!
+!            KC(ab,cd) = tmp_ab * KC(ab,cd)
+!            if(c .eq. d) then
+!              KC(ab,cd) = 0.7071067811865475d0 * KC(ab,cd)
+!            endif
+!          enddo
+!        enddo
+!      enddo
+!    enddo
+!    !$OMP END DO
+!    !$OMP END PARALLEL
+!
+!    deallocate(Om_tmp)
+!    --- --- ---
+
+
+!    --- --- ---
+!    Naive implementation
+!    --- --- ---
+!
+!    ab = 0
+!    do a=nO+1,nBas-nR
+!      do b=a,nBas-nR
+!        ab = ab + 1
+!        cd = 0
+!        do c=nO+1,nBas-nR
+!          do d=c,nBas-nR
+!            cd = cd + 1
+!
+!              chi = 0d0
+!              do m=1,nS
+!                eps = Om(m)**2 + eta**2
+!                chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps &
+!                          - rho(a,d,m)*rho(b,c,m)*Om(m)/eps
+!              end do
+!
+!              KC(ab,cd) = 4d0*lambda*chi/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d)))
+!
+!          end do
+!        end do
+!      end do
+!    end do
+!    --- --- ---
 
   end if
 
@@ -73,28 +215,136 @@ subroutine GW_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nS,nVV,lambda,ERI
 
   if(ispin == 2) then
 
-    ab = 0
+    a0 = nBas - nR - nO - 1
-    do a=nO+1,nBas-nR
+    lambda4 = 4.d0 * lambda
-      do b=a+1,nBas-nR
+    eta2 = eta * eta
-        ab = ab + 1
+
+    allocate(tmp_m(nBas,nBas,nS))
+    allocate(tmp(nBas,nBas,nBas,nBas))
+
+    !$OMP PARALLEL DEFAULT(NONE)         &
+    !$OMP          PRIVATE(m, c, a, eps) &
+    !$OMP          SHARED(nS, nBas, eta2, Om, rho, tmp_m)
+    !$OMP DO
+    do m = 1, nS
+      eps = Om(m) / (Om(m)*Om(m) + eta2)
+      do c = 1, nBas
+        do a = 1, nBas
+          tmp_m(a,c,m) = eps * rho(a,c,m)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    call dgemm("N", "T", nBas*nBas, nBas*nBas, nS, 1.d0,       &
+               tmp_m(1,1,1), nBas*nBas, rho(1,1,1), nBas*nBas, &
+               0.d0, tmp(1,1,1,1), nBas*nBas)
+
+    deallocate(tmp_m)
+
+    !$OMP PARALLEL DEFAULT(NONE)                   &
+    !$OMP          PRIVATE(a, b, aa, ab, c, d, cd) &
+    !$OMP          SHARED(nO, nBas, nR, nS, a0, lambda4, tmp, KC)
+    !$OMP DO
+    do a = nO+1, nBas-nR
+      aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1
+      do b = a+1, nBas-nR
+        ab = aa + b
+
         cd = 0
-        do c=nO+1,nBas-nR
+        do c = nO+1, nBas-nR
-          do d=c+1,nBas-nR
+          do d = c+1, nBas-nR
             cd = cd + 1
 
-            chi = 0d0
+            KC(ab,cd) = lambda4 * (-tmp(a,c,b,d) + tmp(a,d,b,c))
-            do m=1,nS
+          enddo
-              eps = Om(m)**2 + eta**2
+        enddo
-              chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps &
+      enddo
-                        + rho(a,d,m)*rho(b,c,m)*Om(m)/eps
+    enddo
-            end do
+    !$OMP END DO
-           
+    !$OMP END PARALLEL
-            KC(ab,cd) = 4d0*lambda*chi
 
-          end do
+    deallocate(tmp)
-        end do
+
-      end do
+
-    end do
+!    --- --- ---
+!    OpenMP implementation
+!    --- --- ---
+!
+!    a0 = nBas - nR - nO - 1
+!    lambda4 = 4.d0 * lambda
+!    eta2 = eta * eta
+!
+!    allocate(Om_tmp(nS))
+!
+!    !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m) SHARED(nS, eta2, Om, Om_tmp)
+!    !$OMP DO
+!    do m = 1, nS
+!      Om_tmp(m) = Om(m) / (Om(m)*Om(m) + eta2)
+!    enddo
+!    !$OMP END DO
+!    !$OMP END PARALLEL
+!
+!    !$OMP PARALLEL DEFAULT(NONE)                      &
+!    !$OMP          PRIVATE(a, b, aa, ab, c, d, cd, m) &
+!    !$OMP          SHARED(nO, nBas, nR, nS, a0, lambda4, Om_tmp, rho, KC)
+!    !$OMP DO
+!    do a = nO+1, nBas-nR
+!      aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1
+!      do b = a+1, nBas-nR
+!        ab = aa + b
+!
+!        cd = 0
+!        do c = nO+1, nBas-nR
+!          do d = c+1, nBas-nR
+!            cd = cd + 1
+!
+!            KC(ab,cd) = 0d0
+!            do m = 1, nS
+!              KC(ab,cd) = KC(ab,cd) - rho(a,c,m) * rho(b,d,m) * Om_tmp(m) &
+!                                    + rho(a,d,m) * rho(b,c,m) * Om_tmp(m)
+!            end do
+!
+!            KC(ab,cd) = lambda4 * KC(ab,cd)
+!          enddo
+!        enddo
+!      enddo
+!    enddo
+!    !$OMP END DO
+!    !$OMP END PARALLEL
+!
+!    deallocate(Om_tmp)
+!    --- --- ---
+
+
+!    --- --- ---
+!    Naive implementation
+!    --- --- ---
+!
+!    ab = 0
+!    do a=nO+1,nBas-nR
+!      do b=a+1,nBas-nR
+!        ab = ab + 1
+!        cd = 0
+!        do c=nO+1,nBas-nR
+!          do d=c+1,nBas-nR
+!            cd = cd + 1
+!
+!            chi = 0d0
+!            do m=1,nS
+!              eps = Om(m)**2 + eta**2
+!              chi = chi - rho(a,c,m)*rho(b,d,m)*Om(m)/eps &
+!                        + rho(a,d,m)*rho(b,c,m)*Om(m)/eps
+!            end do
+!           
+!            KC(ab,cd) = 4d0*lambda*chi
+!
+!          end do
+!        end do
+!      end do
+!    end do
+!    --- --- ---
 
   end if
 

src/GW/RG0W0.f90

@@ -59,6 +59,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA
   double precision,allocatable  :: eGWlin(:)
   double precision,allocatable  :: eGW(:)
 
+
 ! Output variables
 
 ! Hello world
@@ -101,7 +102,8 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA
 ! Compute screening !
 !-------------------!
 
-                 call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph)
+  call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Aph)
+
   if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph)
 
   call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY)
@@ -159,6 +161,7 @@ subroutine RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA
 ! Compute the RPA correlation energy
 
   call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI,Aph)
+
   if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI,Bph)
 
   call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY)

src/GW/RGW.f90

@@ -1,7 +1,10 @@
-subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thresh,max_diis,doACFDT, &
+
-               exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet,   &
+! ---
-               linearize,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,     & 
+
-               ERI_AO,ERI_MO,dipole_int_AO,dipole_int,PHF,cHF,eHF)
+subroutine RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF, thresh, max_diis, doACFDT,   &
+               exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet,     &
+               linearize, eta, regularize, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, &
+               S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Restricted GW module
 
@@ -43,7 +46,7 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
@@ -51,18 +54,18 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   integer,intent(in)            :: nS
 
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(in)   :: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
+  double precision,intent(in)   :: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
@@ -76,11 +79,11 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
     
     call wall_time(start_GW)
     call RG0W0(dotest,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE,singlet,triplet, &
-               linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+               linearize,eta,regularize,nOrb,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GW)
   
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for G0W0 = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -93,11 +96,11 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
 
     call wall_time(start_GW)
     call evRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, &
-               singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int,eHF)
+               singlet,triplet,linearize,eta,regularize,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF)
     call wall_time(end_GW)
 
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for evGW = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for evGW = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -109,13 +112,14 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   if(doqsGW) then 
 
     call wall_time(start_GW)
-    call qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & 
+    call qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, &
-               singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,     & 
+               TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, &
-               dipole_int_AO,dipole_int,PHF,cHF,eHF)
+               ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO,   &
+               dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GW)
 
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGW = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -127,13 +131,15 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   if(doSRGqsGW) then 
 
     call wall_time(start_GW)
-    call SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA, & 
+    call SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS,  &
-                  singlet,triplet,eta,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,        & 
+                  dophBSE, dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta,   &
-                  dipole_int_AO,dipole_int,PHF,cHF,eHF)
+                  nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS,     &
+                  ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, &
+                  PHF, cHF, eHF)
     call wall_time(end_GW)
 
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGW = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for qsGW = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -145,11 +151,12 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   if(doufG0W0) then
     
     call wall_time(start_GW)
+    ! TODO
     call ufG0W0(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF)
     call wall_time(end_GW)
   
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufG0W0 = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufG0W0 = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -161,11 +168,12 @@ subroutine RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF,thre
   if(doufGW) then
     
     call wall_time(start_GW)
+    ! TODO
     call ufGW(dotest,TDA_W,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,eHF)
     call wall_time(end_GW)
   
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ufGW = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ufGW = ',t_GW,' seconds'
     write(*,*)
 
   end if

src/GW/SRG_qsGW.f90

@@ -1,6 +1,10 @@
-subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE,BSE2,TDA_W,TDA,          & 
+
-                    dBSE,dTDA,singlet,triplet,eta,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, &
+! ---
-                    S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+
+subroutine SRG_qsGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, &
+                    BSE, BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nNuc,    &
+                    ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, &
+                    X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Perform a quasiparticle self-consistent GW calculation
 
@@ -32,30 +36,30 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   integer,intent(in)            :: nS
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: ispin
   integer                       :: ixyz
   integer                       :: n_diis
@@ -114,7 +118,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
 ! Stuff 
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! TDA for W
 
@@ -132,9 +136,32 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
 ! Memory allocation
 
-  allocate(eGW(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas),  &
+  allocate(eGW(nOrb))
-           J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),Z(nBas),Aph(nS,nS),Bph(nS,nS), & 
+  allocate(eOld(nOrb))
-           Om(nS),XpY(nS,nS),XmY(nS,nS),rho(nBas,nBas,nS),error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(Z(nOrb))
+
+  allocate(c(nBas,nOrb))
+
+  allocate(cp(nOrb,nOrb))
+  allocate(Fp(nOrb,nOrb))
+  allocate(SigC(nOrb,nOrb))
+
+  allocate(P(nBas,nBas))
+  allocate(F(nBas,nBas))
+  allocate(J(nBas,nBas))
+  allocate(K(nBas,nBas))
+  allocate(error(nBas,nBas))
+  allocate(SigCp(nBas,nBas))
+
+  allocate(Aph(nS,nS))
+  allocate(Bph(nS,nS))
+  allocate(Om(nS))
+  allocate(XpY(nS,nS))
+  allocate(XmY(nS,nS))
+  allocate(rho(nOrb,nOrb,nS))
+
+  allocate(error_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
 
 ! Initialization
   
@@ -174,22 +201,22 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
     call wall_time(tao1)
     
-    do ixyz=1,ncart             
+    do ixyz = 1, ncart
-      call AOtoMO(nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz))
+      call AOtoMO(nBas, nOrb, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz))
     end do  
 
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
     call wall_time(tao2)
 
-    tao = tao + tao2 -tao1
+    tao = tao + tao2 - tao1
 
     ! Compute linear response
 
     call wall_time(tlr1)
 
-    call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph)
+    call phLR_A(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph)
-    if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
+    if(.not.TDA_W) call phLR_B(ispin,dRPA,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
 
     call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY)
 
@@ -203,13 +230,13 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
     call wall_time(tex1)
     
-    call GW_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,rho)
+    call GW_excitation_density(nOrb,nC,nO,nR,nS,ERI_MO,XpY,rho)
 
     call wall_time(tex2)
     tex=tex+tex2-tex1
 
     call wall_time(tsrg1)
-    call SRG_self_energy(flow,nBas,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z)
+    call SRG_self_energy(flow,nOrb,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z)
 
     call wall_time(tsrg2)
 
@@ -218,7 +245,7 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
     ! Make correlation self-energy Hermitian and transform it back to AO basis
 
     call wall_time(tmo1)
-    call MOtoAO(nBas,S,c,SigC,SigCp)
+    call MOtoAO(nBas, nOrb, S, c, SigC, SigCp)
     call wall_time(tmo2)
     tmo = tmo + tmo2 - tmo1
    ! Solve the quasi-particle equation
@@ -234,18 +261,18 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
     if(max_diis > 1) then
 
       n_diis = min(n_diis+1,max_diis)
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,error_diis,F_diis,error,F)
 
     end if
 
     ! Diagonalize Hamiltonian in AO basis
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    Fp = matmul(transpose(X), matmul(F, X))
     cp(:,:) = Fp(:,:)
-    call diagonalize_matrix(nBas,cp,eGW)
+    call diagonalize_matrix(nOrb, cp, eGW)
-    c = matmul(X,cp)
+    c = matmul(X, cp)
 
-    call AOtoMO(nBas,c,SigCp,SigC)
+    call AOtoMO(nBas, nOrb, c, SigCp, SigC)
 
     ! Compute new density matrix in the AO basis
 
@@ -283,7 +310,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
     ! Print results
 
     call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole)
-    call print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,dipole)
+    call print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, &
+                     SigC, Z, ENuc, ET, EV, EJ, Ex, EcGM, EcRPA, EqsGW, dipole)
 
   end do
 !------------------------------------------------------------------------
@@ -300,6 +328,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(c, cp, P, F, Fp, J, K, SigC, Z, Om, XpY, XmY, rho, error, error_diis, F_diis)
+
     stop
 
  end if
@@ -313,17 +343,18 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
 ! Cumulant expansion
 
-  call RGWC(dotest,eta,nBas,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z)
+  call RGWC(dotest,eta,nOrb,nC,nO,nV,nR,nS,Om,rho,eHF,eGW,eGW,Z)
 
 ! Deallocate memory
 
-  deallocate(c,cp,P,F,Fp,J,K,SigC,Z,Om,XpY,XmY,rho,error,error_diis,F_diis)
+  deallocate(c, cp, P, F, Fp, J, K, SigC, Z, Om, XpY, XmY, rho, error, error_diis, F_diis)
 
 ! Perform BSE calculation
 
   if(BSE) then
 
-    call GW_phBSE(BSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGW,eGW,EcBSE)
+    call GW_phBSE(BSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, &
+                  nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE)
 
     if(exchange_kernel) then
 
@@ -357,7 +388,8 @@ subroutine SRG_qsGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,
 
       end if
 
-      call GW_phACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcBSE)
+      call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, BSE, singlet, triplet, &
+                      eta, nOrb, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE)
 
       write(*,*)
       write(*,*)'-------------------------------------------------------------------------------'

src/GW/SRG_qsUGW.f90

@@ -184,8 +184,8 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS
     !--------------------------------------------------
  
     do ixyz=1,ncart
-        call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
+        call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
-        call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
+        call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
     end do
 
     ! 4-index transform for (aa|aa) block
@@ -228,7 +228,7 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS
     ! Make correlation self-energy Hermitian and transform it back to AO basis
    
     do is=1,nspin
-      call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
+      call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
     end do
  
     ! Solve the quasi-particle equation
@@ -279,7 +279,7 @@ subroutine SRG_qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS
     ! Back-transform self-energy
 
     do is=1,nspin
-      call AOtoMO(nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is))
+      call AOtoMO(nBas,nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is))
     end do
 
     ! Compute density matrix 

src/GW/evRGW.f90

@@ -209,7 +209,9 @@ subroutine evRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 ! Cumulant expansion !
 !--------------------!
 
-  call RGWC(dotest,nBas,nC,nO,nR,nS,Om,rho,eGW,Z)
+  ! TODO
+  !call RGWC(dotest, eta, nBas, nC, nO, nV, nR, nS, Om, rho, eHF, eGW, eGW, Z)
+  call RGWC(dotest, eta, nBas, nC, nO, nV, nR, nS, Om, rho, eHF, eHF, eGW, Z)
 
 ! Deallocate memory
 

src/GW/print_qsRGW.f90

@@ -1,4 +1,8 @@
-subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,EK,EcGM,EcRPA,EqsGW,dipole)
+
+! ---
+
+subroutine print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, &
+                       Z, ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole)
 
 ! Print useful information about qsRGW calculation
 
@@ -7,7 +11,7 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E
 
 ! Input variables
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO
   integer,intent(in)                 :: nSCF
   double precision,intent(in)        :: ENuc
@@ -19,11 +23,11 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E
   double precision,intent(in)        :: EcRPA
   double precision,intent(in)        :: Conv
   double precision,intent(in)        :: thresh
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: eGW(nBas)
+  double precision,intent(in)        :: eGW(nOrb)
-  double precision,intent(in)        :: c(nBas)
+  double precision,intent(in)        :: c(nBas,nOrb)
-  double precision,intent(in)        :: SigC(nBas,nBas)
+  double precision,intent(in)        :: SigC(nOrb,nOrb)
-  double precision,intent(in)        :: Z(nBas)
+  double precision,intent(in)        :: Z(nOrb)
   double precision,intent(in)        :: EqsGW
   double precision,intent(in)        :: dipole(ncart)
 
@@ -59,7 +63,7 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E
             '|','#','|','e_HF (eV)','|','Sig_GW (eV)','|','Z','|','e_GW (eV)','|'
   write(*,*)'-------------------------------------------------------------------------------'
 
-  do p=1,nBas
+  do p=1,nOrb
     write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') &
     '|',p,'|',eHF(p)*HaToeV,'|',SigC(p,p)*HaToeV,'|',Z(p),'|',eGW(p)*HaToeV,'|'
   end do
@@ -110,13 +114,13 @@ subroutine print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,E
       write(*,'(A50)') '---------------------------------------'
       write(*,'(A50)') ' Restricted qsGW orbital coefficients'
       write(*,'(A50)') '---------------------------------------'
-      call matout(nBas,nBas,c)
+      call matout(nBas, nOrb, c)
       write(*,*)
     end if
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A50)') ' Restricted qsGW orbital energies (au) '
     write(*,'(A50)') '---------------------------------------'
-    call vecout(nBas,eGW)
+    call vecout(nOrb, eGW)
     write(*,*)
 
   end if

src/GW/qsRGW.f90

@@ -1,6 +1,10 @@
-subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,TDA_W,TDA,dBSE,dTDA,doppBSE, & 
+
-                 singlet,triplet,eta,regularize,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,     & 
+! ---
-                 ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+
+subroutine qsRGW(dotest, maxSCF, thresh, max_diis, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, &
+                 TDA_W, TDA, dBSE, dTDA, doppBSE, singlet, triplet, eta, regularize, nNuc, ZNuc, rNuc, &
+                 ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO,           &
+                 ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
 
 ! Perform a quasiparticle self-consistent GW calculation
 
@@ -34,15 +38,15 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
   double precision,intent(in)   :: rNuc(nNuc,ncart)
   double precision,intent(in)   :: ENuc
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   integer,intent(in)            :: nS
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: cHF(nBas,nBas)
+  double precision,intent(in)   :: cHF(nBas,nOrb)
   double precision,intent(in)   :: PHF(nBas,nBas)
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: T(nBas,nBas)
@@ -50,14 +54,14 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
   double precision,intent(in)   :: Hc(nBas,nBas)
   double precision,intent(in)   :: X(nBas,nBas)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: ispin
   integer                       :: ixyz
   integer                       :: n_diis
@@ -112,7 +116,7 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 
 ! Stuff 
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! TDA for W
 
@@ -130,10 +134,31 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 
 ! Memory allocation
 
-  allocate(eGW(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), &
+  allocate(eGW(nOrb))
-           J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),Z(nBas),           & 
+  allocate(Z(nOrb))
-           Aph(nS,nS),Bph(nS,nS),Om(nS),XpY(nS,nS),XmY(nS,nS),rho(nBas,nBas,nS),         &
+
-           err(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(c(nBas,nOrb))
+
+  allocate(cp(nOrb,nOrb))
+  allocate(Fp(nOrb,nOrb))
+  allocate(SigC(nOrb,nOrb))
+
+  allocate(P(nBas,nBas))
+  allocate(F(nBas,nBas))
+  allocate(J(nBas,nBas))
+  allocate(K(nBas,nBas))
+  allocate(err(nBas,nBas))
+  allocate(SigCp(nBas,nBas))
+
+  allocate(Aph(nS,nS))
+  allocate(Bph(nS,nS))
+  allocate(Om(nS))
+  allocate(XpY(nS,nS))
+  allocate(XmY(nS,nS))
+  allocate(rho(nOrb,nOrb,nS))
+
+  allocate(err_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
 
 ! Initialization
   
@@ -160,64 +185,68 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 
     ! Build Hartree-exchange matrix
 
-    call Hartree_matrix_AO_basis(nBas,P,ERI_AO,J)
+    call Hartree_matrix_AO_basis(nBas, P, ERI_AO, J)
-    call exchange_matrix_AO_basis(nBas,P,ERI_AO,K)
+    call exchange_matrix_AO_basis(nBas, P, ERI_AO, K)
 
     ! AO to MO transformation of two-electron integrals
 
-    do ixyz=1,ncart
+    do ixyz = 1, ncart
-      call AOtoMO(nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz))
+      call AOtoMO(nBas, nOrb, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz))
     end do
 
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
 
     ! Compute linear response
 
-    call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,Aph)
+    call phLR_A(ispin, dRPA, nOrb, nC, nO, nV, nR, nS, 1d0, eGW, ERI_MO, Aph)
-    if(.not.TDA_W) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
+    if(.not.TDA_W) call phLR_B(ispin, dRPA, nOrb, nC, nO, nV, nR, nS, 1d0, ERI_MO, Bph)
 
-    call phLR(TDA_W,nS,Aph,Bph,EcRPA,Om,XpY,XmY)
+    call phLR(TDA_W, nS, Aph, Bph, EcRPA, Om, XpY, XmY)
     if(print_W) call print_excitation_energies('phRPA@GW@RHF','singlet',nS,Om)
 
     ! Compute correlation part of the self-energy 
 
-    call GW_excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY,rho)
+    call GW_excitation_density(nOrb, nC, nO, nR, nS, ERI_MO, XpY, rho)
 
-    if(regularize) call GW_regularization(nBas,nC,nO,nV,nR,nS,eGW,Om,rho)
+    if(regularize) call GW_regularization(nOrb, nC, nO, nV, nR, nS, eGW, Om, rho)
 
-    call GW_self_energy(eta,nBas,nC,nO,nV,nR,nS,eGW,Om,rho,EcGM,SigC,Z)
+    call GW_self_energy(eta, nOrb, nC, nO, nV, nR, nS, eGW, Om, rho, EcGM, SigC, Z)
 
     ! Make correlation self-energy Hermitian and transform it back to AO basis
    
     SigC = 0.5d0*(SigC + transpose(SigC))
 
-    call MOtoAO(nBas,S,c,SigC,SigCp)
+    call MOtoAO(nBas, nOrb, S, c, SigC, SigCp)
  
     ! Solve the quasi-particle equation
 
     F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + SigCp(:,:)
+    if(nBas .ne. nOrb) then
+      call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1))
+      call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1))
+    endif
 
     ! Compute commutator and convergence criteria
 
-    err = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F)
+    err = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F)
 
     if(nSCF > 1) Conv = maxval(abs(err))
 
     ! Kinetic energy
 
-    ET = trace_matrix(nBas,matmul(P,T))
+    ET = trace_matrix(nBas, matmul(P, T))
 
     ! Potential energy
 
-    EV = trace_matrix(nBas,matmul(P,V))
+    EV = trace_matrix(nBas, matmul(P, V))
 
     ! Hartree energy
 
-    EJ = 0.5d0*trace_matrix(nBas,matmul(P,J))
+    EJ = 0.5d0*trace_matrix(nBas, matmul(P, J))
 
     ! Exchange energy
 
-    EK = 0.25d0*trace_matrix(nBas,matmul(P,K))
+    EK = 0.25d0*trace_matrix(nBas, matmul(P, K))
 
     ! Total energy
 
@@ -228,26 +257,36 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
     if(max_diis > 1) then
 
       n_diis = min(n_diis+1,max_diis)
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,F)
 
     end if
 
     ! Diagonalize Hamiltonian in AO basis
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    if(nBas .eq. nOrb) then
-    cp(:,:) = Fp(:,:)
+      Fp = matmul(transpose(X), matmul(F, X))
-    call diagonalize_matrix(nBas,cp,eGW)
+      cp(:,:) = Fp(:,:)
-    c = matmul(X,cp)
+      call diagonalize_matrix(nOrb, cp, eGW)
-    call AOtoMO(nBas,c,SigCp,SigC)
+      c = matmul(X, cp)
+    else
+      Fp = matmul(transpose(c), matmul(F, c))
+      cp(:,:) = Fp(:,:)
+      call diagonalize_matrix(nOrb, cp, eGW)
+      c = matmul(c, cp)
+    endif
+
+
+    call AOtoMO(nBas, nOrb, c, SigCp, SigC)
 
     ! Density matrix
 
-    P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
+    P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO)))
 
     ! Print results
 
-    call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole)
+    call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int_AO, dipole)
-    call print_qsRGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigCp,Z,ENuc,ET,EV,EJ,EK,EcGM,EcRPA,EqsGW,dipole)
+    call print_qsRGW(nBas, nOrb, nO, nSCF, Conv, thresh, eHF, eGW, c, SigC, Z, &
+                     ENuc, ET, EV, EJ, EK, EcGM, EcRPA, EqsGW, dipole)
 
   end do
 !------------------------------------------------------------------------
@@ -264,19 +303,21 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, Om, XpY, XmY, rho, err, err_diis, F_diis)
     stop
 
   end if
 
 ! Deallocate memory
 
-  deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,Z,Om,XpY,XmY,rho,err,err_diis,F_diis)
+  deallocate(c, cp, P, F, Fp, J, K, SigC, SigCp, Z, Om, XpY, XmY, rho, err, err_diis, F_diis)
 
 ! Perform BSE calculation
 
   if(dophBSE) then
 
-    call GW_phBSE(dophBSE2,TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eGW,eGW,EcBSE)
+    call GW_phBSE(dophBSE2, TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, &
+                  nOrb, nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eGW, eGW, EcBSE)
 
     if(exchange_kernel) then
 
@@ -310,7 +351,8 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 
       end if
 
-      call GW_phACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,dophBSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcBSE)
+      call GW_phACFDT(exchange_kernel, doXBS, .true., TDA_W, TDA, dophBSE, singlet, triplet, &
+                      eta, nOrb, nC, nO, nV, nR, nS, ERI_MO, eGW, eGW, EcBSE)
 
       write(*,*)
       write(*,*)'-------------------------------------------------------------------------------'
@@ -327,7 +369,8 @@ subroutine qsRGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,dop
 
   if(doppBSE) then
       
-    call GW_ppBSE(TDA_W,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eHF,eGW,EcBSE)
+    call GW_ppBSE(TDA_W, TDA, dBSE, dTDA, singlet, triplet, eta, nOrb, &
+                  nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, eGW, EcBSE)
  
     EcBSE(2) = 3d0*EcBSE(2)
    

src/GW/qsUGW.f90

@@ -184,8 +184,8 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE
     !--------------------------------------------------
  
     do ixyz=1,ncart
-        call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
+        call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
-        call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
+        call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
     end do
 
     ! 4-index transform for (aa|aa) block
@@ -232,7 +232,7 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE
     end do
 
     do is=1,nspin
-      call MOtoAO(nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
+      call MOtoAO(nBas,nBas,S,c(:,:,is),SigC(:,:,is),SigCp(:,:,is))
     end do
  
     ! Solve the quasi-particle equation
@@ -283,7 +283,7 @@ subroutine qsUGW(dotest,maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE
     ! Back-transform self-energy
 
     do is=1,nspin
-      call AOtoMO(nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is))
+      call AOtoMO(nBas,nBas,c(:,:,is),SigCp(:,:,is),SigC(:,:,is))
     end do
 
     ! Compute density matrix 

src/HF/GHF.f90

@@ -123,7 +123,7 @@ subroutine GHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu
 
 ! Guess coefficients and density matrices
 
-  call mo_guess(nBas2,guess_type,S,H,X,C)
+  call mo_guess(nBas2,nBas2,guess_type,S,H,X,C)
 
 ! Construct super density matrix
 
@@ -227,7 +227,7 @@ subroutine GHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu
 
 !   Level-shifting
 
-    if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,C,F)
+    if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nBas,nO,S,C,F)
 
 !  Transform Fock matrix in orthogonal basis
 

src/HF/RHF.f90

@@ -1,5 +1,8 @@
-subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, & 
+
-               nBas,nO,S,T,V,Hc,ERI,dipole_int,X,ERHF,eHF,c,P)
+! ---
+
+subroutine RHF(dotest, maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, & 
+               nBas, nOrb, nO, S, T, V, Hc, ERI, dipole_int, X, ERHF, eHF, c, P)
 
 ! Perform restricted Hartree-Fock calculation
 
@@ -16,7 +19,7 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
   double precision,intent(in)   :: thresh
   double precision,intent(in)   :: level_shift
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nO
   integer,intent(in)            :: nNuc
   double precision,intent(in)   :: ZNuc(nNuc)
@@ -26,14 +29,14 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas) 
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
   double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: n_diis
   double precision              :: ET
   double precision              :: EV
@@ -56,8 +59,8 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 ! Output variables
 
   double precision,intent(out)  :: ERHF
-  double precision,intent(out)  :: eHF(nBas)
+  double precision,intent(out)  :: eHF(nOrb)
-  double precision,intent(inout):: c(nBas,nBas)
+  double precision,intent(inout):: c(nBas,nOrb)
   double precision,intent(out)  :: P(nBas,nBas)
 
 ! Hello world
@@ -70,24 +73,37 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 
 ! Useful quantities
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! Memory allocation
 
-  allocate(J(nBas,nBas),K(nBas,nBas),err(nBas,nBas),cp(nBas,nBas),F(nBas,nBas), &
+  allocate(J(nBas,nBas))
-           Fp(nBas,nBas),err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(K(nBas,nBas))
+
+  allocate(err(nBas,nBas))
+  allocate(F(nBas,nBas))
+
+  allocate(cp(nOrb,nOrb))
+  allocate(Fp(nOrb,nOrb))
+
+  allocate(err_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
 
 ! Guess coefficients and density matrix
 
-  call mo_guess(nBas,guess_type,S,Hc,X,c)
+  call mo_guess(nBas, nOrb, guess_type, S, Hc, X, c)
-  P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
+
+  !P(:,:) = 2d0 * matmul(c(:,1:nO), transpose(c(:,1:nO)))
+  call dgemm('N', 'T', nBas, nBas, nO, 2.d0, &
+             c(1,1), nBas, c(1,1), nBas,     &
+             0.d0, P(1,1), nBas)
 
 ! Initialization
 
-  n_diis          = 0
+  n_diis        = 0
   F_diis(:,:)   = 0d0
   err_diis(:,:) = 0d0
-  rcond = 0d0
+  rcond         = 0d0
 
   Conv   = 1d0
   nSCF   = 0
@@ -110,31 +126,35 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 
     ! Build Fock matrix
     
-    call Hartree_matrix_AO_basis(nBas,P,ERI,J)
+    call Hartree_matrix_AO_basis(nBas, P, ERI, J)
-    call exchange_matrix_AO_basis(nBas,P,ERI,K)
+    call exchange_matrix_AO_basis(nBas, P, ERI, K)
     
     F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:)
+    if(nBas .ne. nOrb) then
+      call AOtoMO(nBas, nOrb, c(1,1), F(1,1), Fp(1,1))
+      call MOtoAO(nBas, nOrb, S(1,1), c(1,1), Fp(1,1), F(1,1))
+    endif
 
     ! Check convergence 
 
-    err = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F)
+    err = matmul(F, matmul(P, S)) - matmul(matmul(S, P), F)
     if(nSCF > 1) Conv = maxval(abs(err))
 
     ! Kinetic energy
 
-    ET = trace_matrix(nBas,matmul(P,T))
+    ET = trace_matrix(nBas, matmul(P, T))
 
     ! Potential energy
 
-    EV = trace_matrix(nBas,matmul(P,V))
+    EV = trace_matrix(nBas, matmul(P, V))
 
     ! Hartree energy
 
-    EJ = 0.5d0*trace_matrix(nBas,matmul(P,J))
+    EJ = 0.5d0*trace_matrix(nBas, matmul(P, J))
 
     ! Exchange energy
 
-    EK = 0.25d0*trace_matrix(nBas,matmul(P,K))
+    EK = 0.25d0*trace_matrix(nBas, matmul(P, K))
 
     ! Total energy
 
@@ -144,25 +164,37 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 
     if(max_diis > 1) then
 
-      n_diis = min(n_diis+1,max_diis)
+      n_diis = min(n_diis+1, max_diis)
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,F)
+      call DIIS_extrapolation(rcond, nBas_Sq, nBas_Sq, n_diis, err_diis, F_diis, err, F)
 
     end if
 
     ! Level shift
 
-    if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,c,F)
+    if(level_shift > 0d0 .and. Conv > thresh) then
+      call level_shifting(level_shift, nBas, nOrb, nO, S, c, F)
+    endif
 
     ! Diagonalize Fock matrix
 
-    Fp = matmul(transpose(X),matmul(F,X))
+    if(nBas .eq. nOrb) then
-    cp(:,:) = Fp(:,:)
+      Fp = matmul(transpose(X), matmul(F, X))
-    call diagonalize_matrix(nBas,cp,eHF)
+      cp(:,:) = Fp(:,:)
-    c = matmul(X,cp)
+      call diagonalize_matrix(nOrb, cp, eHF)
+      c = matmul(X, cp)
+    else
+      Fp = matmul(transpose(c), matmul(F, c))
+      cp(:,:) = Fp(:,:)
+      call diagonalize_matrix(nOrb, cp, eHF)
+      c = matmul(c, cp)
+    endif
 
     ! Density matrix
 
-    P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
+    !P(:,:) = 2d0*matmul(c(:,1:nO), transpose(c(:,1:nO)))
+    call dgemm('N', 'T', nBas, nBas, nO, 2.d0, &
+               c(1,1), nBas, c(1,1), nBas,     &
+               0.d0, P(1,1), nBas)
 
     ! Dump results
 
@@ -185,14 +217,16 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(J, K, err, F, cp, Fp, err_diis, F_diis)
+
     stop
 
   end if
 
 ! Compute dipole moments
 
-  call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole)
+  call dipole_moment(nBas, P, nNuc, ZNuc, rNuc, dipole_int, dipole)
-  call print_RHF(nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole)
+  call print_RHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, EK, ERHF, dipole)
 
 ! Testing zone
 
@@ -205,4 +239,6 @@ subroutine RHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 
   end if
 
+  deallocate(J, K, err, F, cp, Fp, err_diis, F_diis)
+
 end subroutine 

src/HF/RHF_search.f90

@@ -1,6 +1,9 @@
-subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc,   &
+
-                      nBas,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO, & 
+! ---
-                      X,ERHF,e,c,P)
+
+subroutine RHF_search(maxSCF, thresh, max_diis, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc,                     &
+                      nBas, nOrb, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, & 
+                      X, ERHF, e, c, P)
 
 ! Search for RHF solutions
 
@@ -13,7 +16,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
   double precision,intent(in)   :: thresh
   double precision,intent(in)   :: level_shift
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
@@ -26,11 +29,11 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
-  double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas)
+  double precision,intent(inout):: ERI_MO(nOrb,nOrb,nOrb,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
-  double precision,intent(inout):: dipole_int_MO(nBas,nBas,ncart)
+  double precision,intent(inout):: dipole_int_MO(nOrb,nOrb,ncart)
 
 ! Local variables
 
@@ -59,8 +62,8 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 ! Output variables
 
   double precision,intent(out)  :: ERHF
-  double precision,intent(out)  :: e(nBas)
+  double precision,intent(out)  :: e(nOrb)
-  double precision,intent(inout):: c(nBas,nBas)
+  double precision,intent(inout):: c(nBas,nOrb)
   double precision,intent(out)  :: P(nBas,nBas)
 
 ! Memory allocation
@@ -76,7 +79,8 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 !-------------------!
 
   nS = (nO - nC)*(nV - nR)
-  allocate(Aph(nS,nS),Bph(nS,nS),AB(nS,nS),Om(nS),R(nBas,nBas),ExpR(nBas,nBas))
+  allocate(Aph(nS,nS), Bph(nS,nS), AB(nS,nS), Om(nS))
+  allocate(R(nOrb,nOrb), ExpR(nOrb,nOrb))
 
 !------------------!
 ! Search algorithm !
@@ -92,12 +96,12 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 !---------------------!
 
     call wall_time(start_HF)
-    call RHF(.false.,maxSCF,thresh,max_diis,guess,level_shift,nNuc,ZNuc,rNuc,ENuc, &
+    call RHF(.false., maxSCF, thresh, max_diis, guess, level_shift, nNuc, ZNuc, rNuc, ENuc, &
-             nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,e,c,P)
+             nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, e, c, P)
     call wall_time(end_HF)
 
     t_HF = end_HF - start_HF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RHF = ',t_HF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RHF = ',t_HF,' seconds'
     write(*,*)
 
 !----------------------------------!
@@ -108,14 +112,14 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
     write(*,*)
     write(*,*) 'AO to MO transformation... Please be patient'
     write(*,*)
-    do ixyz=1,ncart
+    do ixyz = 1, ncart
-      call AOtoMO(nBas,c,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz))
+      call AOtoMO(nBas, nOrb, c, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz))
     end do
-    call AOtoMO_ERI_RHF(nBas,c,ERI_AO,ERI_MO)
+    call AOtoMO_ERI_RHF(nBas, nOrb, c, ERI_AO, ERI_MO)
     call wall_time(end_AOtoMO)
  
     t_AOtoMO = end_AOtoMO - start_AOtoMO
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for AO to MO transformation = ',t_AOtoMO,' seconds'
     write(*,*)
 
 !-------------------------------------------------------------!
@@ -124,12 +128,12 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 
     ispin = 1
  
-    call phLR_A(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph)
+    call phLR_A(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,e,ERI_MO,Aph)
-    call phLR_B(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
+    call phLR_B(ispin,.false.,nOrb,nC,nO,nV,nR,nS,1d0,ERI_MO,Bph)
  
     AB(:,:) = Aph(:,:) + Bph(:,:)
  
-    call diagonalize_matrix(nS,AB,Om)
+    call diagonalize_matrix(nS, AB, Om)
     Om(:) = 2d0*Om(:)
 
     write(*,*)'-------------------------------------------------------------'
@@ -156,6 +160,7 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
       if(eig < 0 .or. eig > nS)  then
         write(*,'(1X,A40,1X,A10)')     'Invalid option...','Stop...'
         write(*,*)
+        deallocate(Aph, Bph, AB, Om, R, ExpR)
         stop
       end if
 
@@ -164,15 +169,15 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
       R(:,:) = 0d0
       ia = 0
       do i=nC+1,nO
-        do a=nO+1,nBas-nR
+        do a=nO+1,nOrb-nR
           ia = ia + 1
           R(a,i) = +AB(ia,eig)
           R(i,a) = -AB(ia,eig)
         end do
       end do
 
-      call matrix_exponential(nBas,R,ExpR)
+      call matrix_exponential(nOrb, R, ExpR)
-      c = matmul(c,ExpR)
+      c = matmul(c, ExpR)
 
     else
  
@@ -191,4 +196,6 @@ subroutine RHF_search(maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,rN
 !---------------!
   end do
 
+  deallocate(Aph, Bph, AB, Om, R, ExpR)
+
 end subroutine

src/HF/RHF_stability.f90

@@ -30,7 +30,7 @@ subroutine RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI)
 
 ! Memory allocation
 
-  allocate(A(nS,nS),B(nS,nS),AB(nS,nS),Om(nS))
+  allocate(A(nS,nS), B(nS,nS), AB(nS,nS), Om(nS))
  
 !-------------------------------------------------------------!
 ! Stability analysis: Real RHF -> Real RHF  
@@ -148,5 +148,7 @@ subroutine RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI)
   end if
   write(*,*)'-------------------------------------------------------------'
   write(*,*)
+
+  deallocate(A, B, AB, Om)
     
 end subroutine 

src/HF/RMOM.f90

@@ -190,6 +190,6 @@ subroutine RMOM(maxSCF,thresh,max_diis,nBas,nO,S,T,V,Hc,ERI,X,ENuc,ERHF,c,e,P)
   EK   = 0.5d0*trace_matrix(nBas,matmul(P,K))
   ERHF = ET + EV + EJ + EK
 
-  call print_RHF(nBas,nO,e,c,ENuc,ET,EV,EJ,EK,ERHF)
+  call print_RHF(nBas,nBas,nO,e,c,ENuc,ET,EV,EJ,EK,ERHF)
 
 end subroutine 

src/HF/ROHF.f90

@@ -1,5 +1,8 @@
-subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNuc,rNuc,ENuc, & 
+
-                nBas,nO,S,T,V,Hc,ERI,dipole_int,X,EROHF,eHF,c,Ptot)
+! ---
+
+subroutine ROHF(dotest, maxSCF, thresh, max_diis, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, & 
+                nBas, nOrb, nO, S, T, V, Hc, ERI, dipole_int, X, EROHF, eHF, c, Ptot)
 
 ! Perform restricted open-shell Hartree-Fock calculation
 
@@ -16,7 +19,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
   double precision,intent(in)   :: mix 
   double precision,intent(in)   :: level_shift
   double precision,intent(in)   :: thresh
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
 
   integer,intent(in)            :: nNuc
   double precision,intent(in)   :: ZNuc(nNuc)
@@ -28,14 +31,14 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas) 
-  double precision,intent(in)   :: X(nBas,nBas) 
+  double precision,intent(in)   :: X(nBas,nOrb) 
   double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
   double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
 
 ! Local variables
 
   integer                       :: nSCF
-  integer                       :: nBasSq
+  integer                       :: nBas_Sq
   integer                       :: n_diis
   double precision              :: Conv
   double precision              :: rcond
@@ -62,8 +65,8 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
 ! Output variables
 
   double precision,intent(out)  :: EROHF
-  double precision,intent(out)  :: eHF(nBas)
+  double precision,intent(out)  :: eHF(nOrb)
-  double precision,intent(inout):: c(nBas,nBas)
+  double precision,intent(inout):: c(nBas,nOrb)
   double precision,intent(out)  :: Ptot(nBas,nBas)
 
 ! Hello world
@@ -76,19 +79,30 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
 
 ! Useful stuff
 
-  nBasSq = nBas*nBas
+  nBas_Sq = nBas*nBas
 
 ! Memory allocation
 
-  allocate(J(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas),Ftot(nBas,nBas), & 
+  allocate(J(nBas,nBas,nspin))
-           P(nBas,nBas,nspin),K(nBas,nBas,nspin),err(nBas,nBas),cp(nBas,nBas),  &
+  allocate(K(nBas,nBas,nspin))
-           err_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis))
+  allocate(F(nBas,nBas,nspin))
+  allocate(Ftot(nBas,nBas))
+  allocate(P(nBas,nBas,nspin))
+  allocate(err(nBas,nBas))
+
+  allocate(Fp(nOrb,nOrb))
+  allocate(cp(nOrb,nOrb))
+
+  allocate(err_diis(nBas_Sq,max_diis))
+  allocate(F_diis(nBas_Sq,max_diis))
 
 ! Guess coefficients and demsity matrices
 
-  call mo_guess(nBas,guess_type,S,Hc,X,c)
+  call mo_guess(nBas, nOrb, guess_type, S, Hc, X, c)
-  do ispin=1,nspin
+
-    P(:,:,ispin) = matmul(c(:,1:nO(ispin)),transpose(c(:,1:nO(ispin))))
+  do ispin = 1, nspin
+    !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin))))
+    call dgemm('N', 'T', nBas, nBas, nO(ispin), 1.d0, c, nBas, c, nBas, 0.d0, P(1,1,ispin), nBas)
   end do
   Ptot(:,:) = P(:,:,1) + P(:,:,2)
 
@@ -120,51 +134,51 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
 
 !   Build Hartree repulsion
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      call Hartree_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),J(:,:,ispin))
+      call Hartree_matrix_AO_basis(nBas, P(:,:,ispin), ERI(:,:,:,:), J(:,:,ispin))
     end do
 
 !   Compute exchange potential
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      call exchange_matrix_AO_basis(nBas,P(:,:,ispin),ERI(:,:,:,:),K(:,:,ispin))
+      call exchange_matrix_AO_basis(nBas, P(:,:,ispin), ERI(:,:,:,:), K(:,:,ispin))
     end do
  
 !   Build Fock operator
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
       F(:,:,ispin) = Hc(:,:) + J(:,:,ispin) + J(:,:,mod(ispin,2)+1) + K(:,:,ispin)
     end do
 
-    call ROHF_fock_matrix(nBas,nO(1),nO(2),S,c,F(:,:,1),F(:,:,2),Ftot)
+    call ROHF_fock_matrix(nBas, nOrb, nO(1), nO(2), S, c, F(:,:,1), F(:,:,2), Ftot)
 
 !   Check convergence 
 
-    err(:,:) = matmul(Ftot,matmul(Ptot,S)) - matmul(matmul(S,Ptot),Ftot)
+    err(:,:) = matmul(Ftot, matmul(Ptot, S)) - matmul(matmul(S, Ptot), Ftot)
     if(nSCF > 1) Conv = maxval(abs(err(:,:)))
     
 !   Kinetic energy
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      ET(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),T(:,:)))
+      ET(ispin) = trace_matrix(nBas, matmul(P(:,:,ispin), T(:,:)))
     end do
 
 !   Potential energy
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      EV(ispin) = trace_matrix(nBas,matmul(P(:,:,ispin),V(:,:)))
+      EV(ispin) = trace_matrix(nBas, matmul(P(:,:,ispin), V(:,:)))
     end do
 
 !   Hartree energy
 
-    EJ(1) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,1)))
+    EJ(1) = 0.5d0*trace_matrix(nBas, matmul(P(:,:,1), J(:,:,1)))
-    EJ(2) = trace_matrix(nBas,matmul(P(:,:,1),J(:,:,2)))
+    EJ(2) = trace_matrix(nBas, matmul(P(:,:,1), J(:,:,2)))
-    EJ(3) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,2)))
+    EJ(3) = 0.5d0*trace_matrix(nBas, matmul(P(:,:,2), J(:,:,2)))
 
 !   Exchange energy
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      EK(ispin) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,ispin),K(:,:,ispin)))
+      EK(ispin) = 0.5d0*trace_matrix(nBas, matmul(P(:,:,ispin), K(:,:,ispin)))
     end do
 
 !   Total energy
@@ -176,7 +190,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
     if(max_diis > 1) then
 
       n_diis = min(n_diis+1,max_diis)
-      call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,err_diis,F_diis,err,Ftot)
+      call DIIS_extrapolation(rcond,nBas_Sq,nBas_Sq,n_diis,err_diis,F_diis,err,Ftot)
 
     end if
 
@@ -185,28 +199,29 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
     if(level_shift > 0d0 .and. Conv > thresh) then
 
       do ispin=1,nspin
-        call level_shifting(level_shift,nBas,maxval(nO),S,c,Ftot)
+        call level_shifting(level_shift, nBas, nOrb, maxval(nO), S, c, Ftot)
       end do
 
     end if
 
 !  Transform Fock matrix in orthogonal basis
 
-    Fp(:,:) = matmul(transpose(X(:,:)),matmul(Ftot(:,:),X(:,:)))
+    Fp(:,:) = matmul(transpose(X(:,:)), matmul(Ftot(:,:), X(:,:)))
 
 !  Diagonalize Fock matrix to get eigenvectors and eigenvalues
 
     cp(:,:) = Fp(:,:)
-    call diagonalize_matrix(nBas,cp,eHF)
+    call diagonalize_matrix(nOrb, cp, eHF)
     
 !   Back-transform eigenvectors in non-orthogonal basis
 
-    c(:,:) = matmul(X(:,:),cp(:,:))
+    c(:,:) = matmul(X(:,:), cp(:,:))
 
 !   Compute density matrix 
 
-    do ispin=1,nspin
+    do ispin = 1, nspin
-      P(:,:,ispin) = matmul(c(:,1:nO(ispin)),transpose(c(:,1:nO(ispin))))
+      !P(:,:,ispin) = matmul(c(:,1:nO(ispin)), transpose(c(:,1:nO(ispin))))
+      call dgemm('N', 'T', nBas, nBas, nO(ispin), 1.d0, c, nBas, c, nBas, 0.d0, P(1,1,ispin), nBas)
     end do
     Ptot(:,:) = P(:,:,1) + P(:,:,2) 
 
@@ -231,6 +246,8 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
     write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     write(*,*)
 
+    deallocate(J, K, F, Ftot, P, err, Fp, cp, err_diis, F_diis)
+
     stop
 
   end if
@@ -238,7 +255,7 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
 ! Compute final UHF energy
 
   call dipole_moment(nBas,Ptot,nNuc,ZNuc,rNuc,dipole_int,dipole)
-  call print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,EK,EROHF,dipole)
+  call print_ROHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, EK, EROHF, dipole)
 
 ! Print test values
 
@@ -248,4 +265,6 @@ subroutine ROHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZN
 
   end if
 
+  deallocate(J, K, F, Ftot, P, err, Fp, cp, err_diis, F_diis)
+
 end subroutine 

src/HF/ROHF_fock_matrix.f90

@@ -1,4 +1,7 @@
-subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO)
+
+! ---
+
+subroutine ROHF_fock_matrix(nBas, nOrb, nOa, nOb, S, c, FaAO, FbAO, FAO)
 
 ! Construct the ROHF Fock matrix in the AO basis
 ! For open shells, the ROHF Fock matrix in the MO basis reads
@@ -17,12 +20,12 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nOa
   integer,intent(in)            :: nOb
 
   double precision,intent(in)   :: S(nBas,nBas)
-  double precision,intent(in)   :: c(nBas,nBas)
+  double precision,intent(in)   :: c(nBas,nOrb)
   double precision,intent(inout):: FaAO(nBas,nBas)
   double precision,intent(inout):: FbAO(nBas,nBas)
 
@@ -46,7 +49,7 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO)
 
 ! Memory allocation
 
-  allocate(F(nBas,nBas),Fa(nBas,nBas),Fb(nBas,nBas))
+  allocate(F(nOrb,nOrb), Fa(nOrb,nOrb), Fb(nOrb,nOrb))
 
 ! Roothan canonicalization parameters
 
@@ -61,14 +64,14 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO)
 
 ! Number of closed, open, and virtual orbitals
 
-  nC = min(nOa,nOb)
+  nC = min(nOa, nOb)
   nO = abs(nOa - nOb)
   nV = nBas - nC - nO
 
 ! Block-by-block Fock matrix 
 
-  call AOtoMO(nBas,c,FaAO,Fa)
+  call AOtoMO(nBas, nOrb, c, FaAO, Fa)
-  call AOtoMO(nBas,c,FbAO,Fb)
+  call AOtoMO(nBas, nOrb, c, FbAO, Fb)
 
   F(1:nC,      1:nC      ) =    aC*Fa(1:nC,      1:nC      ) +    bC*Fb(1:nC,      1:nC      )
   F(1:nC,   nC+1:nC+nO   ) =                                         Fb(1:nC,   nC+1:nC+nO   )
@@ -82,8 +85,10 @@ subroutine ROHF_fock_matrix(nBas,nOa,nOb,S,c,FaAO,FbAO,FAO)
   F(nO+nC+1:nC+nO+nV,   nC+1:nC+nO   ) =       Fa(nO+nC+1:nC+nO+nV,   nC+1:nC+nO   )
   F(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) =    aV*Fa(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV) +    bV*Fb(nO+nC+1:nC+nO+nV,nO+nC+1:nC+nO+nV)
 
-  call MOtoAO(nBas,S,c,F,FAO) 
+  call MOtoAO(nBas, nOrb, S, c, F, FAO) 
-  call MOtoAO(nBas,S,c,Fa,FaAO)
+  call MOtoAO(nBas, nOrb, S, c, Fa, FaAO)
-  call MOtoAO(nBas,S,c,Fb,FbAO)
+  call MOtoAO(nBas, nOrb, S, c, Fb, FbAO)
+
+  deallocate(F, Fa, Fb)
 
 end subroutine

src/HF/UHF.f90

@@ -85,7 +85,7 @@ subroutine UHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu
 ! Guess coefficients and demsity matrices
 
   do ispin=1,nspin
-    call mo_guess(nBas,guess_type,S,Hc,X,c(:,:,ispin))
+    call mo_guess(nBas,nBas,guess_type,S,Hc,X,c(:,:,ispin))
     P(:,:,ispin) = matmul(c(:,1:nO(ispin),ispin),transpose(c(:,1:nO(ispin),ispin)))
   end do
 
@@ -186,7 +186,7 @@ subroutine UHF(dotest,maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu
     if(level_shift > 0d0 .and. Conv > thresh) then
 
       do ispin=1,nspin
-        call level_shifting(level_shift,nBas,nO(ispin),S,c(:,:,ispin),F(:,:,ispin))
+        call level_shifting(level_shift,nBas,nBas,nO(ispin),S,c(:,:,ispin),F(:,:,ispin))
       end do
 
     end if

src/HF/UHF_search.f90

@@ -124,8 +124,8 @@ subroutine UHF_search(maxSCF,thresh,max_diis,guess_type,mix,level_shift,nNuc,ZNu
   ! Transform dipole-related integrals
 
     do ixyz=1,ncart
-      call AOtoMO(nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
+      call AOtoMO(nBas,nBas,c(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
-      call AOtoMO(nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
+      call AOtoMO(nBas,nBas,c(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
     end do
 
     ! 4-index transform for (aa|aa) block

src/HF/cRHF.f90

@@ -94,7 +94,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r
 
 ! Guess coefficients and density matrix
 
-  call mo_guess(nBas,guess_type,S,Hc,X,c)
+  call mo_guess(nBas,nBas,guess_type,S,Hc,X,c)
   P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO)))
 
 ! Initialization
@@ -166,7 +166,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r
 
     ! Level shift
 
-    if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nO,S,c,F)
+    if(level_shift > 0d0 .and. Conv > thresh) call level_shifting(level_shift,nBas,nBas,nO,S,c,F)
 
     ! Diagonalize Fock matrix
 
@@ -207,7 +207,7 @@ subroutine cRHF(dotest,maxSCF,thresh,max_diis,guess_type,level_shift,nNuc,ZNuc,r
 ! Compute dipole moments
 
   call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole)
-  call print_RHF(nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole)
+  call print_RHF(nBas,nBas,nO,eHF,C,ENuc,ET,EV,EJ,EK,ERHF,dipole)
 
 ! Testing zone
 

src/HF/core_guess.f90

@@ -1,4 +1,4 @@
-subroutine core_guess(nBas,Hc,X,c)
+subroutine core_guess(nBas, nOrb, Hc, X, c)
 
 !  Core guess of the molecular orbitals for HF calculation
 
@@ -6,9 +6,9 @@ subroutine core_guess(nBas,Hc,X,c)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
 
 ! Local variables
 
@@ -18,16 +18,19 @@ subroutine core_guess(nBas,Hc,X,c)
 
 ! Output variables
 
-  double precision,intent(out)  :: c(nBas,nBas)
+  double precision,intent(out)  :: c(nBas,nOrb)
 
 ! Memory allocation
 
-  allocate(cp(nBas,nBas),e(nBas))
+  allocate(cp(nOrb,nOrb), e(nOrb))
 
 ! Core guess
 
-  cp(:,:) = matmul(transpose(X(:,:)),matmul(Hc(:,:),X(:,:)))
+  cp(:,:) = matmul(transpose(X(:,:)), matmul(Hc(:,:), X(:,:)))
-  call diagonalize_matrix(nBas,cp,e)
+
-  c(:,:) = matmul(X(:,:),cp(:,:))
+  call diagonalize_matrix(nOrb, cp, e)
+  c(:,:) = matmul(X(:,:), cp(:,:))
+
+  deallocate(cp, e)
 
 end subroutine

src/HF/huckel_guess.f90

@@ -1,4 +1,4 @@
-subroutine huckel_guess(nBas,S,Hc,X,c)
+subroutine huckel_guess(nBas, nOrb, S, Hc, X, c)
 
 !  Hickel guess 
 
@@ -6,10 +6,10 @@ subroutine huckel_guess(nBas,S,Hc,X,c)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
 
 ! Local variables
 
@@ -20,7 +20,7 @@ subroutine huckel_guess(nBas,S,Hc,X,c)
 
 ! Output variables
 
-  double precision,intent(out)  :: c(nBas,nBas)
+  double precision,intent(out)  :: c(nBas,nOrb)
 
 ! Memory allocation
 
@@ -32,9 +32,9 @@ subroutine huckel_guess(nBas,S,Hc,X,c)
 
 ! GWH approximation
 
-  do mu=1,nBas
+  do mu = 1, nBas
     F(mu,mu) = Hc(mu,mu)
-    do nu=mu+1,nBas
+    do nu = mu+1, nBas
 
       F(mu,nu) = 0.5d0*a*S(mu,nu)*(Hc(mu,mu) + Hc(nu,nu))
       F(nu,mu) = F(mu,nu)
@@ -42,6 +42,8 @@ subroutine huckel_guess(nBas,S,Hc,X,c)
     end do
   end do
   
-  call core_guess(nBas,F,X,c)
+  call core_guess(nBas, nOrb, F, X, c)
+
+  deallocate(F)
 
 end subroutine

src/HF/mo_guess.f90

@@ -1,4 +1,7 @@
-subroutine mo_guess(nBas,guess_type,S,Hc,X,c)
+
+! ---
+
+subroutine mo_guess(nBas, nOrb, guess_type, S, Hc, X, c)
 
 !  Guess of the molecular orbitals for HF calculation
 
@@ -6,15 +9,15 @@ subroutine mo_guess(nBas,guess_type,S,Hc,X,c)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: guess_type
   double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
 
 ! Output variables
 
-  double precision,intent(inout)  :: c(nBas,nBas)
+  double precision,intent(inout)  :: c(nBas,nOrb)
 
   if(guess_type == 0) then
 
@@ -24,12 +27,12 @@ subroutine mo_guess(nBas,guess_type,S,Hc,X,c)
   elseif(guess_type == 1) then
 
     write(*,*) 'Core guess...'
-    call core_guess(nBas,Hc,X,c)
+    call core_guess(nBas, nOrb, Hc, X, c)
 
   elseif(guess_type == 2) then
 
     write(*,*) 'Huckel guess...'
-    call huckel_guess(nBas,S,Hc,X,c)
+    call huckel_guess(nBas, nOrb, S, Hc, X, c)
 
   elseif(guess_type == 3) then
 

src/HF/print_RHF.f90

@@ -1,4 +1,7 @@
-subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole)
+
+! ---
+
+subroutine print_RHF(nBas, nOrb, nO, eHF, cHF, ENuc, ET, EV, EJ, EK, ERHF, dipole)
 
 ! Print one-electron energies and other stuff for G0W0
 
@@ -7,10 +10,10 @@ subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole)
 
 ! Input variables
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: cHF(nBas,nBas)
+  double precision,intent(in)        :: cHF(nBas,nOrb)
   double precision,intent(in)        :: ENuc
   double precision,intent(in)        :: ET
   double precision,intent(in)        :: EV
@@ -75,13 +78,13 @@ subroutine print_RHF(nBas,nO,eHF,cHF,ENuc,ET,EV,EJ,EK,ERHF,dipole)
     write(*,'(A50)') '---------------------------------------'
     write(*,'(A50)') ' RHF orbital coefficients '
     write(*,'(A50)') '---------------------------------------'
-    call matout(nBas,nBas,cHF)
+    call matout(nBas, nOrb, cHF)
     write(*,*)
   end if
   write(*,'(A50)') '---------------------------------------'
   write(*,'(A50)') ' RHF orbital energies (au) '
   write(*,'(A50)') '---------------------------------------'
-  call vecout(nBas,eHF)
+  call vecout(nOrb, eHF)
   write(*,*)
 
 end subroutine 

src/HF/print_ROHF.f90

@@ -1,14 +1,17 @@
-subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole)
+
+! ---
+
+subroutine print_ROHF(nBas, nOrb, nO, eHF, c, ENuc, ET, EV, EJ, Ex, EROHF, dipole)
 
 ! Print one- and two-electron energies and other stuff for RoHF calculation
 
   implicit none
   include 'parameters.h'
 
-  integer,intent(in)                 :: nBas
+  integer,intent(in)                 :: nBas, nOrb
   integer,intent(in)                 :: nO(nspin)
-  double precision,intent(in)        :: eHF(nBas)
+  double precision,intent(in)        :: eHF(nOrb)
-  double precision,intent(in)        :: c(nBas,nBas)
+  double precision,intent(in)        :: c(nBas,nOrb)
   double precision,intent(in)        :: ENuc
   double precision,intent(in)        :: ET(nspin)
   double precision,intent(in)        :: EV(nspin)
@@ -31,7 +34,7 @@ subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole)
   do ispin=1,nspin
     if(nO(ispin) > 0) then 
       HOMO(ispin) = eHF(nO(ispin))
-      if(nO(ispin) < nBas) then
+      if(nO(ispin) < nOrb) then
         LUMO(ispin) = eHF(nO(ispin)+1)
       else
         LUMO(ispin) = 0d0
@@ -102,13 +105,13 @@ subroutine print_ROHF(nBas,nO,eHF,c,ENuc,ET,EV,EJ,Ex,EROHF,dipole)
     write(*,'(A50)') '-----------------------------------------'
     write(*,'(A50)') 'ROHF orbital coefficients '
     write(*,'(A50)') '-----------------------------------------'
-    call matout(nBas,nBas,c)
+    call matout(nBas, nOrb, c)
     write(*,*)
   end if
   write(*,'(A50)') '---------------------------------------'
   write(*,'(A50)') ' ROHF orbital energies (au) '
   write(*,'(A50)') '---------------------------------------'
-  call vecout(nBas,eHF)
+  call vecout(nOrb, eHF)
   write(*,*)
 
 end subroutine 

src/LR/ppLR.f90

@@ -1,93 +1,128 @@
-subroutine ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcRPA)
 
-! Solve the pp-RPA linear eigenvalue problem
+! ---
+
+subroutine ppLR(TDA, nOO, nVV, Bpp, Cpp, Dpp, Om1, X1, Y1, Om2, X2, Y2, EcRPA)
+
+  ! 
+  ! Solve the pp-RPA linear eigenvalue problem
+  !
+  ! right eigen-problem: H   R = R w
+  ! left  eigen-problem: H.T L = L w
+  !
+  !     where L.T R = 1
+  !
+  !
+  !        (+C    +B) 
+  !   H =  (        )  where C = C.T and D = D.T
+  !        (-B.T  -D)
+  !
+  !      (w1   0)        (X1   X2)          (+X1  +X2)
+  !  w = (      ),   R = (       )  and L = (        )
+  !      (0   w2)        (Y1   Y2)          (-Y1  -Y2)
+  ! 
+  !
+  !  the normalisation condition reduces to
+  !
+  !    X1.T X2 - Y1.T Y2 = 0
+  !    X1.T X1 - Y1.T Y1 = 1
+  !    X2.T X2 - Y2.T Y2 = 1
+  !
 
   implicit none
   include 'parameters.h'
 
-! Input variables
+  logical,          intent(in)  :: TDA
-
+  integer,          intent(in)  :: nOO, nVV
-  logical,intent(in)            :: TDA
+  double precision, intent(in)  :: Bpp(nVV,nOO), Cpp(nVV,nVV), Dpp(nOO,nOO)
-  integer,intent(in)            :: nOO
+  double precision, intent(out) :: Om1(nVV), X1(nVV,nVV), Y1(nOO,nVV)
-  integer,intent(in)            :: nVV
+  double precision, intent(out) :: Om2(nOO), X2(nVV,nOO), Y2(nOO,nOO)
-  double precision,intent(in)   :: Bpp(nVV,nOO)
+  double precision, intent(out) :: EcRPA
-  double precision,intent(in)   :: Cpp(nVV,nVV)
-  double precision,intent(in)   :: Dpp(nOO,nOO)
   
-! Local variables
+  logical                       :: imp_bio, verbose
+  integer                       :: i, j, N
+  double precision              :: EcRPA1, EcRPA2
+  double precision              :: thr_d, thr_nd, thr_deg
+  double precision,allocatable  :: M(:,:), Z(:,:), Om(:)
 
-  double precision              :: trace_matrix
+  double precision, external    :: trace_matrix
-  double precision              :: EcRPA1
-  double precision              :: EcRPA2
-  double precision,allocatable  :: M(:,:)
-  double precision,allocatable  :: Z(:,:)
-  double precision,allocatable  :: Om(:)
 
-! Output variables
 
-  double precision,intent(out)  :: Om1(nVV)
-  double precision,intent(out)  :: X1(nVV,nVV)
-  double precision,intent(out)  :: Y1(nOO,nVV)
-  double precision,intent(out)  :: Om2(nOO)
-  double precision,intent(out)  :: X2(nVV,nOO)
-  double precision,intent(out)  :: Y2(nOO,nOO)
-  double precision,intent(out)  :: EcRPA
 
-! Memory allocation
+  N = nOO + nVV
 
-  allocate(M(nOO+nVV,nOO+nVV),Z(nOO+nVV,nOO+nVV),Om(nOO+nVV))
+  allocate(M(N,N), Z(N,N), Om(N))
-
-!-------------------------------------------------!
-! Solve the p-p eigenproblem                      !
-!-------------------------------------------------!
-!                                                 !
-!  |  C   B | | X1  X2 |   | w1  0  | | X1  X2 |  !
-!  |        | |        | = |        | |        |  !
-!  | -Bt -D | | Y1  Y2 |   | 0   w2 | | Y1  Y2 |  !
-!                                                 !
-!-------------------------------------------------!
 
   if(TDA) then
 
     X1(:,:) = +Cpp(:,:)
     Y1(:,:) = 0d0
-    if(nVV > 0) call diagonalize_matrix(nVV,X1,Om1)
+    if(nVV > 0) call diagonalize_matrix(nVV, X1, Om1)
 
     X2(:,:) = 0d0
     Y2(:,:) = -Dpp(:,:)
-    if(nOO > 0) call diagonalize_matrix(nOO,Y2,Om2)
+    if(nOO > 0) call diagonalize_matrix(nOO, Y2, Om2)
 
   else
 
-  ! Diagonal blocks 
+    ! Diagonal blocks 
-
     M(    1:nVV    ,    1:nVV)     = + Cpp(1:nVV,1:nVV)
     M(nVV+1:nVV+nOO,nVV+1:nVV+nOO) = - Dpp(1:nOO,1:nOO)
 
-  ! Off-diagonal blocks
+    ! Off-diagonal blocks
-
     M(    1:nVV    ,nVV+1:nOO+nVV) = -           Bpp(1:nVV,1:nOO)
     M(nVV+1:nOO+nVV,    1:nVV)     = + transpose(Bpp(1:nVV,1:nOO))
 
-!   call matout(nOO,nOO,Dpp)
+    if((nOO .eq. 0) .or. (nVV .eq. 0)) then
 
-  ! Diagonalize the p-p matrix
+      ! Diagonalize the p-p matrix
+      if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV, M, Om, Z)
+      ! Split the various quantities in p-p and h-h parts
+      call sort_ppRPA(nOO, nVV, Om, Z, Om1, X1, Y1, Om2, X2, Y2)
 
-    if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV,M,Om,Z)
+    else
 
-  ! Split the various quantities in p-p and h-h parts
+        thr_d   = 1d-6   ! to determine if     diagonal elements of L.T x R are close enouph to 1
+        thr_nd  = 1d-6   ! to determine if non-diagonal elements of L.T x R are close enouph to 1
+        thr_deg = 1d-8   ! to determine if two eigenvectors are degenerate or not
+        imp_bio = .True. ! impose bi-orthogonality
+        verbose = .False.
+        call diagonalize_nonsym_matrix(N, M, Z, Om, thr_d, thr_nd, thr_deg, imp_bio, verbose)
+    
+        do i = 1, nOO
+          Om2(i) = Om(i)
+          do j = 1, nVV
+            X2(j,i) = Z(j,i)
+          enddo
+          do j = 1, nOO
+            Y2(j,i) = Z(nVV+j,i)
+          enddo
+        enddo
+    
+        do i = 1, nVV
+          Om1(i) = Om(nOO+i)
+          do j = 1, nVV
+            X1(j,i) = M(j,nOO+i)
+          enddo
+          do j = 1, nOO
+            Y1(j,i) = M(nVV+j,nOO+i)
+          enddo
+        enddo
 
-    call sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
+    endif
 
   end if
 
-! Compute the RPA correlation energy
+  ! Compute the RPA correlation energy
+  EcRPA = 0.5d0 * (sum(Om1) - sum(Om2) - trace_matrix(nVV, Cpp) - trace_matrix(nOO, Dpp))
+  EcRPA1 = +sum(Om1) - trace_matrix(nVV, Cpp)
+  EcRPA2 = -sum(Om2) - trace_matrix(nOO, Dpp)
 
-  EcRPA = 0.5d0*( sum(Om1) - sum(Om2) - trace_matrix(nVV,Cpp) - trace_matrix(nOO,Dpp) )
+  if(abs(EcRPA - EcRPA1) > 1d-6 .or. abs(EcRPA - EcRPA2) > 1d-6) then
-  EcRPA1 = +sum(Om1) - trace_matrix(nVV,Cpp)
-  EcRPA2 = -sum(Om2) - trace_matrix(nOO,Dpp)
-
-  if(abs(EcRPA - EcRPA1) > 1d-6 .or. abs(EcRPA - EcRPA2) > 1d-6) & 
     print*,'!!! Issue in pp-RPA linear reponse calculation RPA1 != RPA2 !!!'
+  endif
+
+  deallocate(M, Z, Om)
 
 end subroutine 
+
+

src/LR/ppLR_C.f90

@@ -23,6 +23,8 @@ subroutine ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,lambda,e,ERI,Cpp)
   double precision,external     :: Kronecker_delta
 
   integer                       :: a,b,c,d,ab,cd
+  integer                       :: a0, aa
+  double precision              :: e_ab, tmp_ab, delta_ac, tmp_cd
 
 ! Output variables
 
@@ -37,22 +39,70 @@ subroutine ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,lambda,e,ERI,Cpp)
 
   if(ispin == 1) then
 
-    ab = 0
+    a0 = nBas - nR - nO
-    do a=nO+1,nBas-nR
+
-     do b=a,nBas-nR
+    !$OMP PARALLEL DEFAULT(NONE)                                                   &
-        ab = ab + 1
+    !$OMP          PRIVATE(a, b, aa, ab, c, d, cd, e_ab, tmp_ab, delta_ac, tmp_cd) &
+    !$OMP          SHARED(nO, nBas, nR, a0, eF, lambda, e, ERI, Cpp)
+    !$OMP DO
+    do a = nO+1, nBas-nR
+      aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO
+      do b = a, nBas-nR
+        ab = aa + b
+
+        e_ab = e(a) + e(b) - eF
+
+        tmp_ab = lambda
+        if(a .eq. b) then
+          tmp_ab = 0.7071067811865475d0 * lambda
+        endif
+
         cd = 0
-        do c=nO+1,nBas-nR
+        do c = nO+1, nBas-nR
-         do d=c,nBas-nR
+
+          delta_ac = 0.d0
+          if(a .eq. c) then
+            delta_ac = 1.d0
+          endif
+
+         do d = c, nBas-nR
             cd = cd + 1
+
+            tmp_cd = tmp_ab
+            if(c .eq. d) then
+              tmp_cd = 0.7071067811865475d0 * tmp_ab
+            endif
+
+            Cpp(ab,cd) = 0.d0
+            if(b .eq. d) then
+              Cpp(ab,cd) = e_ab * delta_ac
+            endif
  
-            Cpp(ab,cd) = + (e(a) + e(b) - eF)*Kronecker_delta(a,c)*Kronecker_delta(b,d) &
+            Cpp(ab,cd) = Cpp(ab,cd) + tmp_cd * (ERI(a,b,c,d) + ERI(a,b,d,c))
-                         + lambda*(ERI(a,b,c,d) + ERI(a,b,d,c))/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d)))
+          enddo
- 
+        enddo
-          end do
+      enddo
-        end do
+    enddo
-      end do
+    !$OMP END DO
-    end do
+    !$OMP END PARALLEL
+
+
+!    ab = 0
+!    do a=nO+1,nBas-nR
+!     do b=a,nBas-nR
+!        ab = ab + 1
+!        cd = 0
+!        do c=nO+1,nBas-nR
+!         do d=c,nBas-nR
+!            cd = cd + 1
+! 
+!            Cpp(ab,cd) = + (e(a) + e(b) - eF)*Kronecker_delta(a,c)*Kronecker_delta(b,d) &
+!                         + lambda*(ERI(a,b,c,d) + ERI(a,b,d,c))/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d)))
+! 
+!          end do
+!        end do
+!      end do
+!    end do
 
   end if
 

src/MP/RMP.f90

@@ -1,4 +1,4 @@
-subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+subroutine RMP(dotest,doMP2,doMP3,regularize,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
 
 ! Moller-Plesset module
 
@@ -13,15 +13,15 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
   logical,intent(in)            :: doMP3
 
   logical,intent(in)            :: regularize
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
   integer,intent(in)            :: nR
   double precision,intent(in)   :: ENuc
   double precision,intent(in)   :: ERHF
-  double precision,intent(in)   :: eHF(nBas)
+  double precision,intent(in)   :: eHF(nOrb)
-  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
+  double precision,intent(in)   :: ERI(nOrb,nOrb,nOrb,nOrb)
 
 ! Local variables
 
@@ -37,11 +37,11 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
   if(doMP2) then    
        
     call wall_time(start_MP)
-    call RMP2(dotest,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF,Ec)
+    call RMP2(dotest,regularize,nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF,Ec)
     call wall_time(end_MP)
 
     t_MP = end_MP - start_MP
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP2 = ',t_MP,' seconds'
     write(*,*)
                     
   end if
@@ -53,11 +53,11 @@ subroutine RMP(dotest,doMP2,doMP3,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
   if(doMP3) then    
 
     call wall_time(start_MP)
-    call RMP3(nBas,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
+    call RMP3(nOrb,nC,nO,nV,nR,ERI,ENuc,ERHF,eHF)
     call wall_time(end_MP)
 
     t_MP = end_MP - start_MP
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP2 = ',t_MP,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP2 = ',t_MP,' seconds'
     write(*,*)
 
   end if

src/QuAcK/QuAcK.f90

@@ -15,7 +15,7 @@ program QuAcK
   logical                       :: doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW
   logical                       :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh
 
-  integer                       :: nNuc,nBas
+  integer                       :: nNuc, nBas, nOrb
   integer                       :: nC(nspin)
   integer                       :: nO(nspin)
   integer                       :: nV(nspin)
@@ -31,6 +31,7 @@ program QuAcK
   double precision,allocatable  :: X(:,:)
   double precision,allocatable  :: dipole_int_AO(:,:,:)
   double precision,allocatable  :: ERI_AO(:,:,:,:)
+  double precision,allocatable  :: Uvec(:,:), Uval(:)
 
   double precision              :: start_QuAcK,end_QuAcK,t_QuAcK
   double precision              :: start_int  ,end_int  ,t_int
@@ -68,6 +69,10 @@ program QuAcK
 
   logical                       :: dotest,doRtest,doUtest,doGtest
 
+  integer                       :: i, j, j0
+  double precision              :: acc_d, acc_nd
+  double precision, allocatable :: tmp1(:,:), tmp2(:,:)
+
 !-------------!
 ! Hello World !
 !-------------!
@@ -120,15 +125,16 @@ program QuAcK
                     doACFDT,exchange_kernel,doXBS,                                              &
                     dophBSE,dophBSE2,doppBSE,dBSE,dTDA)
 
-!------------------------------------------------!
+!-----------------------------------------------!
-! Read input information                         !
+! Read input information                        !
-!------------------------------------------------!
+!-----------------------------------------------!
-! nC   = number of core orbitals                 !
+! nC   = number of core orbitals                !
-! nO   = number of occupied orbitals             !
+! nO   = number of occupied orbitals            !
-! nV   = number of virtual orbitals (see below)  !
+! nV   = number of virtual orbitals (see below) !
-! nR   = number of Rydberg orbitals              !
+! nR   = number of Rydberg orbitals             !
-! nBas = number of basis functions (see below)   !
+! nBas = number of basis functions              !
-!------------------------------------------------!
+! nOrb = number of orbitals                     !
+!-----------------------------------------------!
 
   call read_molecule(nNuc,nO,nC,nR)
   allocate(ZNuc(nNuc),rNuc(nNuc,ncart))
@@ -149,26 +155,84 @@ program QuAcK
 
 ! Memory allocation for one- and two-electron integrals
 
-  allocate(S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas), & 
+  allocate(S(nBas,nBas))
-           ERI_AO(nBas,nBas,nBas,nBas),dipole_int_AO(nBas,nBas,ncart))
+  allocate(T(nBas,nBas))
+  allocate(V(nBas,nBas))
+  allocate(Hc(nBas,nBas))
+  allocate(ERI_AO(nBas,nBas,nBas,nBas))
+  allocate(dipole_int_AO(nBas,nBas,ncart))
 
 ! Read integrals
 
   call wall_time(start_int)
 
-  call read_integrals(nBas,S,T,V,Hc,ERI_AO)
+  call read_integrals(nBas, S(1,1), T(1,1), V(1,1), Hc(1,1), ERI_AO(1,1,1,1))
-  call read_dipole_integrals(nBas,dipole_int_AO)
+  call read_dipole_integrals(nBas, dipole_int_AO)
 
   call wall_time(end_int)
 
   t_int = end_int - start_int
   write(*,*)
-  write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for reading integrals = ',t_int,' seconds'
+  write(*,'(A65,1X,F9.3,A8)') 'Total wall time for reading integrals = ',t_int,' seconds'
   write(*,*)
 
 ! Compute orthogonalization matrix
 
-  call orthogonalization_matrix(nBas,S,X)
+  !call orthogonalization_matrix(nBas, S, X)
+
+  allocate(Uvec(nBas,nBas), Uval(nBas))
+
+  Uvec(1:nBas,1:nBas) = S(1:nBas,1:nBas)
+  call diagonalize_matrix(nBas, Uvec, Uval)
+
+  nOrb = 0
+  do i = 1, nBas
+    if(Uval(i) > 1d-6) then
+        Uval(i) = 1d0 / dsqrt(Uval(i))
+        nOrb = nOrb + 1
+    else
+      write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization'
+    end if
+  end do
+
+  write(*,'(A38)') '--------------------------------------'
+  write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas
+  write(*,'(A38,1X,I16)') 'Number of basis functions (MOs)', nOrb
+  write(*,'(A38,1X,F9.3)') ' % of discarded orbitals = ', 100.d0 * (1.d0 - dble(nOrb)/dble(nBas))
+  write(*,'(A38)') '--------------------------------------'
+  write(*,*)
+
+  j0 = nBas - nOrb
+  allocate(X(nBas,nOrb))
+  do j = j0+1, nBas
+    do i = 1, nBas
+      X(i,j-j0) = Uvec(i,j) * Uval(j)
+    enddo
+  enddo
+
+  deallocate(Uvec, Uval)
+
+  !! check if X.T S X = 1_(nOrb,nOrb)
+  !allocate(tmp1(nOrb,nBas), tmp2(nOrb,nOrb))
+  !call dgemm("T", "N", nOrb, nBas, nBas, 1.d0, &
+  !           X(1,1), nBas, S(1,1), nBas,       &
+  !           0.d0, tmp1(1,1), nOrb)
+  !call dgemm("N", "N", nOrb, nOrb, nBas, 1.d0, &
+  !           tmp1(1,1), nOrb, X(1,1), nBas,    &
+  !           0.d0, tmp2(1,1), nOrb)
+  !acc_d = 0.d0
+  !acc_nd = 0.d0
+  !do i = 1, nOrb
+  !  !write(*,'(1000(F15.7,2X))') (tmp2(i,j), j = 1, nOrb)
+  !  acc_d = acc_d + tmp2(i,i)
+  !  do j = 1, nOrb
+  !    if(j == i) cycle
+  !    acc_nd = acc_nd + dabs(tmp2(j,i))
+  !  enddo
+  !enddo
+  !print*, '     diag part: ', dabs(acc_d  - dble(nOrb))  / dble(nOrb)
+  !print*, ' non-diag part: ', acc_nd
+  !deallocate(tmp1, tmp2)
 
 !---------------------!
 ! Choose QuAcK branch !
@@ -200,7 +264,7 @@ program QuAcK
                 dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, &
                 doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,  &
                 doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,                                & 
-                nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                                            &
+                nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                               &
                 S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift,                     &
                 guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA,              &
                 maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW,  &
@@ -216,7 +280,7 @@ program QuAcK
                 dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, &
                 doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,  &
                 doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,                                & 
-                nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                                            &
+                nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                                        &
                 S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift,                     &
                 guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,spin_conserved,spin_flip,TDA,              &
                 maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW,  &
@@ -228,13 +292,13 @@ program QuAcK
 !--------------------------!
 
   if(doGQuAcK) & 
-    call GQuAcK(doGtest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,              &
+    call GQuAcK(doGtest,doGHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,                  &
-                dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA,                           &  
+                dodrCCD,dorCCD,docrCCD,dolCCD,dophRPA,dophRPAx,docrRPA,doppRPA,                               &
-                doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,                                              &
+                doG0W0,doevGW,doqsGW,doG0F2,doevGF2,doqsGF2,                                                  &
                 nNuc,nBas,sum(nC),sum(nO),sum(nV),sum(nR),ENuc,ZNuc,rNuc,S,T,V,Hc,X,dipole_int_AO,ERI_AO, &
-                maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP,                        & 
+                maxSCF_HF,max_diis_HF,thresh_HF,level_shift,guess_type,mix,reg_MP,                            &
-                maxSCF_CC,max_diis_CC,thresh_CC,TDA,maxSCF_GF,max_diis_GF,thresh_GF,lin_GF,reg_GF,eta_GF, & 
+                maxSCF_CC,max_diis_CC,thresh_CC,TDA,maxSCF_GF,max_diis_GF,thresh_GF,lin_GF,reg_GF,eta_GF,     &
-                maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW,                               &
+                maxSCF_GW,max_diis_GW,thresh_GW,TDA_W,lin_GW,reg_GW,eta_GW,                                   &
                 dophBSE,dophBSE2,doppBSE,dBSE,dTDA,doACFDT,exchange_kernel,doXBS)
 
 !-----------!
@@ -256,7 +320,7 @@ program QuAcK
   call wall_time(end_QuAcK)
 
   t_QuAcK = end_QuAcK - start_QuAcK
-  write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for QuAcK = ',t_QuAcK,' seconds'
+  write(*,'(A65,1X,F9.3,A8)') 'Total wall time for QuAcK = ',t_QuAcK,' seconds'
   write(*,*)
 
 end program 

src/QuAcK/RQuAcK.f90

@@ -2,7 +2,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
                   dodrCCD,dorCCD,docrCCD,dolCCD,doCIS,doCIS_D,doCID,doCISD,doFCI,dophRPA,dophRPAx,docrRPA,doppRPA, & 
                   doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,  &
                   doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,                                & 
-                  nNuc,nBas,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                                            &  
+                  nNuc,nBas,nOrb,nC,nO,nV,nR,ENuc,ZNuc,rNuc,                                                       &
                   S,T,V,Hc,X,dipole_int_AO,ERI_AO,maxSCF_HF,max_diis_HF,thresh_HF,level_shift,                     &
                   guess_type,mix,reg_MP,maxSCF_CC,max_diis_CC,thresh_CC,singlet,triplet,TDA,                       &
                   maxSCF_GF,max_diis_GF,renorm_GF,thresh_GF,lin_GF,reg_GF,eta_GF,maxSCF_GW,max_diis_GW,thresh_GW,  & 
@@ -29,7 +29,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   logical,intent(in)            :: doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp
   logical,intent(in)            :: doG0T0eh,doevGTeh,doqsGTeh
 
-  integer,intent(in)            :: nNuc,nBas
+  integer,intent(in)            :: nNuc,nBas,nOrb
   integer,intent(in)            :: nC
   integer,intent(in)            :: nO
   integer,intent(in)            :: nV
@@ -42,7 +42,7 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   double precision,intent(in)   :: T(nBas,nBas)
   double precision,intent(in)   :: V(nBas,nBas)
   double precision,intent(in)   :: Hc(nBas,nBas)
-  double precision,intent(in)   :: X(nBas,nBas)
+  double precision,intent(in)   :: X(nBas,nOrb)
   double precision,intent(in)   :: dipole_int_AO(nBas,nBas,ncart)
   double precision,intent(in)   :: ERI_AO(nBas,nBas,nBas,nBas)
 
@@ -109,8 +109,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
 ! Memory allocation !
 !-------------------!
 
-  allocate(cHF(nBas,nBas),eHF(nBas),PHF(nBas,nBas), &
+  allocate(cHF(nBas,nOrb))
-           dipole_int_MO(nBas,nBas,ncart),ERI_MO(nBas,nBas,nBas,nBas))
+  allocate(eHF(nOrb))
+  allocate(PHF(nBas,nBas))
+  allocate(dipole_int_MO(nOrb,nOrb,ncart))
+  allocate(ERI_MO(nOrb,nOrb,nOrb,nOrb))
 
 !---------------------!
 ! Hartree-Fock module !
@@ -119,12 +122,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doRHF) then
 
     call wall_time(start_HF)
-    call RHF(dotest,maxSCF_HF,thresh_HF,max_diis_HF,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, &
+    call RHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, &
-             nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF)
+             nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF)
     call wall_time(end_HF)
 
     t_HF = end_HF - start_HF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RHF = ',t_HF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RHF = ',t_HF,' seconds'
     write(*,*)
 
   end if
@@ -132,12 +135,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doROHF) then
 
     call wall_time(start_HF)
-    call ROHF(dotest,maxSCF_HF,thresh_HF,max_diis_HF,guess_type,mix,level_shift,nNuc,ZNuc,rNuc,ENuc, &
+    call ROHF(dotest, maxSCF_HF, thresh_HF, max_diis_HF, guess_type, mix, level_shift, nNuc, ZNuc, rNuc, ENuc, &
-              nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF)
+              nBas, nOrb, nO, S, T, V, Hc, ERI_AO, dipole_int_AO, X, ERHF, eHF, cHF, PHF)
     call wall_time(end_HF)
 
     t_HF = end_HF - start_HF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for ROHF = ',t_HF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for ROHF = ',t_HF,' seconds'
     write(*,*)
 
   end if
@@ -154,18 +157,18 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
 
   ! Read and transform dipole-related integrals
   
-  do ixyz=1,ncart
+  do ixyz = 1, ncart
-    call AOtoMO(nBas,cHF,dipole_int_AO(:,:,ixyz),dipole_int_MO(:,:,ixyz))
+    call AOtoMO(nBas, nOrb, cHF, dipole_int_AO(1,1,ixyz), dipole_int_MO(1,1,ixyz))
   end do 
 
   ! 4-index transform 
   
-  call AOtoMO_ERI_RHF(nBas,cHF,ERI_AO,ERI_MO)
+  call AOtoMO_ERI_RHF(nBas, nOrb, cHF, ERI_AO, ERI_MO)
 
   call wall_time(end_AOtoMO)
 
   t_AOtoMO = end_AOtoMO - start_AOtoMO
-  write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds'
+  write(*,'(A65,1X,F9.3,A8)') 'Total wall time for AO to MO transformation = ',t_AOtoMO,' seconds'
   write(*,*)
 
 !-----------------------------------!
@@ -177,11 +180,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(dostab) then
 
     call wall_time(start_stab)
-    call RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI_MO)
+    call RHF_stability(nOrb, nC, nO, nV, nR, nS, eHF, ERI_MO)
     call wall_time(end_stab)
 
     t_stab = end_stab - start_stab
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for stability analysis = ',t_stab,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for stability analysis = ',t_stab,' seconds'
     write(*,*)
 
   end if
@@ -189,12 +192,13 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(dosearch) then
 
     call wall_time(start_stab)
-    call RHF_search(maxSCF_HF,thresh_HF,max_diis_HF,guess_type,level_shift,nNuc,ZNuc,rNuc,ENuc, &
+    call RHF_search(maxSCF_HF, thresh_HF, max_diis_HF, guess_type, level_shift, nNuc, ZNuc, rNuc, ENuc, &
-                    nBas,nC,nO,nV,nR,S,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,X,ERHF,eHF,cHF,PHF)
+                    nBas, nOrb, nC, nO, nV, nR, S, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO,     &
+                    dipole_int_MO, X, ERHF, eHF, cHF, PHF)
     call wall_time(end_stab)
 
     t_stab = end_stab - start_stab
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for stability analysis = ',t_stab,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for stability analysis = ',t_stab,' seconds'
     write(*,*)
 
   end if
@@ -208,11 +212,11 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doMP) then
 
     call wall_time(start_MP)
-    call RMP(dotest,doMP2,doMP3,reg_MP,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
+    call RMP(dotest, doMP2, doMP3, reg_MP, nOrb, nC, nO, nV, nR, ERI_MO, ENuc, ERHF, eHF)
     call wall_time(end_MP)
 
     t_MP = end_MP - start_MP
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MP = ',t_MP,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for MP = ',t_MP,' seconds'
     write(*,*)
 
   end if
@@ -227,12 +231,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doCC) then
 
     call wall_time(start_CC)
-    call RCC(dotest,doCCD,dopCCD,doDCD,doCCSD,doCCSDT,dodrCCD,dorCCD,docrCCD,dolCCD, & 
+    call RCC(dotest, doCCD, dopCCD, doDCD, doCCSD, doCCSDT, dodrCCD, dorCCD, docrCCD, dolCCD, & 
-             maxSCF_CC,thresh_CC,max_diis_CC,nBas,nC,nO,nV,nR,ERI_MO,ENuc,ERHF,eHF)
+             maxSCF_CC, thresh_CC, max_diis_CC, nBas, nOrb, nC, nO, nV, nR, Hc, ERI_AO, ERI_MO, ENuc, ERHF, eHF, cHF)
     call wall_time(end_CC)
 
     t_CC = end_CC - start_CC
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CC = ',t_CC,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CC = ',t_CC,' seconds'
     write(*,*)
 
   end if
@@ -246,12 +250,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doCI) then
 
     call wall_time(start_CI)
-    call RCI(dotest,doCIS,doCIS_D,doCID,doCISD,doFCI,singlet,triplet,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO, &
+    call RCI(dotest, doCIS, doCIS_D, doCID, doCISD, doFCI, singlet, triplet, nOrb, &
-             eHF,ERHF,cHF,S)
+             nC, nO, nV, nR, nS, ERI_MO, dipole_int_MO, eHF, ERHF)
     call wall_time(end_CI)
 
     t_CI = end_CI - start_CI
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for CI = ',t_CI,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for CI = ',t_CI,' seconds'
     write(*,*)
 
   end if
@@ -265,12 +269,12 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doRPA) then
 
     call wall_time(start_RPA)
-    call RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_kernel,singlet,triplet,    & 
+    call RRPA(dotest, dophRPA, dophRPAx, docrRPA, doppRPA, TDA, doACFDT, exchange_kernel, singlet, triplet, & 
-              nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,cHF,S)
+              nOrb, nC, nO, nV, nR, nS, ENuc, ERHF, ERI_MO, dipole_int_MO, eHF)
     call wall_time(end_RPA)
 
     t_RPA = end_RPA - start_RPA
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPA = ',t_RPA,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPA = ',t_RPA,' seconds'
     write(*,*)
 
   end if
@@ -284,14 +288,14 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doGF) then
 
     call wall_time(start_GF)
-    call RGF(dotest,doG0F2,doevGF2,doqsGF2,doufG0F02,doG0F3,doevGF3,renorm_GF,maxSCF_GF,thresh_GF,max_diis_GF, & 
+    call RGF(dotest, doG0F2, doevGF2, doqsGF2, doufG0F02, doG0F3, doevGF3, renorm_GF, maxSCF_GF,   &
-             dophBSE,doppBSE,TDA,dBSE,dTDA,singlet,triplet,lin_GF,eta_GF,reg_GF,                               &
+             thresh_GF, max_diis_GF, dophBSE, doppBSE, TDA, dBSE, dTDA, singlet, triplet, lin_GF,  &
-             nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,                            &
+             eta_GF, reg_GF, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, &
-             dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+             S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GF)
 
     t_GF = end_GF - start_GF
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GF2 = ',t_GF,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GF2 = ',t_GF,' seconds'
     write(*,*)
 
   end if
@@ -305,14 +309,14 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doGW) then
     
     call wall_time(start_GW)
-    call RGW(dotest,doG0W0,doevGW,doqsGW,doufG0W0,doufGW,doSRGqsGW,maxSCF_GW,thresh_GW,max_diis_GW,      &
+    call RGW(dotest, doG0W0, doevGW, doqsGW, doufG0W0, doufGW, doSRGqsGW, maxSCF_GW, thresh_GW, max_diis_GW,        &
-             doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE,TDA_W,TDA,dBSE,dTDA,singlet,triplet, &
+             doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, TDA_W, TDA, dBSE, dTDA, singlet, triplet, &
-             lin_GW,eta_GW,reg_GW,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,               &  
+             lin_GW, eta_GW, reg_GW, nNuc, ZNuc, rNuc, ENuc, nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, &
-             ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+             V, Hc, ERI_AO, ERI_MO, dipole_int_AO, dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GW)
   
     t_GW = end_GW - start_GW
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GW = ',t_GW,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GW = ',t_GW,' seconds'
     write(*,*)
 
   end if
@@ -326,14 +330,15 @@ subroutine RQuAcK(dotest,doRHF,doROHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,d
   if(doGT) then
     
     call wall_time(start_GT)
-    call RGT(dotest,doG0T0pp,doevGTpp,doqsGTpp,doufG0T0pp,doG0T0eh,doevGTeh,doqsGTeh,                & 
+    call RGT(dotest, doG0T0pp, doevGTpp, doqsGTpp, doufG0T0pp, doG0T0eh, doevGTeh, doqsGTeh,                 &
-             maxSCF_GT,thresh_GT,max_diis_GT,doACFDT,exchange_kernel,doXBS,dophBSE,dophBSE2,doppBSE, & 
+             maxSCF_GT, thresh_GT, max_diis_GT, doACFDT, exchange_kernel, doXBS, dophBSE, dophBSE2, doppBSE, &
-             TDA_T,TDA,dBSE,dTDA,singlet,triplet,lin_GT,eta_GT,reg_GT,nNuc,ZNuc,rNuc,ENuc,           & 
+             TDA_T, TDA, dBSE, dTDA, singlet, triplet, lin_GT, eta_GT, reg_GT, nNuc, ZNuc, rNuc, ENuc,       &
-             nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF)
+             nBas, nOrb, nC, nO, nV, nR, nS, ERHF, S, X, T, V, Hc, ERI_AO, ERI_MO, dipole_int_AO,    &
+             dipole_int_MO, PHF, cHF, eHF)
     call wall_time(end_GT)
   
     t_GT = end_GT - start_GT
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GT = ',t_GT,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for GT = ',t_GT,' seconds'
     write(*,*)
 
   end if

src/QuAcK/UQuAcK.f90

@@ -163,8 +163,8 @@ subroutine UQuAcK(dotest,doUHF,dostab,dosearch,doMP2,doMP3,doCCD,dopCCD,doDCD,do
   ! Read and transform dipole-related integrals
 
   do ixyz=1,ncart
-    call AOtoMO(nBas,cHF(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
+    call AOtoMO(nBas,nBas,cHF(:,:,1),dipole_int_AO(:,:,ixyz),dipole_int_aa(:,:,ixyz))
-    call AOtoMO(nBas,cHF(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
+    call AOtoMO(nBas,nBas,cHF(:,:,2),dipole_int_AO(:,:,ixyz),dipole_int_bb(:,:,ixyz))
   end do 
   
   ! 4-index transform for (aa|aa) block

src/RPA/RRPA.f90

@@ -1,5 +1,5 @@
 subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_kernel,singlet,triplet, &  
-                nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,cHF,S)
+                nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF)
 
 ! Random-phase approximation module
 
@@ -29,8 +29,6 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker
   double precision,intent(in)   :: ENuc
   double precision,intent(in)   :: ERHF
   double precision,intent(in)   :: eHF(nBas)
-  double precision,intent(in)   :: cHF(nBas,nBas)
-  double precision,intent(in)   :: S(nBas,nBas)
   double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)
   double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
 
@@ -49,7 +47,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker
     call wall_time(end_RPA)
 
     t_RPA = end_RPA - start_RPA
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPA = ',t_RPA,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPA = ',t_RPA,' seconds'
     write(*,*)
 
   end if
@@ -65,7 +63,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker
     call wall_time(end_RPA)
 
     t_RPA = end_RPA - start_RPA
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for RPAx = ',t_RPA,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for RPAx = ',t_RPA,' seconds'
     write(*,*)
 
   end if
@@ -81,7 +79,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker
     call wall_time(end_RPA)
 
     t_RPA = end_RPA - start_RPA
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pp-RPA = ',t_RPA,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pp-RPA = ',t_RPA,' seconds'
     write(*,*)
 
   end if
@@ -97,7 +95,7 @@ subroutine RRPA(dotest,dophRPA,dophRPAx,docrRPA,doppRPA,TDA,doACFDT,exchange_ker
     call wall_time(end_RPA)
 
     t_RPA = end_RPA - start_RPA
-    write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for pp-RPA = ',t_RPA,' seconds'
+    write(*,'(A65,1X,F9.3,A8)') 'Total wall time for pp-RPA = ',t_RPA,' seconds'
     write(*,*)
 
   end if

src/RPA/sort_ppRPA.f90

@@ -39,9 +39,10 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
   double precision,intent(out)  :: X2(nVV,nOO)
   double precision,intent(out)  :: Y2(nOO,nOO)
 
+
 ! Memory allocation
 
- allocate(M(nOO+nVV,nOO+nVV),Z1(nOO+nVV,nVV),Z2(nOO+nVV,nOO),order1(nVV),order2(nOO))
+  allocate(M(nOO+nVV,nOO+nVV),Z1(nOO+nVV,nVV),Z2(nOO+nVV,nOO),order1(nVV),order2(nOO))
 
 ! Initializatiom
 
@@ -86,7 +87,7 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
 
     end if
 
- end do
+  end do
 
   if(minval(Om1) < 0d0 .or. ab /= nVV) call print_warning('You may have instabilities in pp-RPA!!')
   if(maxval(Om2) > 0d0 .or. ij /= nOO) call print_warning('You may have instabilities in pp-RPA!!')
@@ -111,7 +112,8 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
     call quick_sort(Om2,order2,nOO)
     call set_order(Z2,order2,nOO+nVV,nOO)
 
- end if
+  end if
+
 
 ! Orthogonalize eigenvectors
 
@@ -202,7 +204,6 @@ subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
 
   if(nVV > 0) call dgemm ('N', 'N', nOO+nVV, nVV, nOO+nVV, 1d0,  M, nOO+nVV, Z1, nOO+nVV, 0d0, tmp1, nOO+nVV)
   if(nVV > 0) call dgemm ('T', 'N', nVV    , nVV, nOO+nVV, 1d0, Z1, nOO+nVV, tmp1, nOO+nVV, 0d0, S1, nVV)
-
   if(nOO > 0) call dgemm ('N', 'N', nOO+nVV, nOO, nOO+nVV, 1d0,  M, nOO+nVV, -1d0*Z2, nOO+nVV, 0d0, tmp2, nOO+nVV)
   if(nOO > 0) call dgemm ('T', 'N', nOO    , nOO, nOO+nVV, 1d0, Z2, nOO+nVV, tmp2, nOO+nVV, 0d0, S2, nOO)
 

src/make_ninja.py

@@ -76,10 +76,21 @@ STDCXX=-lstdc++
 FIX_ORDER_OF_LIBS=-Wl,--start-group 
 """
 
+compile_olympe = """
+FC = ifort -mkl=parallel -qopenmp
+AR = ar crs
+FFLAGS = -I$IDIR -Ofast -traceback -xCORE-AVX512
+CC = icc
+CXX = icpc
+LAPACK=
+STDCXX=-lstdc++
+FIX_ORDER_OF_LIBS=-Wl,--start-group 
+"""
 
 if sys.platform in ["linux", "linux2"]:
-    compiler = compile_gfortran_linux
+#    compiler = compile_gfortran_linux
-#   compiler = compile_ifort_linux
+   compiler = compile_ifort_linux
+#   compiler = compile_olympe
 elif sys.platform == "darwin":
   compiler = compile_gfortran_mac
 else:

src/test/check_test_value.f90

@@ -9,12 +9,12 @@ subroutine check_test_value(branch)
 ! Local variables
 
   character(len=30)                  :: description
-  double precision                   :: value
+  double precision                   :: val
   double precision                   :: reference
   character(len=15)                  :: answer
 
   logical                            :: failed
-  double precision,parameter         :: cutoff = 1d-10
+  double precision,parameter         :: thresh = 1d-10
 
 ! Output variables
 
@@ -45,19 +45,19 @@ subroutine check_test_value(branch)
   do
 
     read(11,'(A30)',end=11) description
-    read(11,'(F20.15)',end=11) value
+    read(11,'(F20.15)',end=11) val
 
     read(12,*,end=12) 
     read(12,'(F20.15)',end=12) reference
 
-    if(abs(value-reference) < cutoff) then
+    if(dabs(val-reference)/(1d-15+dabs(reference)) < thresh) then
       answer = '.......... :-)'
     else
       answer = '.......... :-( '
       failed = .true.
     end if
     write(*,'(1X,A1,1X,A30,1X,A1,1X,3F15.10,1X,A1,1X,A15,1X,A1)') & 
-      '|',description,'|',value,reference,abs(value-reference),'|',answer,'|'
+      '|',description,'|',val,reference,abs(val-reference),'|',answer,'|'
 
   end do
 

src/test/dump_test_value.f90

@@ -1,4 +1,4 @@
-subroutine dump_test_value(branch,description,value)
+subroutine dump_test_value(branch, description, val)
 
   implicit none
 
@@ -7,7 +7,7 @@ subroutine dump_test_value(branch,description,value)
   character(len=1),intent(in)        :: branch
   character(len=*),intent(in)        :: description
 
-  double precision,intent(in)        :: value
+  double precision,intent(in)        :: val
  
 ! Local variables
 
@@ -15,18 +15,19 @@ subroutine dump_test_value(branch,description,value)
 
   if(branch == 'R') then 
 
-    write(11,*) trim(description)
+    !write(1231597, '(A, ": ", F20.15)') '"' // trim(description) // '"', val
-    write(11,'(F20.15)') value
+    write(1231597, *) trim(description)
+    write(1231597, '(F20.15)') val
 
   elseif(branch == 'U') then 
 
-    write(12,*) trim(description)
+    write(1232584,*) trim(description)
-    write(12,'(F20.15)') value
+    write(1232584,'(F20.15)') val
 
   elseif(branch == 'G') then
 
-    write(13,*) trim(description)
+    write(1234181,*) trim(description)
-    write(13,'(F20.15)') value
+    write(1234181,'(F20.15)') val
 
   else
 

src/test/init_test.f90

@@ -12,10 +12,10 @@ subroutine init_test(doRtest,doUtest,doGtest)
 
 ! Output variables
 
-  if(doRtest) open(unit=11,file='test/Rtest.dat')
+  if(doRtest) open(unit=1231597, file='test/Rtest.dat')
 
-  if(doUtest) open(unit=12,file='test/Utest.dat')
+  if(doUtest) open(unit=1232584, file='test/Utest.dat')
 
-  if(doGtest) open(unit=13,file='test/Gtest.dat')
+  if(doGtest) open(unit=1234181, file='test/Gtest.dat')
 
 end subroutine

src/test/stop_test.f90

@@ -12,10 +12,10 @@ subroutine stop_test(doRtest,doUtest,doGtest)
 
 ! Output variables
 
-  if(doRtest) close(unit=11)
+  if(doRtest) close(unit=1231597)
 
-  if(doUtest) close(unit=12)
+  if(doUtest) close(unit=1231597)
 
-  if(doGtest) close(unit=13)
+  if(doGtest) close(unit=1234181)
 
 end subroutine

src/utils/level_shifting.f90

@@ -1,4 +1,4 @@
-subroutine level_shifting(level_shift,nBas,nO,S,c,F)
+subroutine level_shifting(level_shift, nBas, nOrb, nO, S, c, F)
 
 ! Perform level-shifting on the Fock matrix
 
@@ -7,10 +7,10 @@ subroutine level_shifting(level_shift,nBas,nO,S,c,F)
 ! Input variables
 
   double precision,intent(in)   :: level_shift
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas, nOrb
   integer,intent(in)            :: nO
   double precision,intent(in)   :: S(nBas,nBas)
-  double precision,intent(in)   :: c(nBas,nBas)
+  double precision,intent(in)   :: c(nBas,nOrb)
 
 ! Local variables
 
@@ -23,15 +23,17 @@ subroutine level_shifting(level_shift,nBas,nO,S,c,F)
 
   double precision,intent(inout):: F(nBas,nBas)
 
-  allocate(F_MO(nBas,nBas),Sc(nBas,nBas))
+  allocate(F_MO(nOrb,nOrb), Sc(nBas,nOrb))
 
-  F_MO(:,:) = matmul(transpose(c),matmul(F,c))
+  F_MO(:,:) = matmul(transpose(c), matmul(F, c))
 
-  do a=nO+1,nBas
+  do a = nO+1, nOrb
     F_MO(a,a) = F_MO(a,a) + level_shift
   end do
 
-  Sc(:,:) = matmul(S,c)
+  Sc(:,:) = matmul(S, c)
-  F(:,:) = matmul(Sc,matmul(F_MO,transpose(Sc)))
+  F(:,:) = matmul(Sc, matmul(F_MO, transpose(Sc)))
+
+  deallocate(F_MO, Sc)
 
 end subroutine 

src/utils/non_sym_diag.f90

@@ -0,0 +1,571 @@
+
+! ---
+
+subroutine diagonalize_nonsym_matrix(N, A, L, e_re, thr_d, thr_nd, thr_deg, imp_bio, verbose)
+
+  ! Diagonalize a non-symmetric matrix A
+  ! 
+  ! Output
+  !   right-eigenvectors are saved in A
+  !    left-eigenvectors are saved in L
+  !         eigenvalues  are saved in e = e_re + i e_im
+
+  implicit none
+
+  integer,          intent(in)    :: N
+  logical,          intent(in)    :: imp_bio, verbose
+  double precision, intent(in)    :: thr_d, thr_nd, thr_deg
+  double precision, intent(inout) :: A(N,N)
+  double precision, intent(out)   :: e_re(N), L(N,N)
+
+  integer                         :: i, j, ii
+  integer                         :: lwork, info
+  double precision                :: accu_d, accu_nd
+  integer,          allocatable   :: iorder(:), deg_num(:)
+  double precision, allocatable   :: Atmp(:,:), Ltmp(:,:), work(:), e_im(:)
+  double precision, allocatable   :: S(:,:)
+
+  if(verbose) then
+    print*, ' Starting a non-Hermitian diagonalization ...'
+    print*, ' Good Luck ;)'
+    print*, ' imp_bio = ', imp_bio
+  endif
+
+  ! ---
+  ! diagonalize
+
+  allocate(Atmp(N,N), e_im(N))
+  Atmp(1:N,1:N) = A(1:N,1:N)
+
+  allocate(work(1))
+  lwork = -1
+  call dgeev('V', 'V', N, Atmp, N, e_re, e_im, L, N, A, N, work, lwork, info)
+  if(info .gt. 0) then
+    print*,'dgeev failed !!', info
+    stop
+  endif
+
+  lwork = max(int(work(1)), 1)
+  deallocate(work)
+  allocate(work(lwork))
+
+  call dgeev('V', 'V', N, Atmp, N, e_re, e_im, L, N, A, N, work, lwork, info)
+  if(info .ne. 0) then
+    print*,'dgeev failed !!', info
+    stop
+  endif
+
+  deallocate(Atmp, WORK)
+
+
+  ! ---
+  ! check if eigenvalues are real
+
+  i  = 1
+  ii = 0
+  do while(i .le. N)
+    if(dabs(e_im(i)) .gt. 1.d-12) then
+      ii = ii + 1
+      if(verbose) then
+        print*, ' Warning: complex eigenvalue !'
+        print*, i, e_re(i), e_im(i)
+        if(dabs(e_im(i)/e_re(i)) .lt. 1.d-6) then
+          print*, ' small enouph to be igored'
+        else
+          print*, ' IMAGINARY PART IS SIGNIFANT !!!'
+        endif
+      endif
+    endif
+    i = i + 1
+  enddo
+
+  if(verbose) then
+    if(ii .eq. 0) print*, ' congratulations :) eigenvalues are real-valued !!'
+  endif
+
+
+  ! ---
+  ! track & sort the real eigenvalues 
+
+  allocate(Atmp(N,N), Ltmp(N,N), iorder(N))
+
+  do i = 1, N
+    iorder(i) = i
+  enddo
+  call quick_sort(e_re, iorder, N)
+
+  Atmp(:,:) = A(:,:)
+  Ltmp(:,:) = L(:,:)
+  do i = 1, N
+    do j = 1, N
+      A(j,i) = Atmp(j,iorder(i))
+      L(j,i) = Ltmp(j,iorder(i))
+    enddo
+  enddo
+
+  deallocate(Atmp, Ltmp, iorder)
+
+
+
+
+  ! ---
+  ! check bi-orthog
+
+  allocate(S(N,N))
+  call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .false., verbose)
+
+  if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(N))/dble(N) .lt. thr_d)) then
+
+    if(verbose) then
+      print *, ' lapack vectors are normalized and bi-orthogonalized'
+    endif
+
+  elseif((accu_nd .lt. thr_nd) .and. (dabs(accu_d - dble(N)) .gt. thr_d)) then
+
+    if(verbose) then
+      print *, ' lapack vectors are not normalized but bi-orthogonalized'
+    endif
+
+    call check_biorthog_binormalize(N, N, L, A, thr_d, thr_nd, .true.)
+    call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .true., verbose)
+
+  else
+
+    if(verbose) then
+      print *, ' lapack vectors are not normalized neither bi-orthogonalized'
+    endif
+
+    allocate(deg_num(N))
+    call reorder_degen_eigvec(N, thr_deg, deg_num, e_re, L, A)
+    call impose_biorthog_degen_eigvec(N, deg_num, e_re, L, A)
+    deallocate(deg_num)
+
+    call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .false., verbose)
+    if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(N))/dble(N) .lt. thr_d)) then
+      if(verbose) then
+        print *, ' lapack vectors are now normalized and bi-orthogonalized'
+      endif
+    elseif((accu_nd .lt. thr_nd) .and. (dabs(accu_d - dble(N)) .gt. thr_d)) then
+      if(verbose) then
+        print *, ' lapack vectors are now not normalized but bi-orthogonalized'
+      endif
+      call check_biorthog_binormalize(N, N, L, A, thr_d, thr_nd, .true.)
+      call check_biorthog(N, N, L, A, accu_d, accu_nd, S, thr_d, thr_nd, .true., verbose)
+    else
+      if(verbose) then
+        print*, ' bi-orthogonalization failed !'
+      endif
+      if(imp_bio) then
+        print*, ' bi-orthogonalization failed !'
+        deallocate(S)
+        stop
+      endif
+    endif
+
+  endif
+
+  deallocate(S)
+  return
+
+end
+
+! ---
+
+subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot, verbose)
+
+  implicit none
+
+  integer,          intent(in)  :: n, m
+  logical,          intent(in)  :: stop_ifnot, verbose
+  double precision, intent(in)  :: Vl(n,m), Vr(n,m)
+  double precision, intent(in)  :: thr_d, thr_nd
+  double precision, intent(out) :: accu_d, accu_nd, S(m,m)
+
+  integer                       :: i, j
+  double precision, allocatable :: SS(:,:)
+
+  if(verbose) then
+    print *, ' check bi-orthogonality'
+  endif
+
+  ! ---
+
+  call dgemm( 'T', 'N', m, m, n, 1.d0          &
+            , Vl, size(Vl, 1), Vr, size(Vr, 1) &
+            , 0.d0, S, size(S, 1) )
+
+  accu_d  = 0.d0
+  accu_nd = 0.d0
+  do i = 1, m
+    do j = 1, m
+      if(i==j) then
+        accu_d = accu_d + dabs(S(i,i))
+      else
+        accu_nd = accu_nd + S(j,i) * S(j,i)
+      endif
+    enddo
+  enddo
+  accu_nd = dsqrt(accu_nd) / dble(m)
+
+  if(verbose) then
+    if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then
+      print *, ' non bi-orthogonal vectors !'
+      print *, ' accu_nd = ', accu_nd
+      print *, ' accu_d  = ', dabs(accu_d-dble(m))/dble(m)
+    else
+      print *, ' vectors are bi-orthogonals'
+    endif
+  endif
+
+  ! ---
+
+  if(stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d)) then
+    print *, ' non bi-orthogonal vectors !'
+    print *, ' accu_nd = ', accu_nd
+    print *, ' accu_d  = ', dabs(accu_d-dble(m))/dble(m)
+    stop
+  endif
+
+end
+
+! ---
+
+subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
+
+  implicit none
+
+  integer,          intent(in)    :: n, m
+  logical,          intent(in)    :: stop_ifnot
+  double precision, intent(in)    :: thr_d, thr_nd
+  double precision, intent(inout) :: Vl(n,m), Vr(n,m)
+
+  integer                         :: i, j
+  double precision                :: accu_d, accu_nd, s_tmp
+  double precision, allocatable   :: S(:,:)
+
+  ! ---
+
+  allocate(S(m,m))
+  call dgemm( 'T', 'N', m, m, n, 1.d0          &
+            , Vl, size(Vl, 1), Vr, size(Vr, 1) &
+            , 0.d0, S, size(S, 1) )
+
+  do i = 1, m
+    if(S(i,i) .lt. 0.d0) then
+      do j = 1, n
+        Vl(j,i) = -1.d0 * Vl(j,i)
+      enddo
+      S(i,i) = -S(i,i)
+    endif
+  enddo
+
+  accu_d  = 0.d0
+  accu_nd = 0.d0
+  do i = 1, m
+    do j = 1, m
+      if(i==j) then
+        accu_d = accu_d + S(i,i)
+      else
+        accu_nd = accu_nd + S(j,i) * S(j,i)
+      endif
+    enddo
+  enddo
+  accu_nd = dsqrt(accu_nd) / dble(m)
+
+  ! ---
+
+  if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
+
+    do i = 1, m
+      if(S(i,i) <= 0.d0) then
+        print *, ' negative overlap !'
+        print *, i, S(i,i)
+        exit
+      endif
+      if(dabs(S(i,i) - 1.d0) .gt. thr_d) then
+        s_tmp = 1.d0 / dsqrt(S(i,i))
+        do j = 1, n
+          Vl(j,i) = Vl(j,i) * s_tmp
+          Vr(j,i) = Vr(j,i) * s_tmp
+        enddo
+      endif
+
+    enddo
+
+  endif
+
+  ! ---
+
+  call dgemm( 'T', 'N', m, m, n, 1.d0          &
+            , Vl, size(Vl, 1), Vr, size(Vr, 1) &
+            , 0.d0, S, size(S, 1) )
+
+  accu_d  = 0.d0
+  accu_nd = 0.d0
+  do i = 1, m
+    do j = 1, m
+      if(i==j) then
+        accu_d = accu_d + S(i,i)
+      else
+        accu_nd = accu_nd + S(j,i) * S(j,i)
+      endif
+    enddo
+  enddo
+  accu_nd = dsqrt(accu_nd) / dble(m)
+
+  deallocate(S)
+
+  ! ---
+
+  if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d)) ) then
+    print *, accu_nd, thr_nd
+    print *, dabs(accu_d-dble(m))/dble(m), thr_d
+    print *, ' biorthog_binormalize failed !'
+    stop
+  endif
+
+end
+
+! ---
+
+subroutine reorder_degen_eigvec(n, thr_deg, deg_num, e0, L0, R0)
+
+  implicit none
+
+  integer,          intent(in)    :: n
+  double precision, intent(in)    :: thr_deg
+  double precision, intent(inout) :: e0(n), L0(n,n), R0(n,n)
+  integer,          intent(out)   :: deg_num(n)
+
+  logical                         :: complex_root
+  integer                         :: i, j, k, m, ii, j_tmp
+  double precision                :: ei, ej, de
+  double precision                :: accu_d, accu_nd
+  double precision                :: e0_tmp, L0_tmp(n), R0_tmp(n)
+  double precision, allocatable   :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
+
+  do i = 1, n
+    deg_num(i) = 1
+  enddo
+
+  do i = 1, n-1
+    ei = e0(i)
+
+    ! already considered in degen vectors
+    if(deg_num(i) .eq. 0) cycle
+
+    ii = 0
+    do j = i+1, n
+      ej = e0(j)
+      de = dabs(ei - ej)
+
+      if(de .lt. thr_deg) then
+        ii = ii + 1
+
+        j_tmp = i + ii
+
+        deg_num(j_tmp) = 0
+
+        e0_tmp    = e0(j_tmp)
+        e0(j_tmp) = e0(j)
+        e0(j)     = e0_tmp
+
+        L0_tmp(1:n)   = L0(1:n,j_tmp)
+        L0(1:n,j_tmp) = L0(1:n,j)
+        L0(1:n,j)     = L0_tmp(1:n)
+
+        R0_tmp(1:n)   = R0(1:n,j_tmp)
+        R0(1:n,j_tmp) = R0(1:n,j)
+        R0(1:n,j)     = R0_tmp(1:n)
+      endif
+    enddo
+
+    deg_num(i) = ii + 1
+  enddo
+
+  ii = 0
+  do i = 1, n
+    if(deg_num(i) .gt. 1) then
+      ii = ii + 1
+    endif
+  enddo
+
+  if(ii .eq. 0) then
+    print*, ' WARNING: bi-orthogonality is lost but there is no degeneracies'
+    print*, ' rotations may change energy'
+    stop
+  endif
+
+end
+
+! ---
+
+subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
+
+  implicit none
+
+  integer,          intent(in)    :: n, deg_num(n)
+  double precision, intent(in)    :: e0(n)
+  double precision, intent(inout) :: L0(n,n), R0(n,n)
+
+  logical                         :: complex_root
+  integer                         :: i, j, k, m
+  double precision                :: ei, ej, de
+  double precision                :: accu_d, accu_nd
+  double precision, allocatable   :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
+
+  !do i = 1, n
+  !  if(deg_num(i) .gt. 1) then
+  !    print *, ' degen on', i, deg_num(i), e0(i)
+  !  endif
+  !enddo
+
+  ! ---
+
+  do i = 1, n
+    m = deg_num(i)
+
+    if(m .gt. 1) then
+
+      allocate(L(n,m), R(n,m), S(m,m))
+
+      do j = 1, m
+        L(1:n,j) = L0(1:n,i+j-1)
+        R(1:n,j) = R0(1:n,i+j-1)
+      enddo
+
+      ! ---
+
+      call dgemm( 'T', 'N', m, m, n, 1.d0      &
+                , L, size(L, 1), R, size(R, 1) &
+                , 0.d0, S, size(S, 1) )
+
+      accu_nd = 0.d0
+      do j = 1, m
+        do k = 1, m
+          if(j==k) cycle
+          accu_nd = accu_nd + dabs(S(j,k))
+        enddo
+      enddo
+
+      if(accu_nd .lt. 1d-12) then
+        deallocate(S, L, R)
+        cycle
+      endif
+
+      call impose_biorthog_svd(n, m, L, R)
+
+      call dgemm( 'T', 'N', m, m, n, 1.d0      &
+                , L, size(L, 1), R, size(R, 1) &
+                , 0.d0, S, size(S, 1) )
+      accu_nd = 0.d0
+      do j = 1, m
+        do k = 1, m
+          if(j==k) cycle
+          accu_nd = accu_nd + dabs(S(j,k))
+        enddo
+      enddo
+      if(accu_nd .gt. 1d-12) then
+        print*, ' accu_nd =', accu_nd
+        print*, ' your strategy for degenerates orbitals failed !'
+        print*, m, 'deg on', i
+        stop
+      endif
+
+      deallocate(S)
+
+      ! ---
+
+      do j = 1, m
+        L0(1:n,i+j-1) = L(1:n,j)
+        R0(1:n,i+j-1) = R(1:n,j)
+      enddo
+
+      deallocate(L, R)
+
+    endif
+  enddo
+
+end
+
+! ---
+
+subroutine impose_biorthog_svd(n, m, L, R)
+
+  implicit none
+
+  integer,          intent(in)    :: n, m
+  double precision, intent(inout) :: L(n,m), R(n,m)
+
+  integer                         :: i, j, num_linear_dependencies
+  double precision                :: threshold
+  double precision, allocatable   :: S(:,:), tmp(:,:)
+  double precision, allocatable   :: U(:,:), V(:,:), Vt(:,:), D(:)
+
+  allocate(S(m,m))
+
+  call dgemm( 'T', 'N', m, m, n, 1.d0      &
+            , L, size(L, 1), R, size(R, 1) &
+            , 0.d0, S, size(S, 1) )
+
+  ! ---
+
+  allocate(U(m,m), Vt(m,m), D(m))
+
+  call svd(S, m, U, m, D, Vt, m, m, m)
+
+  deallocate(S)
+
+  threshold               = 1.d-6
+  num_linear_dependencies = 0
+  do i = 1, m
+    if(abs(D(i)) <= threshold) then
+      D(i) = 0.d0
+      num_linear_dependencies = num_linear_dependencies + 1
+    else
+      D(i) = 1.d0 / dsqrt(D(i))
+    endif
+  enddo
+  if(num_linear_dependencies > 0) then
+    write(*,*) ' linear dependencies = ', num_linear_dependencies
+    write(*,*) ' m                   = ', m
+    stop
+  endif
+
+  allocate(V(m,m))
+  do i = 1, m
+    do j = 1, m
+      V(j,i) = Vt(i,j)
+    enddo
+  enddo
+  deallocate(Vt)
+
+  ! ---
+
+  ! R <-- R x V x D^{-0.5}
+  ! L <-- L x U x D^{-0.5}
+
+  do i = 1, m
+    do j = 1, m
+      V(j,i) = V(j,i) * D(i)
+      U(j,i) = U(j,i) * D(i)
+    enddo
+  enddo
+
+  allocate(tmp(n,m))
+  tmp(:,:) = R(:,:)
+  call dgemm( 'N', 'N', n, m, m, 1.d0          &
+            , tmp, size(tmp, 1), V, size(V, 1) &
+            , 0.d0, R, size(R, 1))
+
+  tmp(:,:) = L(:,:)
+  call dgemm( 'N', 'N', n, m, m, 1.d0          &
+            , tmp, size(tmp, 1), U, size(U, 1) &
+            , 0.d0, L, size(L, 1))
+
+  deallocate(tmp, U, V, D)
+
+end
+
+! ---
+

src/utils/orthogonalization_matrix.f90

@@ -1,4 +1,7 @@
-subroutine orthogonalization_matrix(nBas,S,X)
+
+! ---
+
+subroutine orthogonalization_matrix(nBas, S, X)
 
 ! Compute the orthogonalization matrix X
 
@@ -35,14 +38,32 @@ subroutine orthogonalization_matrix(nBas,S,X)
 
   if(ortho_type == 1) then
 
+    !
+    ! S V = V s   where 
+    !
+    !     V.T V = 1 and s > 0 (S is positive def)
+    !
+    ! S = V s V.T
+    !   = V s^0.5 s^0.5 V.T
+    !   = V s^0.5 V.T V s^0.5 V.T
+    !   = S^0.5 S^0.5 
+    !
+    ! where
+    !
+    !     S^0.5 = V s^0.5 V.T
+    !
+    ! X = S^(-0.5)
+    !   = V s^(-0.5) V.T
+    !
+
 !   write(*,*)
 !   write(*,*) ' Lowdin orthogonalization'
 !   write(*,*)
 
     Uvec = S
-    call diagonalize_matrix(nBas,Uvec,Uval)
+    call diagonalize_matrix(nBas, Uvec, Uval)
 
-    do i=1,nBas
+    do i = 1, nBas
 
       if(Uval(i) < thresh) then 
 
@@ -50,11 +71,11 @@ subroutine orthogonalization_matrix(nBas,S,X)
 
       end if
 
-      Uval(i) = 1d0/sqrt(Uval(i))
+      Uval(i) = 1d0 / dsqrt(Uval(i))
 
     end do
     
-    call ADAt(nBas,Uvec,Uval,X)
+    call ADAt(nBas, Uvec(1,1), Uval(1), X(1,1))
 
   elseif(ortho_type == 2) then
 
@@ -63,13 +84,13 @@ subroutine orthogonalization_matrix(nBas,S,X)
 !   write(*,*)
 
     Uvec = S
-    call diagonalize_matrix(nBas,Uvec,Uval)
+    call diagonalize_matrix(nBas, Uvec, Uval)
 
-    do i=1,nBas
+    do i = 1, nBas
 
       if(Uval(i) > thresh) then 
 
-        Uval(i) = 1d0/sqrt(Uval(i))
+        Uval(i) = 1d0 / dsqrt(Uval(i))
 
       else
 
@@ -79,7 +100,7 @@ subroutine orthogonalization_matrix(nBas,S,X)
 
     end do
     
-    call AD(nBas,Uvec,Uval)
+    call AD(nBas, Uvec, Uval)
     X = Uvec
  
   elseif(ortho_type == 3) then
@@ -117,3 +138,6 @@ subroutine orthogonalization_matrix(nBas,S,X)
   end if
 
 end subroutine 
+
+! ---
+

src/utils/read_basis_pyscf.f90

@@ -21,13 +21,13 @@ subroutine read_basis_pyscf(nBas,nO,nV)
 !------------------------------------------------------------------------
 
   open(unit=3,file='int/nBas.dat')
-  read(3,*) nBas
+    read(3, *) nBas
   close(unit=3)
 
-  write(*,'(A28)') '------------------'
+!  write(*,'(A38)') '--------------------------------------'
-  write(*,'(A28,1X,I16)') 'Number of basis functions',nBas
+!  write(*,'(A38,1X,I16)') 'Number of basis functions (AOs)', nBas
-  write(*,'(A28)') '------------------'
+!  write(*,'(A38)') '--------------------------------------'
-  write(*,*)
+!  write(*,*)
 
 ! Number of virtual orbitals
 

src/utils/read_integrals.f90

@@ -1,4 +1,4 @@
-subroutine read_integrals(nBas,S,T,V,Hc,G)
+subroutine read_integrals(nBas_AOs, S, T, V, Hc, G)
 
 ! Read one- and two-electron integrals from files
 
@@ -7,7 +7,7 @@ subroutine read_integrals(nBas,S,T,V,Hc,G)
 
 ! Input variables
 
-  integer,intent(in)            :: nBas
+  integer,intent(in)            :: nBas_AOs
 
 ! Local variables
 
@@ -18,11 +18,11 @@ subroutine read_integrals(nBas,S,T,V,Hc,G)
 
 ! Output variables
 
-  double precision,intent(out)  :: S(nBas,nBas)
+  double precision,intent(out)  :: S(nBas_AOs,nBas_AOs)
-  double precision,intent(out)  :: T(nBas,nBas)
+  double precision,intent(out)  :: T(nBas_AOs,nBas_AOs)
-  double precision,intent(out)  :: V(nBas,nBas)
+  double precision,intent(out)  :: V(nBas_AOs,nBas_AOs)
-  double precision,intent(out)  :: Hc(nBas,nBas)
+  double precision,intent(out)  :: Hc(nBas_AOs,nBas_AOs)
-  double precision,intent(out)  :: G(nBas,nBas,nBas,nBas)
+  double precision,intent(out)  :: G(nBas_AOs,nBas_AOs,nBas_AOs,nBas_AOs)
 
 ! Open file with integrals
 
@@ -35,7 +35,6 @@ subroutine read_integrals(nBas,S,T,V,Hc,G)
   open(unit=8 ,file='int/Ov.dat')
   open(unit=9 ,file='int/Kin.dat')
   open(unit=10,file='int/Nuc.dat')
-  open(unit=11,file='int/ERI.dat')
 
   open(unit=21,file='int/x.dat')
   open(unit=22,file='int/y.dat')
@@ -75,31 +74,29 @@ subroutine read_integrals(nBas,S,T,V,Hc,G)
 
   Hc(:,:) = T(:,:) + V(:,:)
 
-! Read nuclear integrals
+! Read 2e-integrals
 
-  G(:,:,:,:) = 0d0
+!  ! formatted file
-  do 
+!  open(unit=11, file='int/ERI.dat')
-    read(11,*,end=11) mu,nu,la,si,ERI
+!  G(:,:,:,:) = 0d0
+!  do 
+!    read(11,*,end=11) mu, nu, la, si, ERI
+!    ERI = lambda*ERI
+!    G(mu,nu,la,si) = ERI    !   <12|34>
+!    G(la,nu,mu,si) = ERI    !   <32|14>
+!    G(mu,si,la,nu) = ERI    !   <14|32>
+!    G(la,si,mu,nu) = ERI    !   <34|12>
+!    G(si,mu,nu,la) = ERI    !   <41|23>
+!    G(nu,la,si,mu) = ERI    !   <23|41>
+!    G(nu,mu,si,la) = ERI    !   <21|43>
+!    G(si,la,nu,mu) = ERI    !   <43|21>
+!  end do
+!  11 close(unit=11)
 
-    ERI = lambda*ERI
+  ! binary file
-!   <12|34>
+  open(unit=11, file='int/ERI.bin', form='unformatted', access='stream')
-    G(mu,nu,la,si) = ERI
+  read(11) G
-!   <32|14>
+  close(11)
-    G(la,nu,mu,si) = ERI
-!   <14|32>
-    G(mu,si,la,nu) = ERI
-!   <34|12>
-    G(la,si,mu,nu) = ERI
-!   <41|23>
-    G(si,mu,nu,la) = ERI
-!   <23|41>
-    G(nu,la,si,mu) = ERI
-!   <21|43>
-    G(nu,mu,si,la) = ERI
-!   <43|21>
-    G(si,la,nu,mu) = ERI
-  end do
-  11 close(unit=11)
 
 
 ! Print results
@@ -107,24 +104,24 @@ subroutine read_integrals(nBas,S,T,V,Hc,G)
     write(*,'(A28)') '----------------------'
     write(*,'(A28)') 'Overlap integrals'
     write(*,'(A28)') '----------------------'
-    call matout(nBas,nBas,S)
+    call matout(nBas_AOs,nBas_AOs,S)
     write(*,*)
     write(*,'(A28)') '----------------------'
     write(*,'(A28)') 'Kinetic integrals'
     write(*,'(A28)') '----------------------'
-    call matout(nBas,nBas,T)
+    call matout(nBas_AOs,nBas_AOs,T)
     write(*,*)
     write(*,'(A28)') '----------------------'
     write(*,'(A28)') 'Nuclear integrals'
     write(*,'(A28)') '----------------------'
-    call matout(nBas,nBas,V)
+    call matout(nBas_AOs,nBas_AOs,V)
     write(*,*)
     write(*,'(A28)') '----------------------'
     write(*,'(A28)') 'Electron repulsion integrals'
     write(*,'(A28)') '----------------------'
-    do la=1,nBas
+    do la=1,nBas_AOs
-      do si=1,nBas
+      do si=1,nBas_AOs
-        call matout(nBas,nBas,G(1,1,la,si))
+        call matout(nBas_AOs, nBas_AOs, G(1,1,la,si))
       end do
     end do
     write(*,*)

src/utils/utils.f90

@@ -65,7 +65,7 @@ subroutine diagonal_matrix(N,D,A)
 end subroutine
 
 !------------------------------------------------------------------------
-subroutine matrix_exponential(N,A,ExpA)
+subroutine matrix_exponential(N, A, ExpA)
 
 ! Compute Exp(A)
 
@@ -81,7 +81,7 @@ subroutine matrix_exponential(N,A,ExpA)
 
 ! Memory allocation
 
-  allocate(W(N,N),tau(N),t(N,N))
+  allocate(W(N,N), tau(N), t(N,N))
 
 ! Initialize
 
@@ -89,8 +89,8 @@ subroutine matrix_exponential(N,A,ExpA)
 
 ! Diagonalize
 
-  W(:,:) = - matmul(A,A)
+  W(:,:) = - matmul(A, A)
-  call diagonalize_matrix(N,W,tau)
+  call diagonalize_matrix(N, W, tau)
 
 ! do i=1,N
 !   tau(i) = max(abs(tau(i)),1d-14)
@@ -99,16 +99,18 @@ subroutine matrix_exponential(N,A,ExpA)
 
 ! Construct cos part
 
-  call diagonal_matrix(N,cos(tau),t)
+  call diagonal_matrix(N, cos(tau), t)
-  t(:,:) = matmul(t,transpose(W))
+  t(:,:) = matmul(t, transpose(W))
-  ExpA(:,:) = ExpA(:,:) + matmul(W,t) 
+  ExpA(:,:) = ExpA(:,:) + matmul(W, t) 
 
 ! Construct sin part
 
-  call diagonal_matrix(N,sin(tau)/tau,t)
+  call diagonal_matrix(N, sin(tau)/tau, t)
-  t(:,:) = matmul(t,transpose(W))
+  t(:,:) = matmul(t, transpose(W))
-  t(:,:) = matmul(t,A)
+  t(:,:) = matmul(t, A)
-  ExpA(:,:) = ExpA(:,:) + matmul(W,t)
+  ExpA(:,:) = ExpA(:,:) + matmul(W, t)
+
+  deallocate(W, tau, t)
 
 end subroutine
 
@@ -375,15 +377,29 @@ subroutine ADAt(N,A,D,B)
 
   double precision,intent(out)  :: B(N,N)
 
-  B = 0d0
+  double precision, allocatable :: tmp(:,:)
 
-  do i=1,N
+  allocate(tmp(N,N))
-    do j=1,N
+  !$OMP PARALLEL DEFAULT(NONE) PRIVATE(i, j) SHARED(N, A, D, tmp)
-      do k=1,N
+  !$OMP DO
-        B(i,k) = B(i,k) + A(i,j)*D(j)*A(k,j)
+  do i = 1, N
-      end do
+    do j = 1, N
-    end do
+      tmp(i,j) = D(i) * A(j,i)
-  end do
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call dgemm("N", "N", N, N, N, 1.d0, A(1,1), N, tmp(1,1), N, 0.d0, B(1,1), N)
+  deallocate(tmp)
+
+!  B = 0d0
+!  do i=1,N
+!    do j=1,N
+!      do k=1,N
+!        B(i,k) = B(i,k) + A(i,j)*D(j)*A(k,j)
+!      end do
+!    end do
+!  end do
 
 end subroutine 
 !------------------------------------------------------------------------

src/utils/wrap_lapack.f90

@@ -31,6 +31,8 @@ subroutine diagonalize_general_matrix(N,A,WR,VR)
 
   call dgeev('V','V',N,A,N,WR,WI,VL,N,VR,N,work,lwork,info)
 
+  deallocate(work, WI, VL)
+
   if(info /= 0) then 
     print*,'Problem in diagonalize_general_matrix (dgeev)!!'
   end if
@@ -67,6 +69,8 @@ subroutine diagonalize_matrix(N,A,e)
   allocate(work(lwork))
 
   call dsyev('V','U',N,A,N,e,work,lwork,info)
+
+  deallocate(work)
  
   if(info /= 0) then 
     print*,'Problem in diagonalize_matrix (dsyev)!!'

test/export_tobench.py

@@ -0,0 +1,26 @@
+
+import sys
+
+
+def read_quantities_from_file(filename):
+    quantities = {}
+
+    with open(filename, 'r') as file:
+        lines = file.readlines()
+        for i in range(0, len(lines), 2):
+            # Remove any leading or trailing whitespace/newline characters
+            quantity_name = lines[i].strip()
+            quantity_value = float(lines[i+1].strip())
+            quantities[quantity_name] = quantity_value
+
+    return quantities
+
+def print_quantities(quantities):
+    for key, value in quantities.items():
+        print(f'"{key}": {value},')
+
+filename = sys.argv[1]
+
+quantities = read_quantities_from_file(filename)
+print_quantities(quantities)
+

tests/.gitignore

@@ -0,0 +1,7 @@
+
+FeatherBench.db
+FeatherBench.json
+
+*.xyz
+work
+

tests/create_database.py

@@ -0,0 +1,52 @@
+
+import argparse
+
+from molecule import save_molecules_to_json, load_molecules_from_json
+from molecule import create_database, add_molecule_to_db, remove_database
+
+from feather_bench import FeatherBench
+
+
+parser = argparse.ArgumentParser(description="Benchmark Data Sets")
+
+parser.add_argument(
+    '-s', '--set_type',
+    choices=['light', 'medium', 'heavy'],
+    default='light',
+    help="Specify the type of data set: light (default), medium, or heavy."
+)
+
+
+args = parser.parse_args()
+
+if args.set_type == 'light':
+    bench = 'FeatherBench'
+    bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench)
+elif args.set_type == 'medium':
+    bench = 'BalanceBench'
+    bench_title = "\n\nSelected Medium Benchmark: {}\n\n".format(bench)
+elif args.set_type == 'heavy':
+    bench = 'TitanBench'
+    bench_title = "\n\nSelected Heavy Benchmark: {}\n\n".format(bench)
+else:
+    bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench)
+
+
+db_name = '{}.db'.format(bench)
+
+
+# Save molecules to JSON
+#save_molecules_to_json(FeatherBench, 'FeatherBench.json')
+
+# Load molecules from JSON
+#loaded_molecules = load_molecules_from_json('FeatherBench.json')
+#print(loaded_molecules)
+
+#remove_database(db_name)
+
+create_database(db_name)
+for molecule in FeatherBench:
+    add_molecule_to_db(db_name, molecule)
+
+
+

tests/feather_bench.py

@@ -0,0 +1,113 @@
+
+from molecule import Molecule
+
+
+He = Molecule(
+    name="He",
+    multiplicity=1,
+    geometry=[
+        {"element": "He", "x": 0.0, "y": 0.0, "z": 0.0}
+    ],
+    properties={
+        "properties_rhf":{
+            "6-31g": {
+                "RHF energy": -2.855160426154444,
+                "RHF HOMO energy": -0.914126628640145,
+                "RHF LUMO energy": 1.399859335255765,
+                "RHF dipole moment": 0.0,
+                "MP2 correlation energy": -0.011200122909934,
+                "CCD correlation energy": -0.014985063116,
+                "CCSD correlation energy": -0.015001711549092,
+                "drCCD correlation energy": -0.01884537385338,
+                "rCCD correlation energy": -0.016836322809386,
+                "crCCD correlation energy": 0.008524676641474,
+                "lCCD correlation energy": -0.00808242082105,
+                "CIS singlet excitation energy": 1.911193619991987,
+                "CIS triplet excitation energy": 1.455852629458543,
+                "phRPA correlation energy": -0.018845374128748,
+                "phRPAx correlation energy": -0.015760565120758,
+                "crRPA correlation energy": -0.008868581132249,
+                "ppRPA correlation energy": -0.008082420814972,
+                "G0F2 correlation energy": -0.011438430540104,
+                "G0F2 HOMO energy": -0.882696116274599,
+                "G0F2 LUMO energy": 1.383080391842522,
+                "G0W0 correlation energy": -0.019314094399372,
+                "G0W0 HOMO energy": -0.87053388021722,
+                "G0W0 LUMO energy": 1.377171287041735,
+                "evGW correlation energy": -0.019335511771337,
+                "evGW HOMO energy": -0.868460640984803,
+                "evGW LUMO energy": 1.376287581502582,
+                "G0T0pp correlation energy": -0.008161908540634,
+                "G0T0pp HOMO energy": -0.898869172597701,
+                "G0T0pp LUMO energy": 1.383928087417952,
+            }
+        },
+        "properties_uhf":{
+            "6-31g": {
+            }
+        },
+        "properties_ghf":{
+            "6-31g": {
+            }
+        },
+    }
+)
+
+# ---
+
+H2O = Molecule(
+    name="H2O",
+    multiplicity=1,
+    geometry=[
+        {"element": "O", "x":  0.0000, "y": 0.0000, "z": 0.0000},
+        {"element": "H", "x":  0.7571, "y": 0.0000, "z": 0.5861},
+        {"element": "H", "x": -0.7571, "y": 0.0000, "z": 0.5861}
+    ],
+    properties={
+        "properties_rhf":{
+            "cc-pvdz": {
+                "RHF energy": -85.21935817501823,
+                "RHF HOMO energy": -0.493132793449897,
+                "RHF LUMO energy": 0.185534869842355,
+                "RHF dipole moment": 0.233813698748474,
+                "MP2 correlation energy": -0.203978216774657,
+                "CCD correlation energy": -0.212571260121257,
+                "CCSD correlation energy": -0.213302190845899,
+                "drCCD correlation energy": -0.231281853419338,
+                "rCCD correlation energy": -0.277238348710547,
+                "crCCD correlation energy": 0.18014617422324,
+                "lCCD correlation energy": -0.15128653432796,
+                "CIS singlet excitation energy": 0.338828950934568,
+                "CIS triplet excitation energy": 0.304873339484139,
+                "phRPA correlation energy": -0.231281866582435,
+                "phRPAx correlation energy": -0.310796738307943,
+                "crRPA correlation energy": -0.246289801609294,
+                "ppRPA correlation energy": -0.151286536255888,
+                "G0F2 correlation energy": -0.217807591229668,
+                "G0F2 HOMO energy": -0.404541451101377,
+                "G0F2 LUMO energy": 0.16650398400197,
+                "G0W0 correlation energy": -0.23853664665404,
+                "G0W0 HOMO energy": -0.446828623007469,
+                "G0W0 LUMO energy": 0.173026609033024,
+                "evGW correlation energy": -0.239414217281308,
+                "evGW HOMO energy": -0.443076613314424,
+                "evGW LUMO energy": 0.172691758111392,
+                "G0T0pp correlation energy": -0.156214864467344,
+                "G0T0pp HOMO energy": -0.452117482732615,
+                "G0T0pp LUMO energy": 0.16679206983464,
+            }
+        }
+    }
+)
+
+# ---
+
+FeatherBench = [
+    He, 
+    H2O
+]
+
+
+
+
+

tests/inp/methods.RHF

@@ -0,0 +1,22 @@
+# RHF UHF GHF ROHF
+  T   F   F   F
+# MP2 MP3
+  T   T
+# CCD pCCD DCD CCSD CCSD(T)
+  T   F    F   T    F
+# drCCD rCCD crCCD lCCD
+  T     T    T     T
+# CIS CIS(D) CID CISD FCI
+  T   F      F   F    F
+# phRPA phRPAx crRPA ppRPA
+  T     T      T     T 
+# G0F2 evGF2 qsGF2 ufGF2 G0F3 evGF3
+  T    F     F     F    F    F
+# G0W0 evGW qsGW SRG-qsGW ufG0W0 ufGW
+  T    T    F    F        F      F
+# G0T0pp evGTpp qsGTpp ufG0T0pp
+  T      F      F      F
+# G0T0eh evGTeh qsGTeh
+  F      F      F
+# Rtest Utest Gtest
+  T     F     F

tests/inp/options.RHF

@@ -0,0 +1,18 @@
+# HF: maxSCF thresh  DIIS guess mix   shift stab search
+      10000  0.0000001  5 1     0.0   0.0   F    F
+# MP: reg
+      F
+# CC: maxSCF thresh     DIIS
+      64     0.0000001  5
+# spin: TDA singlet triplet
+        F   T       T
+# GF: maxSCF thresh  DIIS lin eta renorm reg
+      256    0.00001 5    F   0.0 0      F
+# GW: maxSCF thresh  DIIS lin eta TDA_W reg
+      256   0.00001  5    F   0.0 F     F 
+# GT: maxSCF thresh  DIIS lin eta TDA_T reg
+      256    0.00001 5    F   0.0 F     F  
+# ACFDT: AC Kx  XBS
+         F  F   T
+# BSE: phBSE phBSE2 ppBSE dBSE dTDA
+       F     F      F     F    T     

tests/lunch_bench.py

@@ -0,0 +1,246 @@
+
+import time
+import threading
+import sys
+import os
+import shutil
+from pathlib import Path
+import subprocess
+import platform
+from datetime import datetime
+import argparse
+
+from molecule import get_molecules_from_db
+from molecule import generate_xyz
+from utils import print_col, stdout_col
+
+
+current_date = datetime.now()
+
+quack_root = os.getenv('QUACK_ROOT')
+
+# User Name
+user_name = os.getlogin()
+
+# Operating System
+os_name = platform.system()
+os_release = platform.release()
+os_version = platform.version()
+
+# CPU Information
+machine = platform.machine()
+processor = platform.processor()
+
+# System Architecture
+architecture = platform.architecture()[0]
+
+# Python Version
+python_version_full = platform.python_version_tuple()
+PYTHON_VERSION = "{}.{}".format(python_version_full[0], python_version_full[1])
+
+
+
+print(f"The current date and time is {current_date.strftime('%Y-%m-%d %H:%M:%S')}")
+print(f"User Name: {user_name}")
+print(f"Operating System: {os_name} {os_release} ({os_version})")
+print(f"CPU: {processor} ({machine})")
+print(f"System Architecture: {architecture}")
+print(f"QUACK_ROOT: {quack_root}")
+print(f"Python version: {python_version_full}\n\n")
+
+
+parser = argparse.ArgumentParser(description="Benchmark Data Sets")
+
+parser.add_argument(
+    '-s', '--set_type',
+    choices=['light', 'medium', 'heavy'],
+    default='light',
+    help="Specify the type of data set: light (default), medium, or heavy."
+)
+parser.add_argument(
+    '-t', '--thresh',
+    type=float,
+    default=1e-7,
+    help='Threshold for acceptable difference (default: 1e-8)'
+)
+    
+
+
+
+
+args = parser.parse_args()
+
+THRESH = args.thresh
+
+if args.set_type == 'light':
+    bench = 'FeatherBench'
+    bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench)
+elif args.set_type == 'medium':
+    bench = 'BalanceBench'
+    bench_title = "\n\nSelected Medium Benchmark: {}\n\n".format(bench)
+elif args.set_type == 'heavy':
+    bench = 'TitanBench'
+    bench_title = "\n\nSelected Heavy Benchmark: {}\n\n".format(bench)
+else:
+    bench_title = "\n\nSelected Light Benchmark: {}\n\n".format(bench)
+
+print(bench_title.center(150, '-'))
+print("\n\n")
+
+# ---
+
+class Quack_Job:
+
+    def __init__(self, mol, multip, basis, geom, methd):
+        self.mol = mol
+        self.multip = multip
+        self.basis = basis
+        self.geom = geom
+        self.methd = methd
+
+    def prep_inp(self):
+
+        # geometry
+        generate_xyz(self.geom, filename="{}/mol/{}.xyz".format(quack_root, self.mol))
+
+        # input files
+        for inp in ["methods", "options"]:
+            inp_file = "{}.{}".format(inp, self.methd.upper())
+            if os.path.exists("inp/{}".format(inp_file)):
+                shutil.copy("{}/tests/inp/{}".format(quack_root, inp_file), 
+                            "{}/input/{}".format(quack_root, inp))
+            else:
+                print_col("File 'inp/{}' does not exist.".format(inp_file), "red")
+                sys.exit(1)
+
+    def run(self, work_path):
+
+        def display_spinner():
+            spinner = ['|', '/', '-', '\\']
+            idx = 0
+            while not done_event.is_set():
+                stdout_col(f'\r    Testing {self.methd} ({self.basis}) {spinner[idx]}', "cyan")
+                sys.stdout.flush()
+                idx = (idx + 1) % len(spinner)
+                time.sleep(0.05)
+            stdout_col(f'\r    Testing {self.methd} ({self.basis})    \n\n', "cyan")
+
+        done_event = threading.Event()
+        spinner_thread = threading.Thread(target=display_spinner)
+        spinner_thread.start()
+
+        try:
+    
+            os.chdir('..')
+            #print_col(f"      Starting QuAck..", "magenta")
+            #print_col(f"      $ cd ..", "magenta")
+    
+            command = [
+                'python{}'.format(PYTHON_VERSION), 'PyDuck.py',
+                '-x', '{}'.format(self.mol), 
+                '-b', '{}'.format(self.basis),
+                '-m', '{}'.format(self.multip)
+            ]
+            #print_col(f"      $ {' '.join(command)}", "magenta")
+    
+            file_out = "{}/{}/{}_{}_{}.out".format(work_path, self.methd, self.mol, self.multip, self.basis)
+            with open(file_out, 'w') as fobj:
+                result = subprocess.run(command, stdout=fobj, stderr=subprocess.PIPE, text=True)
+            if result.stderr:
+                print("Error output:", result.stderr)
+    
+            os.chdir('tests')
+            #print_col(f"      $ cd tests", "magenta")
+    
+        except Exception as e:
+
+            print_col(f"An error occurred: {str(e)}", "red")
+
+        finally:
+
+            done_event.set()
+            spinner_thread.join()
+
+    def check_data(self, data_ref):
+        filepath = '../test/Rtest.dat'
+        data_new = {}
+        try:
+            # read data_new
+            with open(filepath, 'r') as f:
+                lines = f.readlines()
+                for i in range(0, len(lines) - 1, 2):
+                    key = lines[i].strip()
+                    value = lines[i + 1].strip()
+                    data_new[key] = float(value)  # Convert value to float
+            
+            # Compare with data_ref
+            for key in data_ref:
+                if key not in data_new:
+                    print_col(f"        😐 {key} missing ⚠️ ", "yellow")
+                else:
+                    diff = abs(data_new[key] - data_ref[key]) / (1e-15 + abs(data_ref[key]))
+                    if(diff <= THRESH):
+                        print_col(f"        🙂 {key}", "green")
+                    else:
+                        print_col(f"        ☹️  {key}: ❌ {data_ref[key]} ≠ {data_new[key]}", "red")
+        except FileNotFoundError:
+            print_col(f"Error: The file '{filepath}' does not exist.", "red")
+            sys.exit(1)
+        except Exception as e:
+            print_col(f"An error occurred: {str(e)}", "red")
+            sys.exit(1)
+    
+
+# ---
+
+
+def main():
+
+    work_path = Path('{}/tests/work'.format(quack_root))
+    if not work_path.exists():
+        work_path.mkdir(parents=True, exist_ok=True)
+        print(f"Directory '{work_path}' created.\n")
+
+    for mol in molecules:
+
+        mol_name = mol.name
+        mol_mult = mol.multiplicity
+        mol_geom = mol.geometry
+        mol_data = mol.properties
+
+        print_col("  Molecule: {} (2S+1 = {})".format(mol_name, mol_mult), "blue")
+
+        for mol_prop_name, mol_prop_data in mol_data.items():
+
+            methd = mol_prop_name[len('properties_'):]
+
+            if(len(mol_prop_data) == 0):
+                continue
+
+            for basis_name, basis_data in mol_prop_data.items():
+
+                if(len(basis_data) == 0):
+                    continue
+
+                work_methd = Path('{}/{}'.format(work_path, methd))
+                if not work_methd.exists():
+                    work_methd.mkdir(parents=True, exist_ok=True)
+        
+                New_Quack_Job = Quack_Job(mol_name, mol_mult, basis_name, mol_geom, methd)
+                New_Quack_Job.prep_inp()
+                New_Quack_Job.run(work_path)
+                New_Quack_Job.check_data(basis_data)
+
+                print()
+            print()
+        print()
+
+    quit()
+
+        
+db_name = '{}.db'.format(bench)
+
+molecules = get_molecules_from_db(db_name)
+
+main()
+

tests/molecule.py

@@ -0,0 +1,150 @@
+
+import os
+import json
+import sqlite3
+
+from utils import print_col
+
+
+class Molecule:
+    def __init__(self, name, multiplicity, geometry, properties):
+        self.name = name
+        self.multiplicity = multiplicity
+        self.geometry = geometry
+        self.properties = properties
+
+    def to_dict(self):
+        return {
+            "name": self.name,
+            "multiplicity": self.multiplicity,
+            "geometry": self.geometry,
+            "properties": self.properties,
+        }
+
+    @staticmethod
+    def from_dict(data):
+        return Molecule(
+            name=data["name"],
+            multiplicity=data["multiplicity"],
+            geometry=data["geometry"],
+            properties=data["properties"]
+        )
+
+def save_molecules_to_json(molecules, filename):
+    with open(filename, 'w') as f:
+        json_data = [molecule.to_dict() for molecule in molecules]
+        json.dump(json_data, f, indent=4)
+
+def load_molecules_from_json(filename):
+    with open(filename, 'r') as f:
+        json_data = json.load(f)
+        return [Molecule.from_dict(data) for data in json_data]
+
+
+def create_database(db_name):
+    if os.path.exists(db_name):
+        conn = sqlite3.connect(db_name)
+        cursor = conn.cursor()
+        # Check if the table already exists
+        cursor.execute("SELECT name FROM sqlite_master WHERE type='table' AND name='molecules';")
+        table_exists = cursor.fetchone()
+        
+        if table_exists:
+            print_col(f"Database '{db_name}' already exists and table 'molecules' is already created.", "yellow")
+        else:
+            # Create the table if it does not exist
+            cursor.execute('''CREATE TABLE molecules
+                              (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''')
+            conn.commit()
+            print_col(f"Table 'molecules' created in existing database '{db_name}' successfully.", "green")
+        conn.close()
+    else:
+        # Create the database and table
+        conn = sqlite3.connect(db_name)
+        cursor = conn.cursor()
+        cursor.execute('''CREATE TABLE molecules
+                          (name TEXT, multiplicity INTEGER, geometry TEXT, properties TEXT)''')
+        conn.commit()
+        conn.close()
+        print_col(f"Database '{db_name}' created and table 'molecules' added successfully.", "green")
+
+def add_molecule_to_db(db_name, molecule):
+
+    conn = sqlite3.connect(db_name)
+    cursor = conn.cursor()
+
+    # Convert geometry and properties to JSON strings
+    geometry_str = json.dumps(molecule.geometry)
+    energies_str = json.dumps(molecule.properties)
+
+    # Check if the molecule already exists
+    cursor.execute("SELECT COUNT(*) FROM molecules WHERE name = ?", (molecule.name,))
+    count = cursor.fetchone()[0]
+    
+    if count > 0:
+        print_col(f"Molecule '{molecule.name}' already exists in {db_name}.", "yellow")
+    else:
+        # Insert the molecule if it does not exist
+        cursor.execute("INSERT INTO molecules (name, multiplicity, geometry, properties) VALUES (?, ?, ?, ?)",
+                       (molecule.name, molecule.multiplicity, geometry_str, energies_str))
+        conn.commit()
+        print_col(f"'{molecule.name}' added to {db_name} successfully.", "green")
+    
+    conn.close()
+
+
+def remove_database(db_name):
+    if os.path.exists(db_name):
+        os.remove(db_name)
+        print_col(f"Database '{db_name}' removed successfully.", "red")
+    else:
+        print_col(f"Database '{db_name}' does not exist.", "red")
+
+def get_molecules_from_db(db_name):
+    conn = sqlite3.connect(db_name)
+    cursor = conn.cursor()
+    cursor.execute("SELECT name, multiplicity, geometry, properties FROM molecules")
+    rows = cursor.fetchall()
+    molecules = []
+    for row in rows:
+        name, multiplicity, geometry_str, energies_str = row
+        geometry = json.loads(geometry_str)
+        properties = json.loads(energies_str)
+        molecules.append(Molecule(name, multiplicity, geometry, properties))
+    conn.close()
+    return molecules
+
+
+def generate_xyz(elements, filename="output.xyz", verbose=False):
+    """
+    Generate an XYZ file from a list of elements.
+
+    Parameters:
+    elements (list): A list of dictionaries, where each dictionary represents
+                     an atom with its element and x, y, z coordinates.
+    filename (str): The name of the output XYZ file. Default is 'output.xyz'.
+    """
+
+    # Get the number of atoms
+    num_atoms = len(elements)
+
+    # Open the file in write mode
+    with open(filename, 'w') as f:
+        # Write the number of atoms
+        f.write(f"{num_atoms}\n")
+
+        # Write a comment line (can be left blank or customized)
+        f.write("XYZ file generated by generate_xyz function\n")
+
+        # Write the element and coordinates
+        for atom in elements:
+            element = atom['element']
+            x = atom['x']
+            y = atom['y']
+            z = atom['z']
+            f.write(f"{element} {x:.6f} {y:.6f} {z:.6f}\n")
+
+    if(verbose):
+        print(f"XYZ file '{filename}' generated successfully!")
+
+

tests/utils.py

@@ -0,0 +1,88 @@
+
+import sys
+
+
+
+
+def print_col(text, color):
+
+    if(color == "black"):
+
+        print("\033[30m{}\033[0m".format(text))
+
+    elif(color == "red"):
+
+        print("\033[31m{}\033[0m".format(text))
+
+    elif(color == "green"):
+
+        print("\033[32m{}\033[0m".format(text))
+
+    elif(color == "yellow"):
+
+        print("\033[33m{}\033[0m".format(text))
+
+    elif(color == "blue"):
+
+        print("\033[34m{}\033[0m".format(text))
+
+    elif(color == "magenta"):
+
+        print("\033[35m{}\033[0m".format(text))
+
+    elif(color == "cyan"):
+
+        print("\033[36m{}\033[0m".format(text))
+
+    elif(color == "white"):
+
+        print("\033[37m{}\033[0m".format(text))
+
+    else:
+
+        print("{}".format(text))
+
+
+# ---
+
+def stdout_col(text, color):
+
+    if(color == "black"):
+
+        sys.stdout.write("\033[30m{}\033[0m".format(text))
+
+    elif(color == "red"):
+
+        sys.stdout.write("\033[31m{}\033[0m".format(text))
+
+    elif(color == "green"):
+
+        sys.stdout.write("\033[32m{}\033[0m".format(text))
+
+    elif(color == "yellow"):
+
+        sys.stdout.write("\033[33m{}\033[0m".format(text))
+
+    elif(color == "blue"):
+
+        sys.stdout.write("\033[34m{}\033[0m".format(text))
+
+    elif(color == "magenta"):
+
+        sys.stdout.write("\033[35m{}\033[0m".format(text))
+
+    elif(color == "cyan"):
+
+        sys.stdout.write("\033[36m{}\033[0m".format(text))
+
+    elif(color == "white"):
+
+        sys.stdout.write("\033[37m{}\033[0m".format(text))
+
+    else:
+
+        sys.stdout.write("{}".format(text))
+
+# ---
+
+