PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 12:23:43 +01:00
Code Releases Activity

Working on compute_singles

Browse Source
This commit is contained in:
Anthony Scemama 2024-09-26 16:21:04 +02:00
parent 4c4c65581a
commit db29e0048a
7 changed files with 322 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/ao_two_e_ints/cholesky.irp.f
View File

@ -181,15 +181,9 @@ END_PROVIDER
rank_max = min(np,20*elec_num*elec_num) rank_max = min(np,20*elec_num*elec_num)
endif 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 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. ! 3.
N = 0 N = 0

7
src/davidson/diagonalization_hs2_dressed.irp.f
View File

@ -774,6 +774,13 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
lambda & lambda &
) )
FREE nthreads_davidson 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 end

136
src/davidson/u0_h_u0.irp.f
View File

@ -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 ! if (.not.compute_singles) then
! provide singles_beta_csc ! provide singles_beta_csc
! endif ! endif
PROVIDE singles_beta_csc_map singles_alpha_csc_map
compute_singles=.True. compute_singles=.True.
@ -209,8 +212,8 @@ compute_singles=.True.
!$OMP psi_bilinear_matrix_transp_rows_loc, & !$OMP psi_bilinear_matrix_transp_rows_loc, &
!$OMP istart, iend, istep, irp_here, v_t, & !$OMP istart, iend, istep, irp_here, v_t, &
!$OMP ishift, idx0, u_t, maxab, compute_singles, & !$OMP ishift, idx0, u_t, maxab, compute_singles, &
!$OMP singles_alpha_csc,singles_alpha_csc_idx, & !$OMP singles_alpha_csc_map,singles_alpha_csc_idx, &
!$OMP singles_beta_csc,singles_beta_csc_idx) & !$OMP singles_beta_csc_map,singles_beta_csc_idx) &
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$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 lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
!$OMP buffer, doubles, n_doubles, umax, & !$OMP buffer, doubles, n_doubles, umax, &
@ -272,7 +275,7 @@ compute_singles=.True.
!DIR$ LOOP COUNT avg(1000) !DIR$ LOOP COUNT avg(1000)
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1 do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
n_singles_b = n_singles_b+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 enddo
endif endif
endif endif
@ -287,8 +290,7 @@ compute_singles=.True.
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) 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) l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det) ASSERT (l_a <= N_det)
@ -311,69 +313,67 @@ compute_singles=.True.
buffer, idx, tmp_det(1,1), j, & buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a ) singles_a, n_singles_a )
!----- else
! else
! ! Search for singles
! ! Search for singles
! ! Right boundary
!call cpu_time(time0) l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
! ! Right boundary ASSERT (l_a <= N_det)
! l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1 do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
! ASSERT (l_a <= N_det) lrow = psi_bilinear_matrix_rows(l_a)
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) ASSERT (lrow <= N_det_alpha_unique)
! lrow = psi_bilinear_matrix_rows(l_a)
! ASSERT (lrow <= N_det_alpha_unique) left = singles_alpha_csc_idx(krow)
! right_max = -1_8
! left = singles_alpha_csc_idx(krow) right = singles_alpha_csc_idx(krow+1)
! right_max = -1_8 do while (right-left>0_8)
! right = singles_alpha_csc_idx(krow+1) k8 = shiftr(right+left,1)
! do while (right-left>0_8) if (singles_alpha_csc_map%i1(k8) > lrow) then
! k8 = shiftr(right+left,1) right = k8
! if (singles_alpha_csc(k8) > lrow) then else if (singles_alpha_csc_map%i1(k8) < lrow) then
! right = k8 left = k8 + 1_8
! else if (singles_alpha_csc(k8) < lrow) then else
! left = k8 + 1_8 right_max = k8+1_8
! else exit
! right_max = k8+1_8 endif
! exit enddo
! endif if (right_max > 0_8) exit
! enddo l_a = l_a-1
! if (right_max > 0_8) exit enddo
! l_a = l_a-1 if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
! enddo
! if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow) ! Search
! n_singles_a = 0
! ! Search l_a = psi_bilinear_matrix_columns_loc(lcol)
! n_singles_a = 0 ASSERT (l_a <= N_det)
! 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)
! last_found = singles_alpha_csc_idx(krow) lrow = psi_bilinear_matrix_rows(l_a)
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) ASSERT (lrow <= N_det_alpha_unique)
! lrow = psi_bilinear_matrix_rows(l_a)
! ASSERT (lrow <= N_det_alpha_unique) left = last_found
! right = right_max
! left = last_found do while (right-left>0_8)
! right = right_max k8 = shiftr(right+left,1)
! do while (right-left>0_8) if (singles_alpha_csc_map%i1(k8) > lrow) then
! k8 = shiftr(right+left,1) right = k8
! if (singles_alpha_csc(k8) > lrow) then else if (singles_alpha_csc_map%i1(k8) < lrow) then
! right = k8 left = k8 + 1_8
! else if (singles_alpha_csc(k8) < lrow) then else
! left = k8 + 1_8 n_singles_a += 1
! else singles_a(n_singles_a) = l_a
! n_singles_a += 1 last_found = k8+1_8
! singles_a(n_singles_a) = l_a exit
! last_found = k8+1_8 endif
! exit enddo
! endif l_a = l_a+1
! enddo enddo
! l_a = l_a+1 j = j-1
! enddo
! j = j-1 endif
!
! endif
!-----
! Loop over alpha singles ! Loop over alpha singles
! ----------------------- ! -----------------------

