diff --git a/src/ao_two_e_ints/cholesky.irp.f b/src/ao_two_e_ints/cholesky.irp.f index bae10cc7..d409a6d5 100644 --- a/src/ao_two_e_ints/cholesky.irp.f +++ b/src/ao_two_e_ints/cholesky.irp.f @@ -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 diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 191e0021..464b646f 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -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 diff --git a/src/davidson/u0_h_u0.irp.f b/src/davidson/u0_h_u0.irp.f index 7ef154a3..c6b36f3d 100644 --- a/src/davidson/u0_h_u0.irp.f +++ b/src/davidson/u0_h_u0.irp.f @@ -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 ! ----------------------- diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index 38fb56bd..06ef1fc5 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -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 ! ----------------------- diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index 771c30a1..87c5d360 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -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 ] diff --git a/src/ezfio_files/ezfio.irp.f b/src/ezfio_files/ezfio.irp.f index 02f45571..ef19d551 100644 --- a/src/ezfio_files/ezfio.irp.f +++ b/src/ezfio_files/ezfio.irp.f @@ -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 + diff --git a/src/utils/mmap.f90 b/src/utils/mmap.f90 index a9841a91..4db655a2 100644 --- a/src/utils/mmap.f90 +++ b/src/utils/mmap.f90 @@ -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