mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 04:13:55 +01:00
Working on compute_singles
This commit is contained in:
parent
4c4c65581a
commit
db29e0048a
@ -5,7 +5,7 @@ double precision function get_ao_integ_chol(i,j,k,l)
|
||||
! i(r1) j(r1) 1/r12 k(r2) l(r2)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
double precision, external :: ddot
|
||||
double precision, external :: ddot
|
||||
get_ao_integ_chol = ddot(cholesky_ao_num, cholesky_ao_transp(1,i,j), 1, cholesky_ao_transp(1,k,l), 1)
|
||||
|
||||
end
|
||||
@ -155,7 +155,7 @@ END_PROVIDER
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
endif
|
||||
! Just to guarentee termination
|
||||
! Just to guarentee termination
|
||||
D(ndim8) = 0.d0
|
||||
|
||||
D_sorted(:) = -D(:)
|
||||
@ -181,15 +181,9 @@ END_PROVIDER
|
||||
rank_max = min(np,20*elec_num*elec_num)
|
||||
endif
|
||||
|
||||
call mmap_create_d(trim(ezfio_work_dir)//'cholesky_ao_tmp', (/ ndim8, rank_max /), 8, .False., .True., map)
|
||||
call mmap_create_d('', (/ ndim8, rank_max /), .False., .True., map)
|
||||
L => map%d2
|
||||
|
||||
! Deleting the file while it is open makes the file invisible on the filesystem,
|
||||
! and automatically deleted, even if the program crashes
|
||||
iunit = getUnitAndOpen(trim(ezfio_work_dir)//'cholesky_ao_tmp', 'R')
|
||||
close(iunit,status='delete')
|
||||
|
||||
|
||||
! 3.
|
||||
N = 0
|
||||
|
||||
@ -205,7 +199,7 @@ END_PROVIDER
|
||||
do while ( (Dmax > tau).and.(np > 0) )
|
||||
! a.
|
||||
i = i+1
|
||||
|
||||
|
||||
|
||||
|
||||
block_size = max(N,24)
|
||||
@ -317,7 +311,7 @@ END_PROVIDER
|
||||
! g.
|
||||
|
||||
iblock = 0
|
||||
|
||||
|
||||
do j=1,nq
|
||||
|
||||
if ( (Qmax < Dmin).or.(N+j*1_8 > ndim8) ) exit
|
||||
|
||||
@ -774,6 +774,13 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
|
||||
lambda &
|
||||
)
|
||||
FREE nthreads_davidson
|
||||
|
||||
! call mmap_destroy(singles_alpha_csc_map)
|
||||
! FREE singles_alpha_csc_map
|
||||
!
|
||||
! call mmap_destroy(singles_beta_csc_map)
|
||||
! FREE singles_beta_csc_map
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
@ -182,6 +182,9 @@ subroutine H_u_0_nstates_openmp_work_$N_int(v_t,u_t,N_st,sze,istart,iend,ishift,
|
||||
! if (.not.compute_singles) then
|
||||
! provide singles_beta_csc
|
||||
! endif
|
||||
|
||||
PROVIDE singles_beta_csc_map singles_alpha_csc_map
|
||||
|
||||
compute_singles=.True.
|
||||
|
||||
|
||||
@ -209,8 +212,8 @@ compute_singles=.True.
|
||||
!$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||
!$OMP istart, iend, istep, irp_here, v_t, &
|
||||
!$OMP ishift, idx0, u_t, maxab, compute_singles, &
|
||||
!$OMP singles_alpha_csc,singles_alpha_csc_idx, &
|
||||
!$OMP singles_beta_csc,singles_beta_csc_idx) &
|
||||
!$OMP singles_alpha_csc_map,singles_alpha_csc_idx, &
|
||||
!$OMP singles_beta_csc_map,singles_beta_csc_idx) &
|
||||
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
|
||||
!$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
|
||||
!$OMP buffer, doubles, n_doubles, umax, &
|
||||
@ -272,7 +275,7 @@ compute_singles=.True.
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
|
||||
n_singles_b = n_singles_b+1
|
||||
singles_b(n_singles_b) = singles_beta_csc(k8)
|
||||
singles_b(n_singles_b) = singles_beta_csc_map%i1(k8)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
@ -287,8 +290,7 @@ compute_singles=.True.
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
|
||||
!---
|
||||
! if (compute_singles) then
|
||||
if (compute_singles) then
|
||||
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
@ -311,69 +313,67 @@ compute_singles=.True.
|
||||
buffer, idx, tmp_det(1,1), j, &
|
||||
singles_a, n_singles_a )
|
||||
|
||||
!-----
|
||||
! else
|
||||
!
|
||||
! ! Search for singles
|
||||
!
|
||||
!call cpu_time(time0)
|
||||
! ! Right boundary
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
|
||||
! ASSERT (l_a <= N_det)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = singles_alpha_csc_idx(krow)
|
||||
! right_max = -1_8
|
||||
! right = singles_alpha_csc_idx(krow+1)
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! right_max = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! if (right_max > 0_8) exit
|
||||
! l_a = l_a-1
|
||||
! enddo
|
||||
! if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
|
||||
!
|
||||
! ! Search
|
||||
! n_singles_a = 0
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
! ASSERT (l_a <= N_det)
|
||||
!
|
||||
! last_found = singles_alpha_csc_idx(krow)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = last_found
|
||||
! right = right_max
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! n_singles_a += 1
|
||||
! singles_a(n_singles_a) = l_a
|
||||
! last_found = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! l_a = l_a+1
|
||||
! enddo
|
||||
! j = j-1
|
||||
!
|
||||
! endif
|
||||
!-----
|
||||
else
|
||||
|
||||
! Search for singles
|
||||
|
||||
! Right boundary
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
|
||||
ASSERT (l_a <= N_det)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
left = singles_alpha_csc_idx(krow)
|
||||
right_max = -1_8
|
||||
right = singles_alpha_csc_idx(krow+1)
|
||||
do while (right-left>0_8)
|
||||
k8 = shiftr(right+left,1)
|
||||
if (singles_alpha_csc_map%i1(k8) > lrow) then
|
||||
right = k8
|
||||
else if (singles_alpha_csc_map%i1(k8) < lrow) then
|
||||
left = k8 + 1_8
|
||||
else
|
||||
right_max = k8+1_8
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (right_max > 0_8) exit
|
||||
l_a = l_a-1
|
||||
enddo
|
||||
if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
|
||||
|
||||
! Search
|
||||
n_singles_a = 0
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
last_found = singles_alpha_csc_idx(krow)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
left = last_found
|
||||
right = right_max
|
||||
do while (right-left>0_8)
|
||||
k8 = shiftr(right+left,1)
|
||||
if (singles_alpha_csc_map%i1(k8) > lrow) then
|
||||
right = k8
|
||||
else if (singles_alpha_csc_map%i1(k8) < lrow) then
|
||||
left = k8 + 1_8
|
||||
else
|
||||
n_singles_a += 1
|
||||
singles_a(n_singles_a) = l_a
|
||||
last_found = k8+1_8
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
j = j-1
|
||||
|
||||
endif
|
||||
|
||||
|
||||
! Loop over alpha singles
|
||||
! -----------------------
|
||||
|
||||
@ -221,7 +221,11 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,
|
||||
! if (.not.compute_singles) then
|
||||
! provide singles_beta_csc
|
||||
! endif
|
||||
compute_singles=.True.
|
||||
|
||||
! PROVIDE singles_beta_csc_map singles_alpha_csc_map
|
||||
PROVIDE singles_beta_csc singles_alpha_csc
|
||||
|
||||
compute_singles=.True.
|
||||
|
||||
|
||||
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||
@ -250,6 +254,8 @@ compute_singles=.True.
|
||||
!$OMP ishift, idx0, u_t, maxab, compute_singles, &
|
||||
!$OMP singles_alpha_csc,singles_alpha_csc_idx, &
|
||||
!$OMP singles_beta_csc,singles_beta_csc_idx) &
|
||||
! !$OMP singles_alpha_csc_map,singles_alpha_csc_idx, &
|
||||
! !$OMP singles_beta_csc_map,singles_beta_csc_idx) &
|
||||
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
|
||||
!$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
|
||||
!$OMP buffer, doubles, n_doubles, umax, &
|
||||
@ -311,9 +317,11 @@ compute_singles=.True.
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
|
||||
n_singles_b = n_singles_b+1
|
||||
! singles_b(n_singles_b) = singles_beta_csc_map%i1(k8)
|
||||
singles_b(n_singles_b) = singles_beta_csc(k8)
|
||||
enddo
|
||||
endif
|
||||
|
||||
endif
|
||||
kcol_prev = kcol
|
||||
|
||||
@ -326,8 +334,7 @@ compute_singles=.True.
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
|
||||
!---
|
||||
! if (compute_singles) then
|
||||
if (compute_singles) then
|
||||
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
@ -352,69 +359,70 @@ compute_singles=.True.
|
||||
buffer, idx, tmp_det(1,1), j, &
|
||||
singles_a, n_singles_a )
|
||||
|
||||
!-----
|
||||
! else
|
||||
!
|
||||
! ! Search for singles
|
||||
!
|
||||
!call cpu_time(time0)
|
||||
! ! Right boundary
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
|
||||
! ASSERT (l_a <= N_det)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = singles_alpha_csc_idx(krow)
|
||||
! right_max = -1_8
|
||||
! right = singles_alpha_csc_idx(krow+1)
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! right_max = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! if (right_max > 0_8) exit
|
||||
! l_a = l_a-1
|
||||
! enddo
|
||||
! if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
|
||||
!
|
||||
! ! Search
|
||||
! n_singles_a = 0
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
! ASSERT (l_a <= N_det)
|
||||
!
|
||||
! last_found = singles_alpha_csc_idx(krow)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = last_found
|
||||
! right = right_max
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! n_singles_a += 1
|
||||
! singles_a(n_singles_a) = l_a
|
||||
! last_found = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! l_a = l_a+1
|
||||
! enddo
|
||||
! j = j-1
|
||||
!
|
||||
! endif
|
||||
!-----
|
||||
else
|
||||
|
||||
! Search for singles
|
||||
|
||||
! Right boundary
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
|
||||
ASSERT (l_a <= N_det)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
left = singles_alpha_csc_idx(krow)
|
||||
right_max = -1_8
|
||||
right = singles_alpha_csc_idx(krow+1)
|
||||
do while (right-left>0_8)
|
||||
k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc_map%i1(k8) > lrow) then
|
||||
if (singles_alpha_csc(k8) > lrow) then
|
||||
right = k8
|
||||
! else if (singles_alpha_csc_map%i1(k8) < lrow) then
|
||||
else if (singles_alpha_csc(k8) < lrow) then
|
||||
left = k8 + 1_8
|
||||
else
|
||||
right_max = k8+1_8
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (right_max > 0_8) exit
|
||||
l_a = l_a-1
|
||||
enddo
|
||||
if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
|
||||
|
||||
! Search
|
||||
n_singles_a = 0
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
last_found = singles_alpha_csc_idx(krow)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
left = last_found
|
||||
right = right_max
|
||||
do while (right-left>0_8)
|
||||
k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc_map%i1(k8) > lrow) then
|
||||
if (singles_alpha_csc(k8) > lrow) then
|
||||
right = k8
|
||||
! else if (singles_alpha_csc_map%i1(k8) < lrow) then
|
||||
else if (singles_alpha_csc(k8) < lrow) then
|
||||
left = k8 + 1_8
|
||||
else
|
||||
n_singles_a += 1
|
||||
singles_a(n_singles_a) = l_a
|
||||
last_found = k8+1_8
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
j = j-1
|
||||
|
||||
endif
|
||||
|
||||
! Loop over alpha singles
|
||||
! -----------------------
|
||||
|
||||
@ -910,6 +910,7 @@ subroutine copy_psi_bilinear_to_psi(psi, isize)
|
||||
end
|
||||
|
||||
|
||||
use mmap_module
|
||||
|
||||
BEGIN_PROVIDER [ integer*8, singles_alpha_csc_idx, (N_det_alpha_unique+1) ]
|
||||
&BEGIN_PROVIDER [ integer*8, singles_alpha_csc_size ]
|
||||
@ -926,12 +927,11 @@ end
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
|
||||
!$OMP idx0, N_int, singles_alpha_csc, &
|
||||
!$OMP elec_alpha_num, mo_num, singles_alpha_csc_idx) &
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
|
||||
!$OMP idx0, N_int, singles_alpha_csc_idx) &
|
||||
!$OMP PRIVATE(i,s,j)
|
||||
allocate (s(elec_alpha_num * (mo_num-elec_alpha_num) ))
|
||||
allocate (s(N_det_alpha_unique))
|
||||
!$OMP DO SCHEDULE(static,64)
|
||||
do i=1, N_det_alpha_unique
|
||||
call get_all_spin_singles( &
|
||||
@ -967,7 +967,7 @@ BEGIN_PROVIDER [ integer, singles_alpha_csc, (singles_alpha_csc_size) ]
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
|
||||
!$OMP idx0, N_int, singles_alpha_csc, singles_alpha_csc_idx)&
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static,1)
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static)
|
||||
do i=1, N_det_alpha_unique
|
||||
call get_all_spin_singles( &
|
||||
psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int,&
|
||||
@ -979,7 +979,36 @@ BEGIN_PROVIDER [ integer, singles_alpha_csc, (singles_alpha_csc_size) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ type(mmap_type), singles_alpha_csc_map ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Indices of all single excitations
|
||||
END_DOC
|
||||
integer :: i, k
|
||||
integer, allocatable :: idx0(:)
|
||||
|
||||
call mmap_create_i('', (/ 1_8*singles_alpha_csc_size /), &
|
||||
.False., .False., singles_alpha_csc_map)
|
||||
|
||||
allocate (idx0(N_det_alpha_unique))
|
||||
do i=1, N_det_alpha_unique
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
|
||||
!$OMP idx0, N_int, singles_alpha_csc_map, singles_alpha_csc_idx)&
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static)
|
||||
do i=1, N_det_alpha_unique
|
||||
call get_all_spin_singles( &
|
||||
psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, N_det_alpha_unique, &
|
||||
singles_alpha_csc_map%i1(singles_alpha_csc_idx(i):singles_alpha_csc_idx(i)+N_det_alpha_unique-1),&
|
||||
k)
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
deallocate(idx0)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer*8, singles_beta_csc_idx, (N_det_beta_unique+1) ]
|
||||
@ -997,13 +1026,12 @@ END_PROVIDER
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, &
|
||||
!$OMP idx0, N_int, singles_beta_csc, &
|
||||
!$OMP elec_beta_num, mo_num, singles_beta_csc_idx) &
|
||||
!$OMP idx0, N_int, singles_beta_csc_idx) &
|
||||
!$OMP PRIVATE(i,s,j)
|
||||
allocate (s(elec_beta_num*(mo_num-elec_beta_num)))
|
||||
!$OMP DO SCHEDULE(static,1)
|
||||
allocate (s(N_det_beta_unique))
|
||||
!$OMP DO SCHEDULE(static)
|
||||
do i=1, N_det_beta_unique
|
||||
call get_all_spin_singles( &
|
||||
psi_det_beta_unique, idx0, psi_det_beta_unique(1,i), N_int,&
|
||||
@ -1038,7 +1066,7 @@ BEGIN_PROVIDER [ integer, singles_beta_csc, (singles_beta_csc_size) ]
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, &
|
||||
!$OMP idx0, N_int, singles_beta_csc, singles_beta_csc_idx)&
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static,64)
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static)
|
||||
do i=1, N_det_beta_unique
|
||||
call get_all_spin_singles( &
|
||||
psi_det_beta_unique, idx0, psi_det_beta_unique(1,i), N_int,&
|
||||
@ -1050,6 +1078,37 @@ BEGIN_PROVIDER [ integer, singles_beta_csc, (singles_beta_csc_size) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ type(mmap_type), singles_beta_csc_map ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Indices of all single excitations
|
||||
END_DOC
|
||||
integer :: i, k
|
||||
integer, allocatable :: idx0(:)
|
||||
|
||||
call mmap_create_i('', (/ 1_8*singles_beta_csc_size /), &
|
||||
.False., .False., singles_beta_csc_map)
|
||||
|
||||
allocate (idx0(N_det_beta_unique))
|
||||
do i=1, N_det_beta_unique
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||
!$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, &
|
||||
!$OMP idx0, N_int, singles_beta_csc_map, singles_beta_csc_idx)&
|
||||
!$OMP PRIVATE(i,k) SCHEDULE(static)
|
||||
do i=1, N_det_beta_unique
|
||||
call get_all_spin_singles( &
|
||||
psi_det_beta_unique, idx0, psi_det_beta_unique(1,i), N_int, N_det_beta_unique, &
|
||||
singles_beta_csc_map%i1(singles_beta_csc_idx(i):singles_beta_csc_idx(i)+N_det_beta_unique-1),&
|
||||
k)
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
deallocate(idx0)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1112,16 +1171,16 @@ subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_
|
||||
integer :: i
|
||||
integer(bit_kind) :: v
|
||||
integer :: degree
|
||||
integer :: add_single(0:64) = (/ 0, 0, 1, 0, 0, (0, i=1,60) /)
|
||||
include 'utils/constants.include.F'
|
||||
|
||||
n_singles = 1
|
||||
n_singles = 0
|
||||
do i=1,size_buffer
|
||||
degree = popcnt(xor( spindet, buffer(i) ))
|
||||
singles(n_singles) = idx(i)
|
||||
n_singles = n_singles+add_single(degree)
|
||||
if (degree == 2) then
|
||||
n_singles = n_singles+1
|
||||
singles(n_singles) = idx(i)
|
||||
endif
|
||||
enddo
|
||||
n_singles = n_singles-1
|
||||
|
||||
end
|
||||
|
||||
@ -1143,15 +1202,15 @@ subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_
|
||||
integer :: i
|
||||
include 'utils/constants.include.F'
|
||||
integer :: degree
|
||||
integer :: add_double(0:64) = (/ 0, 0, 0, 0, 1, (0, i=1,60) /)
|
||||
|
||||
n_doubles = 1
|
||||
n_doubles = 0
|
||||
do i=1,size_buffer
|
||||
degree = popcnt(xor( spindet, buffer(i) ))
|
||||
doubles(n_doubles) = idx(i)
|
||||
n_doubles = n_doubles+add_double(degree)
|
||||
if (degree == 4) then
|
||||
n_doubles = n_doubles+1
|
||||
doubles(n_doubles) = idx(i)
|
||||
endif
|
||||
enddo
|
||||
n_doubles = n_doubles-1
|
||||
|
||||
end
|
||||
|
||||
@ -1182,8 +1241,8 @@ subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_bu
|
||||
integer(bit_kind) :: xorvec($N_int)
|
||||
integer :: degree
|
||||
|
||||
n_singles = 1
|
||||
n_doubles = 1
|
||||
n_singles = 0
|
||||
n_doubles = 0
|
||||
do i=1,size_buffer
|
||||
|
||||
do k=1,$N_int
|
||||
@ -1197,16 +1256,14 @@ subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_bu
|
||||
enddo
|
||||
|
||||
if ( degree == 4 ) then
|
||||
doubles(n_doubles) = idx(i)
|
||||
n_doubles = n_doubles+1
|
||||
doubles(n_doubles) = idx(i)
|
||||
else if ( degree == 2 ) then
|
||||
singles(n_singles) = idx(i)
|
||||
n_singles = n_singles+1
|
||||
singles(n_singles) = idx(i)
|
||||
endif
|
||||
|
||||
enddo
|
||||
n_singles = n_singles-1
|
||||
n_doubles = n_doubles-1
|
||||
|
||||
end
|
||||
|
||||
@ -1231,7 +1288,7 @@ subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, single
|
||||
integer(bit_kind) :: xorvec($N_int)
|
||||
integer :: degree
|
||||
|
||||
n_singles = 1
|
||||
n_singles = 0
|
||||
do i=1,size_buffer
|
||||
|
||||
do k=1,$N_int
|
||||
@ -1248,11 +1305,10 @@ subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, single
|
||||
cycle
|
||||
endif
|
||||
|
||||
singles(n_singles) = idx(i)
|
||||
n_singles = n_singles+1
|
||||
singles(n_singles) = idx(i)
|
||||
|
||||
enddo
|
||||
n_singles = n_singles-1
|
||||
|
||||
end
|
||||
|
||||
@ -1276,7 +1332,7 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
|
||||
include 'utils/constants.include.F'
|
||||
integer(bit_kind) :: xorvec($N_int)
|
||||
|
||||
n_doubles = 1
|
||||
n_doubles = 0
|
||||
do i=1,size_buffer
|
||||
|
||||
do k=1,$N_int
|
||||
@ -1293,13 +1349,11 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
|
||||
cycle
|
||||
endif
|
||||
|
||||
doubles(n_doubles) = idx(i)
|
||||
n_doubles = n_doubles+1
|
||||
doubles(n_doubles) = idx(i)
|
||||
|
||||
enddo
|
||||
|
||||
n_doubles = n_doubles-1
|
||||
|
||||
end
|
||||
|
||||
SUBST [ N_int ]
|
||||
|
||||
@ -60,3 +60,16 @@ BEGIN_PROVIDER [ character*(1024), ezfio_work_dir ]
|
||||
ezfio_work_dir = trim(ezfio_filename)//'/work/'
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ character*(1024), ezfio_work_dir_pid ]
|
||||
use c_functions
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! EZFIO/work/pid_
|
||||
END_DOC
|
||||
character*(32) :: pid_str
|
||||
integer :: getpid
|
||||
|
||||
write(pid_str,*) getpid()
|
||||
ezfio_work_dir_pid = trim(ezfio_work_dir)//'/'//trim(pid_str)//'_'
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
@ -9,16 +9,20 @@ module mmap_module
|
||||
integer :: fd ! File descriptor
|
||||
|
||||
! Pointers to data
|
||||
integer, pointer, dimension (:) :: i1
|
||||
integer, pointer, dimension (:,:) :: i2
|
||||
integer, pointer, dimension (:,:,:) :: i3
|
||||
integer, pointer, dimension (:,:,:,:) :: i4
|
||||
integer, pointer :: i1(:)
|
||||
integer, pointer :: i2(:,:)
|
||||
integer, pointer :: i3(:,:,:)
|
||||
integer, pointer :: i4(:,:,:,:)
|
||||
|
||||
! Pointers to data
|
||||
double precision, pointer, dimension (:) :: d1
|
||||
double precision, pointer, dimension (:,:) :: d2
|
||||
double precision, pointer, dimension (:,:,:) :: d3
|
||||
double precision, pointer, dimension (:,:,:,:) :: d4
|
||||
integer*8, pointer :: i81(:)
|
||||
integer*8, pointer :: i82(:,:)
|
||||
integer*8, pointer :: i83(:,:,:)
|
||||
integer*8, pointer :: i84(:,:,:,:)
|
||||
|
||||
double precision, pointer :: d1(:)
|
||||
double precision, pointer :: d2(:,:)
|
||||
double precision, pointer :: d3(:,:,:)
|
||||
double precision, pointer :: d4(:,:,:,:)
|
||||
end type mmap_type
|
||||
|
||||
interface
|
||||
@ -138,8 +142,17 @@ module mmap_module
|
||||
type(mmap_type), intent(out) :: map ! mmap
|
||||
|
||||
integer :: i
|
||||
logical :: temporary
|
||||
|
||||
temporary = ( trim(filename) == '' )
|
||||
|
||||
if (.not.temporary) then
|
||||
map%filename = filename
|
||||
else
|
||||
call getenv('EZFIO_FILE', map%filename)
|
||||
map%filename = trim(map%filename) // '/work/tmpfile'
|
||||
endif
|
||||
|
||||
map%filename = filename
|
||||
map%length = int(bytes,8)
|
||||
do i=1,size(shape)
|
||||
map%length = map%length * shape(i)
|
||||
@ -152,6 +165,13 @@ module mmap_module
|
||||
single_node, &
|
||||
map%ptr)
|
||||
|
||||
if (temporary) then
|
||||
! Deleting the file while it is open makes the file invisible on the filesystem,
|
||||
! and automatically deleted, even if the program crashes
|
||||
open(UNIT=47, FILE=trim(map%filename), STATUS='OLD')
|
||||
close(47,STATUS='DELETE')
|
||||
endif
|
||||
|
||||
map%d1 => NULL()
|
||||
map%d2 => NULL()
|
||||
map%d3 => NULL()
|
||||
@ -160,19 +180,22 @@ module mmap_module
|
||||
map%i2 => NULL()
|
||||
map%i3 => NULL()
|
||||
map%i4 => NULL()
|
||||
map%i81 => NULL()
|
||||
map%i82 => NULL()
|
||||
map%i83 => NULL()
|
||||
map%i84 => NULL()
|
||||
|
||||
end
|
||||
|
||||
subroutine mmap_create_d(filename, shape, bytes, read_only, single_node, map)
|
||||
subroutine mmap_create_d(filename, shape, read_only, single_node, map)
|
||||
implicit none
|
||||
character*(*), intent(in) :: filename ! Name of the mapped file
|
||||
integer*8, intent(in) :: shape(:) ! Shape of the array to map
|
||||
integer, intent(in) :: bytes ! Number of bytes per element
|
||||
logical, intent(in) :: read_only ! If true, mmap is read-only
|
||||
logical, intent(in) :: single_node! If true, mmap is on a single node
|
||||
type(mmap_type), intent(out) :: map ! mmap
|
||||
|
||||
call mmap_create(filename, shape, bytes, read_only, single_node, map)
|
||||
call mmap_create(filename, shape, 8, read_only, single_node, map)
|
||||
|
||||
select case (size(shape))
|
||||
case (1)
|
||||
@ -188,16 +211,15 @@ module mmap_module
|
||||
end select
|
||||
end subroutine
|
||||
|
||||
subroutine mmap_create_i(filename, shape, bytes, read_only, single_node, map)
|
||||
subroutine mmap_create_i(filename, shape, read_only, single_node, map)
|
||||
implicit none
|
||||
character*(*), intent(in) :: filename ! Name of the mapped file
|
||||
integer*8, intent(in) :: shape(:) ! Shape of the array to map
|
||||
integer, intent(in) :: bytes ! Number of bytes per element
|
||||
logical, intent(in) :: read_only ! If true, mmap is read-only
|
||||
logical, intent(in) :: single_node! If true, mmap is on a single node
|
||||
type(mmap_type), intent(out) :: map ! mmap
|
||||
|
||||
call mmap_create(filename, shape, bytes, read_only, single_node, map)
|
||||
call mmap_create(filename, shape, 4, read_only, single_node, map)
|
||||
|
||||
select case (size(shape))
|
||||
case (1)
|
||||
@ -213,6 +235,30 @@ module mmap_module
|
||||
end select
|
||||
end subroutine
|
||||
|
||||
subroutine mmap_create_i8(filename, shape, read_only, single_node, map)
|
||||
implicit none
|
||||
character*(*), intent(in) :: filename ! Name of the mapped file
|
||||
integer*8, intent(in) :: shape(:) ! Shape of the array to map
|
||||
logical, intent(in) :: read_only ! If true, mmap is read-only
|
||||
logical, intent(in) :: single_node! If true, mmap is on a single node
|
||||
type(mmap_type), intent(out) :: map ! mmap
|
||||
|
||||
call mmap_create(filename, shape, 8, read_only, single_node, map)
|
||||
|
||||
select case (size(shape))
|
||||
case (1)
|
||||
call c_f_pointer(map%ptr, map%i81, shape)
|
||||
case (2)
|
||||
call c_f_pointer(map%ptr, map%i82, shape)
|
||||
case (3)
|
||||
call c_f_pointer(map%ptr, map%i83, shape)
|
||||
case (4)
|
||||
call c_f_pointer(map%ptr, map%i84, shape)
|
||||
case default
|
||||
stop 'mmap: dimension not implemented'
|
||||
end select
|
||||
end subroutine
|
||||
|
||||
subroutine mmap_destroy(map)
|
||||
implicit none
|
||||
type(mmap_type), intent(inout) :: map
|
||||
@ -231,6 +277,10 @@ module mmap_module
|
||||
map%i2 => NULL()
|
||||
map%i3 => NULL()
|
||||
map%i4 => NULL()
|
||||
map%i81 => NULL()
|
||||
map%i82 => NULL()
|
||||
map%i83 => NULL()
|
||||
map%i84 => NULL()
|
||||
end subroutine
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user