140
src/davidson/u0_hs2_u0.irp.f
View File

@ -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 ! if (.not.compute_singles) then
! provide singles_beta_csc ! provide singles_beta_csc
! endif ! 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 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 ishift, idx0, u_t, maxab, compute_singles, &
!$OMP singles_alpha_csc,singles_alpha_csc_idx, & !$OMP singles_alpha_csc,singles_alpha_csc_idx, &
!$OMP singles_beta_csc,singles_beta_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 PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
!$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, & !$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
!$OMP buffer, doubles, n_doubles, umax, & !$OMP buffer, doubles, n_doubles, umax, &
@ -311,9 +317,11 @@ compute_singles=.True.
!DIR$ LOOP COUNT avg(1000) !DIR$ LOOP COUNT avg(1000)
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1 do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
n_singles_b = n_singles_b+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) singles_b(n_singles_b) = singles_beta_csc(k8)
enddo enddo
endif endif
endif endif
kcol_prev = kcol kcol_prev = kcol
@ -326,8 +334,7 @@ compute_singles=.True.
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) 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) l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det) ASSERT (l_a <= N_det)
@ -352,69 +359,70 @@ compute_singles=.True.
buffer, idx, tmp_det(1,1), j, & buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a ) singles_a, n_singles_a )
!----- else
! else
! ! Search for singles
! ! Search for singles
! ! Right boundary
!call cpu_time(time0) l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
! ! Right boundary ASSERT (l_a <= N_det)
! l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1 do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
! ASSERT (l_a <= N_det) lrow = psi_bilinear_matrix_rows(l_a)
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) ASSERT (lrow <= N_det_alpha_unique)
! lrow = psi_bilinear_matrix_rows(l_a)
! ASSERT (lrow <= N_det_alpha_unique) left = singles_alpha_csc_idx(krow)
! right_max = -1_8
! left = singles_alpha_csc_idx(krow) right = singles_alpha_csc_idx(krow+1)
! right_max = -1_8 do while (right-left>0_8)
! right = singles_alpha_csc_idx(krow+1) k8 = shiftr(right+left,1)
! do while (right-left>0_8) ! if (singles_alpha_csc_map%i1(k8) > lrow) then
! k8 = shiftr(right+left,1) if (singles_alpha_csc(k8) > lrow) then
! if (singles_alpha_csc(k8) > lrow) then right = k8
! right = k8 ! else if (singles_alpha_csc_map%i1(k8) < lrow) then
! else if (singles_alpha_csc(k8) < lrow) then else if (singles_alpha_csc(k8) < lrow) then
! left = k8 + 1_8 left = k8 + 1_8
! else else
! right_max = k8+1_8 right_max = k8+1_8
! exit exit
! endif endif
! enddo enddo
! if (right_max > 0_8) exit if (right_max > 0_8) exit
! l_a = l_a-1 l_a = l_a-1
! enddo enddo
! if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow) if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
!
! ! Search ! Search
! n_singles_a = 0 n_singles_a = 0
! l_a = psi_bilinear_matrix_columns_loc(lcol) l_a = psi_bilinear_matrix_columns_loc(lcol)
! ASSERT (l_a <= N_det) ASSERT (l_a <= N_det)
!
! last_found = singles_alpha_csc_idx(krow) last_found = singles_alpha_csc_idx(krow)
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
! lrow = psi_bilinear_matrix_rows(l_a) lrow = psi_bilinear_matrix_rows(l_a)
! ASSERT (lrow <= N_det_alpha_unique) ASSERT (lrow <= N_det_alpha_unique)
!
! left = last_found left = last_found
! right = right_max right = right_max
! do while (right-left>0_8) do while (right-left>0_8)
! k8 = shiftr(right+left,1) k8 = shiftr(right+left,1)
! if (singles_alpha_csc(k8) > lrow) then ! if (singles_alpha_csc_map%i1(k8) > lrow) then
! right = k8 if (singles_alpha_csc(k8) > lrow) then
! else if (singles_alpha_csc(k8) < lrow) then right = k8
! left = k8 + 1_8 ! else if (singles_alpha_csc_map%i1(k8) < lrow) then
! else else if (singles_alpha_csc(k8) < lrow) then
! n_singles_a += 1 left = k8 + 1_8
! singles_a(n_singles_a) = l_a else
! last_found = k8+1_8 n_singles_a += 1
! exit singles_a(n_singles_a) = l_a
! endif last_found = k8+1_8
! enddo exit
! l_a = l_a+1 endif
! enddo enddo
! j = j-1 l_a = l_a+1
! enddo
! endif j = j-1
!-----
endif
! Loop over alpha singles ! Loop over alpha singles
! ----------------------- ! -----------------------

