diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index daa33b90..92e5adf5 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -39,6 +39,7 @@ subroutine routine_bis accu_d += psi_coef(i,1)**2 enddo print*,'accu_d = ',accu_d + provide superci_natorb end subroutine routine diff --git a/src/casscf/swap_orb.irp.f b/src/casscf/swap_orb.irp.f index 30bfb243..c19bf811 100644 --- a/src/casscf/swap_orb.irp.f +++ b/src/casscf/swap_orb.irp.f @@ -52,8 +52,8 @@ ! equation B3.c of the annex B of Roos et. al. Chemical Physics 48 (1980) 157-173 do i = 1, n_core_inact_orb iorb = list_core_inact(i) - do a = 1, n_act_orb - aorb = list_act(a) + do a = 1, n_virt_orb + aorb = list_virt(a) super_ci_dm(aorb,iorb) = 2.d0 * c0 * lowest_super_ci_coef_mo(aorb,iorb) super_ci_dm(iorb,aorb) = 2.d0 * c0 * lowest_super_ci_coef_mo(aorb,iorb) enddo @@ -125,6 +125,12 @@ END_PROVIDER + BEGIN_PROVIDER [double precision, superci_natorb, (ao_num,mo_num) +&BEGIN_PROVIDER [double precision, superci_nat_occ, (mo_num) + implicit none + call general_mo_coef_new_as_svd_vectors_of_mo_matrix_eig(super_ci_dm,mo_num,mo_num,mo_num,superci_nat_occ,superci_natorb) + +END_PROVIDER BEGIN_PROVIDER [double precision, mat_tmp_dm_super_ci, (n_act_orb,n_act_orb)] implicit none diff --git a/src/mo_basis/utils.irp.f b/src/mo_basis/utils.irp.f index e141867a..2cefcbd4 100644 --- a/src/mo_basis/utils.irp.f +++ b/src/mo_basis/utils.irp.f @@ -217,3 +217,59 @@ subroutine mo_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,label) end +subroutine general_mo_coef_new_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,mo_coef_new) + implicit none + integer,intent(in) :: lda,m,n + double precision, intent(in) :: matrix(lda,n) + double precision, intent(out) :: eig(m),mo_coef_new(ao_num,m) + + integer :: i,j + double precision :: accu + double precision, allocatable :: mo_coef_tmp(:,:), U(:,:),D(:), A(:,:), Vt(:,:), work(:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A + + call write_time(6) + if (m /= mo_num) then + print *, irp_here, ': Error : m/= mo_num' + stop 1 + endif + + allocate(A(lda,n),U(lda,n),D(m),Vt(lda,n),mo_coef_tmp(ao_num,mo_num)) + + do j=1,n + do i=1,m + A(i,j) = matrix(i,j) + enddo + enddo + mo_coef_tmp = mo_coef + + call svd(A,lda,U,lda,D,Vt,lda,m,n) + + write (6,'(A)') '' + write (6,'(A)') 'Eigenvalues' + write (6,'(A)') '-----------' + write (6,'(A)') '' + write (6,'(A)') '======== ================ ================' + write (6,'(A)') ' MO Eigenvalue Cumulative ' + write (6,'(A)') '======== ================ ================' + + accu = 0.d0 + do i=1,m + accu = accu + D(i) + write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu + enddo + write (6,'(A)') '======== ================ ================' + write (6,'(A)') '' + + call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_tmp,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef_new,size(mo_coef,1)) + + do i=1,m + eig(i) = D(i) + enddo + + deallocate(A,U,Vt,D,mo_coef_tmp) + call write_time(6) + +end + +