program psiSVD_naivBbyB_v1 implicit none BEGIN_DOC ! perturbative approach to build psi_postsvd END_DOC read_wf = .True. TOUCH read_wf PROVIDE N_int call run() end subroutine run USE OMP_LIB implicit none integer(bit_kind) :: det1(N_int,2), det2(N_int,2) integer :: degree, i_state integer :: i, j, k, l, m, n double precision :: x, y, h12 double precision, allocatable :: Uref(:,:), Dref(:), Vtref(:,:), Aref(:,:), Vref(:,:) integer :: rank_max, n_TSVD, n_selected double precision :: E0, overlop double precision, allocatable :: H0(:,:) double precision, allocatable :: eigvec0(:,:), eigval0(:) integer, allocatable :: numalpha_selected(:), numbeta_selected(:) integer :: ii integer :: na_new, nb_new, ind_new, ind_gs double precision, allocatable :: epsil(:), epsil_energ(:), check_ov(:) double precision, allocatable :: Uezfio(:,:,:), Dezfio(:,:), Vezfio(:,:,:) integer(kind=8) :: W_tbeg, W_tend, W_tbeg_it, W_tend_it, W_ir real(kind=8) :: W_tot_time, W_tot_time_it integer :: nb_taches !$OMP PARALLEL nb_taches = OMP_GET_NUM_THREADS() !$OMP END PARALLEL call SYSTEM_CLOCK(COUNT=W_tbeg, COUNT_RATE=W_ir) i_state = 1 det1(:,1) = psi_det_alpha_unique(:,1) det2(:,1) = psi_det_alpha_unique(:,1) det1(:,2) = psi_det_beta_unique(:,1) det2(:,2) = psi_det_beta_unique(:,1) call get_excitation_degree_spin(det1(1,1),det2(1,1),degree,N_int) call get_excitation_degree(det1,det2,degree,N_int) call i_H_j(det1, det2, N_int, h12) ! --------------------------------------------------------------------------------------- ! construct the initial CISD matrix print *, ' ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~' print *, ' CI matrix:', n_det_alpha_unique,'x',n_det_beta_unique print *, ' N det :', N_det print *, ' ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~' allocate( Aref(n_det_alpha_unique,n_det_beta_unique) ) Aref(:,:) = 0.d0 do k = 1, N_det i = psi_bilinear_matrix_rows(k) j = psi_bilinear_matrix_columns(k) Aref(i,j) = psi_bilinear_matrix_values(k,i_state) enddo ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- ! perform a Full SVD allocate( Uref(n_det_alpha_unique,n_det_alpha_unique) ) allocate( Dref(min(n_det_alpha_unique,n_det_beta_unique)) ) allocate( Vtref(n_det_beta_unique,n_det_beta_unique) ) call svd_s(Aref, size(Aref,1), Uref, size(Uref,1), Dref, Vtref & , size(Vtref,1), n_det_alpha_unique, n_det_beta_unique) allocate( Vref(n_det_beta_unique,n_det_beta_unique) ) do l = 1, n_det_beta_unique do i = 1, n_det_beta_unique Vref(i,l) = Vtref(l,i) enddo enddo deallocate( Vtref ) deallocate( Aref ) ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- ! initial wavefunction: psi_0 n_TSVD = 1 n_selected = 1 allocate( numalpha_selected(n_selected) , numbeta_selected(n_selected) ) numalpha_selected(1) = 1 numbeta_selected (1) = 1 ! get E0 = < psi_0 | H | psi_0 > allocate( H0(n_selected,n_selected) ) call const_psiHpsi(n_TSVD, n_selected, Uref, Vref, numalpha_selected, numbeta_selected, H0) E0 = H0(1,1) + nuclear_repulsion print*, ' ground state E0 = ', E0 deallocate( H0 ) ! --------------------------------------------------------------------------------------- !________________________________________________________________________________________________________ ! ! increase the size of psi0 iteratively !________________________________________________________________________________________________________ rank_max = n_det_alpha_unique*n_det_beta_unique ! 15*15 do while( n_selected .lt. rank_max ) call SYSTEM_CLOCK(COUNT=W_tbeg_it, COUNT_RATE=W_ir) print*, ' ' print*, ' new iteration ' deallocate( numalpha_selected, numbeta_selected ) n_TSVD = n_TSVD + 1 n_selected = n_TSVD * n_TSVD allocate( numalpha_selected(n_selected) , numbeta_selected(n_selected) ) l = 0 do i = 1, n_TSVD do j = 1, n_TSVD l = l + 1 numalpha_selected(l) = i numbeta_selected (l) = j enddo enddo if( l.ne.n_selected) then print *, "error in numbering" stop endif ! construct and diagonalise the hamiltonian < psi_selected | H | psi_selected > allocate( H0(n_selected,n_selected) ) call const_psiHpsi(n_TSVD, n_selected, Uref, Vref, numalpha_selected, numbeta_selected, H0) allocate( eigvec0(n_selected,n_selected), eigval0(n_selected) ) call lapack_diag(eigval0, eigvec0, H0, n_selected, n_selected) ! get the postsvd ground state allocate( check_ov(n_selected) ) do l = 1, n_selected overlop = 0.d0 do i = 1, n_TSVD ii = i + (i-1)*n_TSVD overlop = overlop + eigvec0(ii,l) * Dref(i) enddo check_ov(l) = dabs(overlop) enddo ind_gs = MAXLOC( check_ov, DIM=1 ) overlop = check_ov(ind_gs) E0 = eigval0(ind_gs)+nuclear_repulsion print*, ' space dimen = ', n_selected print*, ' diag energy = ', E0 print*, ' overlop = ', overlop deallocate( H0 ) deallocate( check_ov, eigval0, eigvec0 ) ! --------------------------------------------------------------------------------------- write(221, *) n_selected, E0 call SYSTEM_CLOCK(COUNT=W_tend_it, COUNT_RATE=W_ir) W_tot_time_it = real(W_tend_it-W_tbeg_it, kind=8) / real(W_ir, kind=8) print*, " " print*, " elapsed time (min) = ", W_tot_time_it/60.d0 end do !________________________________________________________________________________________________________ !________________________________________________________________________________________________________ deallocate( Dref ) deallocate( Uref, Vref ) ! *************************************************************************************************** ! save to ezfion !allocate( Uezfio(n_det_alpha_unique,rank0,1), Dezfio(rank0,1), Vezfio(n_det_beta_unique,rank0,1) ) !do l = 1, rank0 ! Dezfio(l,1) = coeff_psi(l) ! Uezfio(:,l,1) = U0(:,l) ! Vezfio(:,l,1) = V0(:,l) !enddo !call ezfio_set_spindeterminants_n_det(N_det) !call ezfio_set_spindeterminants_n_states(N_states) !call ezfio_set_spindeterminants_n_det_alpha(n_det_alpha_unique) !call ezfio_set_spindeterminants_n_det_beta(n_det_beta_unique) !call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_bilinear_matrix_rows) !call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_bilinear_matrix_columns) !call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_bilinear_matrix_values) !call ezfio_set_spindeterminants_n_svd_coefs(rank0) !call ezfio_set_spindeterminants_psi_svd_alpha(Uezfio) !call ezfio_set_spindeterminants_psi_svd_beta(Vezfio ) !call ezfio_set_spindeterminants_psi_svd_coefs(Dezfio) !deallocate( Uezfio, Dezfio, Vezfio ) ! *************************************************************************************************** call SYSTEM_CLOCK(COUNT=W_tend, COUNT_RATE=W_ir) W_tot_time = real(W_tend - W_tbeg, kind=8) / real(W_ir, kind=8) print *, ' ___________________________________________________________________' print *, ' ' print *, " Execution avec ", nb_taches, " threads" print *, " total elapsed time (min) = ", W_tot_time/60.d0 print *, ' ___________________________________________________________________' end subroutine const_psiHpsi(n_TSVD, n_selected, Uref, Vref, numalpha_selected, numbeta_selected, H0) implicit none integer, intent(in) :: n_TSVD, n_selected integer, intent(in) :: numalpha_selected(n_selected), numbeta_selected(n_selected) double precision, intent(in) :: Uref(n_det_alpha_unique,n_det_alpha_unique) double precision, intent(in) :: Vref(n_det_beta_unique ,n_det_beta_unique) double precision, intent(out) :: H0(n_selected,n_selected) integer(bit_kind) :: det1(N_int,2) integer(bit_kind) :: det2(N_int,2) integer :: degree, na, nb integer :: i, j, k, l integer :: iin, jjn, iim, jjm, n, m double precision :: h12, x double precision, allocatable :: Utmp(:,:), Vtmp(:,:) double precision, allocatable :: tmp1(:,:,:,:), tmp2(:,:,:,:) na = n_det_alpha_unique nb = n_det_beta_unique H0(:,:) = 0.d0 allocate( tmp1(nb,nb,n_TSVD,n_TSVD) ) tmp1(:,:,:,:) = 0.d0 allocate( Utmp(n_TSVD,na) ) do i = 1, na do iin = 1, n_TSVD Utmp(iin,i) = Uref(i,iin) enddo enddo !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(iin,iim,i,j,k,l,h12,x,det1,det2,degree,tmp2) & !$OMP SHARED(na,nb,psi_det_alpha_unique,psi_det_beta_unique, & !$OMP N_int,n_TSVD,Utmp,tmp1) allocate( tmp2(nb,nb,n_TSVD,n_TSVD) ) tmp2(:,:,:,:) = 0.d0 !$OMP DO COLLAPSE(2) SCHEDULE(DYNAMIC,8) do l = 1, nb do j = 1, nb det2(:,2) = psi_det_beta_unique(:,l) det1(:,2) = psi_det_beta_unique(:,j) call get_excitation_degree_spin(det1(1,2),det2(1,2),degree,N_int) if(degree .gt. 2) cycle do k = 1, na det2(:,1) = psi_det_alpha_unique(:,k) do i = 1, na det1(:,1) = psi_det_alpha_unique(:,i) call get_excitation_degree(det1,det2,degree,N_int) if(degree .gt. 2) cycle call i_H_j(det1, det2, N_int, h12) if( h12 .eq. 0.d0) cycle do iin = 1, n_TSVD x = Utmp(iin,i) * h12 if( x == 0.d0 ) cycle do iim = 1, n_TSVD tmp2(j,l,iim,iin) += Utmp(iim,k) * x enddo enddo enddo enddo enddo enddo !$OMP END DO !$OMP CRITICAL do iin = 1, n_TSVD do iim = 1, n_TSVD do l = 1, nb do j = 1, nb tmp1(j,l,iim,iin) += tmp2(j,l,iim,iin) enddo enddo enddo enddo !$OMP END CRITICAL deallocate( tmp2 ) !$OMP END PARALLEL deallocate( Utmp ) allocate( Vtmp(nb,n_TSVD) ) do iin = 1, n_TSVD do i = 1, nb Vtmp(i,iin) = Vref(i,iin) enddo enddo allocate( tmp2(nb,n_TSVD,n_TSVD,n_TSVD) ) call DGEMM('T','N', nb*n_TSVD*n_TSVD, n_TSVD, nb, 1.d0 & , tmp1, size(tmp1,1) & , Vtmp, size(Vtmp,1) & , 0.d0, tmp2, size(tmp2,1)*size(tmp2,2)*size(tmp2,3) ) deallocate(tmp1) allocate( tmp1(n_TSVD,n_TSVD,n_TSVD,n_TSVD) ) call DGEMM('T','N', n_TSVD*n_TSVD*n_TSVD, n_TSVD, nb, 1.d0 & , tmp2, size(tmp2,1) & , Vtmp, size(Vtmp,1) & , 0.d0, tmp1, size(tmp1,1)*size(tmp1,2)*size(tmp1,3) ) deallocate( tmp2, Vtmp ) do n = 1, n_selected iin = numalpha_selected(n) jjn = numbeta_selected (n) do m = 1, n_selected iim = numalpha_selected(m) jjm = numbeta_selected (m) H0(m,n) = tmp1(iin,iim,jjn,jjm) enddo enddo deallocate( tmp1 ) return end subroutine const_psiHpsi