124
src/determinants/spindeterminants.irp.f
View File

@ -910,6 +910,7 @@ subroutine copy_psi_bilinear_to_psi(psi, isize)
end end
use mmap_module
BEGIN_PROVIDER [ integer*8, singles_alpha_csc_idx, (N_det_alpha_unique+1) ] BEGIN_PROVIDER [ integer*8, singles_alpha_csc_idx, (N_det_alpha_unique+1) ]
&BEGIN_PROVIDER [ integer*8, singles_alpha_csc_size ] &BEGIN_PROVIDER [ integer*8, singles_alpha_csc_size ]
@ -926,12 +927,11 @@ end
idx0(i) = i idx0(i) = i
enddo enddo
!$OMP PARALLEL DEFAULT(NONE) & !$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
!$OMP idx0, N_int, singles_alpha_csc, & !$OMP idx0, N_int, singles_alpha_csc_idx) &
!$OMP elec_alpha_num, mo_num, singles_alpha_csc_idx) &
!$OMP PRIVATE(i,s,j) !$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) !$OMP DO SCHEDULE(static,64)
do i=1, N_det_alpha_unique do i=1, N_det_alpha_unique
call get_all_spin_singles( & 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 PARALLEL DO DEFAULT(NONE) &
!$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, &
!$OMP idx0, N_int, singles_alpha_csc, singles_alpha_csc_idx)& !$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 do i=1, N_det_alpha_unique
call get_all_spin_singles( & call get_all_spin_singles( &
psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int,& 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 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) ] BEGIN_PROVIDER [ integer*8, singles_beta_csc_idx, (N_det_beta_unique+1) ]
@ -997,13 +1026,12 @@ END_PROVIDER
idx0(i) = i idx0(i) = i
enddo enddo
!$OMP PARALLEL DEFAULT(NONE) & !$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, & !$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, &
!$OMP idx0, N_int, singles_beta_csc, & !$OMP idx0, N_int, singles_beta_csc_idx) &
!$OMP elec_beta_num, mo_num, singles_beta_csc_idx) &
!$OMP PRIVATE(i,s,j) !$OMP PRIVATE(i,s,j)
allocate (s(elec_beta_num*(mo_num-elec_beta_num))) allocate (s(N_det_beta_unique))
!$OMP DO SCHEDULE(static,1) !$OMP DO SCHEDULE(static)
do i=1, N_det_beta_unique do i=1, N_det_beta_unique
call get_all_spin_singles( & call get_all_spin_singles( &
psi_det_beta_unique, idx0, psi_det_beta_unique(1,i), N_int,& 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 PARALLEL DO DEFAULT(NONE) &
!$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, & !$OMP SHARED(N_det_beta_unique, psi_det_beta_unique, &
!$OMP idx0, N_int, singles_beta_csc, singles_beta_csc_idx)& !$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 do i=1, N_det_beta_unique
call get_all_spin_singles( & call get_all_spin_singles( &
psi_det_beta_unique, idx0, psi_det_beta_unique(1,i), N_int,& 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 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 :: i
integer(bit_kind) :: v integer(bit_kind) :: v
integer :: degree integer :: degree
integer :: add_single(0:64) = (/ 0, 0, 1, 0, 0, (0, i=1,60) /)
include 'utils/constants.include.F' include 'utils/constants.include.F'
n_singles = 1 n_singles = 0
do i=1,size_buffer do i=1,size_buffer
degree = popcnt(xor( spindet, buffer(i) )) degree = popcnt(xor( spindet, buffer(i) ))
singles(n_singles) = idx(i) if (degree == 2) then
n_singles = n_singles+add_single(degree) n_singles = n_singles+1
singles(n_singles) = idx(i)
endif
enddo enddo
n_singles = n_singles-1
end end
@ -1143,15 +1202,15 @@ subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_
integer :: i integer :: i
include 'utils/constants.include.F' include 'utils/constants.include.F'
integer :: degree 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 do i=1,size_buffer
degree = popcnt(xor( spindet, buffer(i) )) degree = popcnt(xor( spindet, buffer(i) ))
doubles(n_doubles) = idx(i) if (degree == 4) then
n_doubles = n_doubles+add_double(degree) n_doubles = n_doubles+1
doubles(n_doubles) = idx(i)
endif
enddo enddo
n_doubles = n_doubles-1
end 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(bit_kind) :: xorvec($N_int)
integer :: degree integer :: degree
n_singles = 1 n_singles = 0
n_doubles = 1 n_doubles = 0
do i=1,size_buffer do i=1,size_buffer
do k=1,$N_int do k=1,$N_int
@ -1197,16 +1256,14 @@ subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_bu
enddo enddo
if ( degree == 4 ) then if ( degree == 4 ) then
doubles(n_doubles) = idx(i)
n_doubles = n_doubles+1 n_doubles = n_doubles+1
doubles(n_doubles) = idx(i)
else if ( degree == 2 ) then else if ( degree == 2 ) then
singles(n_singles) = idx(i)
n_singles = n_singles+1 n_singles = n_singles+1
singles(n_singles) = idx(i)
endif endif
enddo enddo
n_singles = n_singles-1
n_doubles = n_doubles-1
end 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(bit_kind) :: xorvec($N_int)
integer :: degree integer :: degree
n_singles = 1 n_singles = 0
do i=1,size_buffer do i=1,size_buffer
do k=1,$N_int do k=1,$N_int
@ -1248,11 +1305,10 @@ subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, single
cycle cycle
endif endif
singles(n_singles) = idx(i)
n_singles = n_singles+1 n_singles = n_singles+1
singles(n_singles) = idx(i)
enddo enddo
n_singles = n_singles-1
end end
@ -1276,7 +1332,7 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
include 'utils/constants.include.F' include 'utils/constants.include.F'
integer(bit_kind) :: xorvec($N_int) integer(bit_kind) :: xorvec($N_int)
n_doubles = 1 n_doubles = 0
do i=1,size_buffer do i=1,size_buffer
do k=1,$N_int do k=1,$N_int
@ -1293,13 +1349,11 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
cycle cycle
endif endif
doubles(n_doubles) = idx(i)
n_doubles = n_doubles+1 n_doubles = n_doubles+1
doubles(n_doubles) = idx(i)
enddo enddo
n_doubles = n_doubles-1
end end
SUBST [ N_int ] SUBST [ N_int ]

13
src/ezfio_files/ezfio.irp.f
View File

@ -60,3 +60,16 @@ BEGIN_PROVIDER [ character*(1024), ezfio_work_dir ]
ezfio_work_dir = trim(ezfio_filename)//'/work/' ezfio_work_dir = trim(ezfio_filename)//'/work/'
END_PROVIDER 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

82
src/utils/mmap.f90
View File

@ -9,16 +9,20 @@ module mmap_module
integer :: fd ! File descriptor integer :: fd ! File descriptor
! Pointers to data ! Pointers to data
integer, pointer, dimension (:) :: i1 integer, pointer :: i1(:)
integer, pointer, dimension (:,:) :: i2 integer, pointer :: i2(:,:)
integer, pointer, dimension (:,:,:) :: i3 integer, pointer :: i3(:,:,:)
integer, pointer, dimension (:,:,:,:) :: i4 integer, pointer :: i4(:,:,:,:)
! Pointers to data integer*8, pointer :: i81(:)
double precision, pointer, dimension (:) :: d1 integer*8, pointer :: i82(:,:)
double precision, pointer, dimension (:,:) :: d2 integer*8, pointer :: i83(:,:,:)
double precision, pointer, dimension (:,:,:) :: d3 integer*8, pointer :: i84(:,:,:,:)
double precision, pointer, dimension (:,:,:,:) :: d4
double precision, pointer :: d1(:)
double precision, pointer :: d2(:,:)
double precision, pointer :: d3(:,:,:)
double precision, pointer :: d4(:,:,:,:)
end type mmap_type end type mmap_type
interface interface
@ -138,8 +142,17 @@ module mmap_module
type(mmap_type), intent(out) :: map ! mmap type(mmap_type), intent(out) :: map ! mmap
integer :: i 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) map%length = int(bytes,8)
do i=1,size(shape) do i=1,size(shape)
map%length = map%length * shape(i) map%length = map%length * shape(i)
@ -152,6 +165,13 @@ module mmap_module
single_node, & single_node, &
map%ptr) 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%d1 => NULL()
map%d2 => NULL() map%d2 => NULL()
map%d3 => NULL() map%d3 => NULL()
@ -160,19 +180,22 @@ module mmap_module
map%i2 => NULL() map%i2 => NULL()
map%i3 => NULL() map%i3 => NULL()
map%i4 => NULL() map%i4 => NULL()
map%i81 => NULL()
map%i82 => NULL()
map%i83 => NULL()
map%i84 => NULL()
end 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 implicit none
character*(*), intent(in) :: filename ! Name of the mapped file character*(*), intent(in) :: filename ! Name of the mapped file
integer*8, intent(in) :: shape(:) ! Shape of the array to map 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) :: read_only ! If true, mmap is read-only
logical, intent(in) :: single_node! If true, mmap is on a single node logical, intent(in) :: single_node! If true, mmap is on a single node
type(mmap_type), intent(out) :: map ! mmap 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)) select case (size(shape))
case (1) case (1)
@ -188,16 +211,15 @@ module mmap_module
end select end select
end subroutine 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 implicit none
character*(*), intent(in) :: filename ! Name of the mapped file character*(*), intent(in) :: filename ! Name of the mapped file
integer*8, intent(in) :: shape(:) ! Shape of the array to map 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) :: read_only ! If true, mmap is read-only
logical, intent(in) :: single_node! If true, mmap is on a single node logical, intent(in) :: single_node! If true, mmap is on a single node
type(mmap_type), intent(out) :: map ! mmap 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)) select case (size(shape))
case (1) case (1)
@ -213,6 +235,30 @@ module mmap_module
end select end select
end subroutine 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) subroutine mmap_destroy(map)
implicit none implicit none
type(mmap_type), intent(inout) :: map type(mmap_type), intent(inout) :: map
@ -231,6 +277,10 @@ module mmap_module
map%i2 => NULL() map%i2 => NULL()
map%i3 => NULL() map%i3 => NULL()
map%i4 => NULL() map%i4 => NULL()
map%i81 => NULL()
map%i82 => NULL()
map%i83 => NULL()
map%i84 => NULL()
end subroutine end subroutine