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)
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

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 &
)
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

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
! 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
! -----------------------

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
! 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
! -----------------------

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

@ -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 ]

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/'
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
! 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