comp-chem/cp2k
1
0
Fork 0
mirror of https://github.com/cp2k/cp2k.git synced 2026-07-28 22:25:32 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions

Various minor tweaks

Browse source 
- Conditionally prepare max_contraction arrays.
- Make more use of SOURCE argument (ALLOCATE).
- OpenMP parallelized loop (lattice_sum).
- Change loop order.
This commit is contained in:
Hans Pabst 2025-10-29 14:46:31 +01:00
parent 09343da68f
commit e68414f036
6 changed files with 104 additions and 122 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/hfx_ri.F
View file

@ -1718,8 +1718,8 @@ CONTAINS
CALL dbt_batched_contract_finalize(ri_data%t_3c_int_ctr_1(1, 1))
CALL dbt_batched_contract_finalize(t_3c_3)
DO i_mem = 1, n_mem
DO j_mem = 1, n_mem_RI
DO j_mem = 1, n_mem_RI
DO i_mem = 1, n_mem
ASSOCIATE (blk_indices => ri_data%blk_indices(i_mem, j_mem), t_3c => ri_data%t_3c_int_ctr_1(1, 1))
CALL decompress_tensor(tensor_old, blk_indices%ind, &
ri_data%store_3c(i_mem, j_mem), ri_data%filter_eps_storage)

4
src/kpoint_coulomb_2c.F
View file

@ -179,10 +179,14 @@ CONTAINS
qs_kind_set, atomic_kind_set, basis_type, cell, &
operator_type)
!$OMP PARALLEL DO DEFAULT(NONE) &
!$OMP SHARED(blocks_v_L, blocks_v_L_store) &
!$OMP PRIVATE(i_block)
DO i_block = 1, SIZE(blocks_v_L)
blocks_v_L_store(i_block)%block(:, :) = blocks_v_L_store(i_block)%block(:, :) &
+ blocks_v_L(i_block)%block(:, :)
END DO
!$OMP END PARALLEL DO
END DO
END DO

38
src/post_scf_bandstructure_utils.F
View file

@ -1392,12 +1392,11 @@ CONTAINS
CALL bs_env%para_env%min(i_y_start_glob)
CALL bs_env%para_env%max(i_y_end_glob)
ALLOCATE (n_sum_for_bins(bin_mesh(1), bin_mesh(2)))
n_sum_for_bins(:, :) = 0
ALLOCATE (n_sum_for_bins(bin_mesh(1), bin_mesh(2)), SOURCE=0)
! transform interval [i_x_start, i_x_end] to [1, bin_mesh(1)] (and same for y)
DO i_x = i_x_start, i_x_end
DO i_y = i_y_start, i_y_end
DO i_y = i_y_start, i_y_end
DO i_x = i_x_start, i_x_end
i_x_bin = bin_mesh(1)*(i_x - i_x_start_glob)/(i_x_end_glob - i_x_start_glob + 1) + 1
i_y_bin = bin_mesh(2)*(i_y - i_y_start_glob)/(i_y_end_glob - i_y_start_glob + 1) + 1
LDOS_2d_bins(i_x_bin, i_y_bin, :) = LDOS_2d_bins(i_x_bin, i_y_bin, :) + &
@ -1410,8 +1409,8 @@ CONTAINS
CALL bs_env%para_env%sum(n_sum_for_bins)
! divide by number of terms in the sum so we have the average LDOS(x,y,E)
DO i_x_bin = 1, bin_mesh(1)
DO i_y_bin = 1, bin_mesh(2)
DO i_y_bin = 1, bin_mesh(2)
DO i_x_bin = 1, bin_mesh(1)
LDOS_2d_bins(i_x_bin, i_y_bin, :) = LDOS_2d_bins(i_x_bin, i_y_bin, :)/ &
REAL(n_sum_for_bins(i_x_bin, i_y_bin), KIND=dp)
END DO
@ -1470,8 +1469,8 @@ CONTAINS
IF (bs_env%para_env%is_source()) THEN
DO i_x = i_x_start, i_x_end
DO i_y = i_y_start, i_y_end
DO i_y = i_y_start, i_y_end
DO i_x = i_x_start, i_x_end
idx(1) = (REAL(i_x, KIND=dp) - 0.5_dp)/REAL(n_x, KIND=dp)
idx(2) = (REAL(i_y, KIND=dp) - 0.5_dp)/REAL(n_y, KIND=dp)
@ -2224,8 +2223,8 @@ CONTAINS
CALL cp_cfm_to_cfm(cfm_s, cfm_s_i_kind)
! set entries in overlap matrix to zero which do not belong to atoms of i_kind
DO i_row = 1, nrow_local
DO j_col = 1, ncol_local
DO j_col = 1, ncol_local
DO i_row = 1, nrow_local
i_global = row_indices(i_row)
@ -2352,7 +2351,7 @@ CONTAINS
CHARACTER(LEN=*), PARAMETER :: routineN = 'cfm_ikp_from_fm_Gamma'
INTEGER :: col_global, handle, i, i_atom, i_atom_old, i_cell, i_mic_cell, i_row, j, j_atom, &
INTEGER :: col_global, handle, i_atom, i_atom_old, i_cell, i_mic_cell, i_row, j_atom, &
j_atom_old, j_cell, j_col, n_bf, ncol_local, nrow_local, num_cells, row_global
INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_from_bf
INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
@ -2400,8 +2399,8 @@ CONTAINS
i_atom_old = 0
j_atom_old = 0
DO i_row = 1, nrow_local
DO j_col = 1, ncol_local
DO j_col = 1, ncol_local
DO i_row = 1, nrow_local
row_global = row_indices(i_row)
col_global = col_indices(j_col)
@ -2446,11 +2445,8 @@ CONTAINS
REAL(index_to_cell(2, i_mic_cell), dp)*kpoints%xkp(2, ikp) + &
REAL(index_to_cell(3, i_mic_cell), dp)*kpoints%xkp(3, ikp)
i = i_row
j = j_col
cfm_ikp%local_data(i, j) = COS(twopi*arg)*fm_Gamma%local_data(i, j)*z_one + &
SIN(twopi*arg)*fm_Gamma%local_data(i, j)*gaussi
cfm_ikp%local_data(i_row, j_col) = COS(twopi*arg)*fm_Gamma%local_data(i_row, j_col)*z_one + &
SIN(twopi*arg)*fm_Gamma%local_data(i_row, j_col)*gaussi
j_atom_old = j_atom
i_atom_old = i_atom
@ -2479,7 +2475,7 @@ CONTAINS
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(cp_fm_type) :: fm_W_MIC_freq_j
TYPE(cp_cfm_type) :: cfm_W_ikp_freq_j
INTEGER :: ikp
INTEGER, INTENT(IN) :: ikp
TYPE(kpoint_type), POINTER :: kpoints
CHARACTER(LEN=*) :: basis_type
REAL(KIND=dp), OPTIONAL :: wkp_ext
@ -2531,8 +2527,8 @@ CONTAINS
iatom_old = 0
jatom_old = 0
DO irow = 1, nrow_local
DO jcol = 1, ncol_local
DO jcol = 1, ncol_local
DO irow = 1, nrow_local
i_bf = row_indices(irow)
j_bf = col_indices(jcol)

162
src/qs_tensors.F
View file

@ -184,13 +184,10 @@ CONTAINS
CALL section_vals_val_get(qs_env%input, "DFT%SUBCELLS", r_val=subcells)
ALLOCATE (i_present(nkind), j_present(nkind))
ALLOCATE (i_radius(nkind), j_radius(nkind))
i_present = .FALSE.
j_present = .FALSE.
i_radius = 0.0_dp
j_radius = 0.0_dp
ALLOCATE (i_present(nkind), SOURCE=.FALSE.)
ALLOCATE (j_present(nkind), SOURCE=.FALSE.)
ALLOCATE (i_radius(nkind), SOURCE=0.0_dp)
ALLOCATE (j_radius(nkind), SOURCE=0.0_dp)
IF (PRESENT(dist_2d)) dist_2d_prv => dist_2d
@ -245,8 +242,7 @@ CONTAINS
CPABORT("Operator not implemented.")
END IF
ALLOCATE (pair_radius(nkind, nkind))
pair_radius = 0.0_dp
ALLOCATE (pair_radius(nkind, nkind), SOURCE=0.0_dp)
CALL pair_radius_setup(i_present, j_present, i_radius, j_radius, pair_radius)
ALLOCATE (atom2d(nkind))
@ -1321,36 +1317,32 @@ CONTAINS
IF (kind_radius_j + kind_radius_k + dr_jk < djk) CYCLE
IF (kind_radius_k + kind_radius_i + dr_ik < dik) CYCLE
ALLOCATE (max_contraction_i(nseti))
max_contraction_i = 0.0_dp
DO iset = 1, nseti
sgfi = first_sgf_i(1, iset)
max_contraction_i(iset) = MAXVAL((/(SUM(ABS(sphi_i(:, i))), i=sgfi, sgfi + nsgfi(iset) - 1)/))
END DO
IF (PRESENT(der_eps)) THEN
ALLOCATE (max_contraction_i(nseti))
DO iset = 1, nseti
sgfi = first_sgf_i(1, iset)
max_contraction_i(iset) = MAXVAL((/(SUM(ABS(sphi_i(:, i))), i=sgfi, sgfi + nsgfi(iset) - 1)/))
END DO
ALLOCATE (max_contraction_j(nsetj))
max_contraction_j = 0.0_dp
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
ALLOCATE (max_contraction_j(nsetj))
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
max_contraction_k = 0.0_dp
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
END IF
CALL dbt_blk_sizes(t3c_der_i(jcell, kcell, 1), blk_idx, blk_size)
ALLOCATE (block_t_i(blk_size(2), blk_size(3), blk_size(1), 3))
ALLOCATE (block_t_j(blk_size(2), blk_size(3), blk_size(1), 3))
ALLOCATE (block_t_k(blk_size(2), blk_size(3), blk_size(1), 3))
ALLOCATE (block_t_i(blk_size(2), blk_size(3), blk_size(1), 3), SOURCE=0.0_dp)
ALLOCATE (block_t_j(blk_size(2), blk_size(3), blk_size(1), 3), SOURCE=0.0_dp)
ALLOCATE (block_t_k(blk_size(2), blk_size(3), blk_size(1), 3), SOURCE=0.0_dp)
block_t_i = 0.0_dp
block_t_j = 0.0_dp
block_t_k = 0.0_dp
block_j_not_zero = .FALSE.
block_k_not_zero = .FALSE.
@ -1374,10 +1366,8 @@ CONTAINS
sgfk = first_sgf_k(1, kset)
IF (ncoj*ncok*ncoi > 0) THEN
ALLOCATE (dijk_j(ncoj, ncok, ncoi, 3))
ALLOCATE (dijk_k(ncoj, ncok, ncoi, 3))
dijk_j(:, :, :, :) = 0.0_dp
dijk_k(:, :, :, :) = 0.0_dp
ALLOCATE (dijk_j(ncoj, ncok, ncoi, 3), SOURCE=0.0_dp)
ALLOCATE (dijk_k(ncoj, ncok, ncoi, 3), SOURCE=0.0_dp)
der_j_zero = .FALSE.
der_k_zero = .FALSE.
@ -1395,10 +1385,8 @@ CONTAINS
djk, dij, dik, lib, potential_parameter, &
der_abc_1_ext=der_ext_j, der_abc_2_ext=der_ext_k)
ELSE
ALLOCATE (tmp_ijk_i(ncoi, ncoj, ncok, 3))
ALLOCATE (tmp_ijk_j(ncoi, ncoj, ncok, 3))
tmp_ijk_i(:, :, :, :) = 0.0_dp
tmp_ijk_j(:, :, :, :) = 0.0_dp
ALLOCATE (tmp_ijk_i(ncoi, ncoj, ncok, 3), SOURCE=0.0_dp)
ALLOCATE (tmp_ijk_j(ncoi, ncoj, ncok, 3), SOURCE=0.0_dp)
CALL eri_3center_derivs(tmp_ijk_i, tmp_ijk_j, &
lmin_i(iset), lmax_i(iset), npgfi(iset), zeti(:, iset), rpgf_i(:, iset), ri, &
@ -1537,7 +1525,9 @@ CONTAINS
CALL timestop(handle2)
DEALLOCATE (block_t_i, block_t_j, block_t_k)
DEALLOCATE (max_contraction_i, max_contraction_j, max_contraction_k)
IF (PRESENT(der_eps)) THEN
DEALLOCATE (max_contraction_i, max_contraction_j, max_contraction_k)
END IF
END DO
IF (ALLOCATED(ccp_buffer)) DEALLOCATE (ccp_buffer)
@ -1762,8 +1752,8 @@ CONTAINS
END DO
m_max = maxli + maxlj + maxlk + 1
!To minimize expensive memory opsand generally optimize contraction, pre-allocate
!contiguous sphi arrays (and transposed in the cas of sphi_i)
!To minimize expensive memory ops and generally optimize contraction, pre-allocate
!contiguous sphi arrays (and transposed in the case of sphi_i)
NULLIFY (tspj, spi, spk)
ALLOCATE (spi(max_nset, nbasis), tspj(max_nset, nbasis), spk(max_nset, nbasis))
@ -1883,26 +1873,25 @@ CONTAINS
IF (kind_radius_j + kind_radius_k + dr_jk < djk) CYCLE
IF (kind_radius_k + kind_radius_i + dr_ik < dik) CYCLE
ALLOCATE (max_contraction_i(nseti))
max_contraction_i = 0.0_dp
DO iset = 1, nseti
sgfi = first_sgf_i(1, iset)
max_contraction_i(iset) = MAXVAL((/(SUM(ABS(sphi_i(:, i))), i=sgfi, sgfi + nsgfi(iset) - 1)/))
END DO
IF (PRESENT(der_eps)) THEN
ALLOCATE (max_contraction_i(nseti))
DO iset = 1, nseti
sgfi = first_sgf_i(1, iset)
max_contraction_i(iset) = MAXVAL((/(SUM(ABS(sphi_i(:, i))), i=sgfi, sgfi + nsgfi(iset) - 1)/))
END DO
ALLOCATE (max_contraction_j(nsetj))
max_contraction_j = 0.0_dp
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
ALLOCATE (max_contraction_j(nsetj))
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
max_contraction_k = 0.0_dp
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
END IF
CALL dbt_blk_sizes(t3c_trace, [iatom, jatom, katom], blk_size)
@ -1942,10 +1931,8 @@ CONTAINS
sgfk = first_sgf_k(1, kset)
IF (ncoj*ncok*ncoi > 0) THEN
ALLOCATE (dijk_j(ncoj, ncok, ncoi, 3))
ALLOCATE (dijk_k(ncoj, ncok, ncoi, 3))
dijk_j(:, :, :, :) = 0.0_dp
dijk_k(:, :, :, :) = 0.0_dp
ALLOCATE (dijk_j(ncoj, ncok, ncoi, 3), SOURCE=0.0_dp)
ALLOCATE (dijk_k(ncoj, ncok, ncoi, 3), SOURCE=0.0_dp)
der_j_zero = .FALSE.
der_k_zero = .FALSE.
@ -2073,7 +2060,9 @@ CONTAINS
END DO
DEALLOCATE (block_t_i, block_t_j, block_t_k)
DEALLOCATE (max_contraction_i, max_contraction_j, max_contraction_k, ablock)
IF (PRESENT(der_eps)) THEN
DEALLOCATE (max_contraction_i, max_contraction_j, max_contraction_k, ablock)
END IF
END DO
IF (ALLOCATED(ccp_buffer)) DEALLOCATE (ccp_buffer)
@ -2522,17 +2511,19 @@ CONTAINS
IF (kind_radius_j + kind_radius_k + dr_jk < djk) CYCLE
IF (kind_radius_k + kind_radius_i + dr_ik < dik) CYCLE
ALLOCATE (max_contraction_j(nsetj))
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
IF (PRESENT(int_eps)) THEN
ALLOCATE (max_contraction_j(nsetj))
DO jset = 1, nsetj
sgfj = first_sgf_j(1, jset)
max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, sgfj + nsgfj(jset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
ALLOCATE (max_contraction_k(nsetk))
DO kset = 1, nsetk
sgfk = first_sgf_k(1, kset)
max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, sgfk + nsgfk(kset) - 1)/))
END DO
END IF
CALL dbt_blk_sizes(t3c(jcell, kcell), blk_idx, blk_size)
@ -2649,7 +2640,9 @@ CONTAINS
END IF
DEALLOCATE (block_t)
DEALLOCATE (max_contraction_j, max_contraction_k)
IF (PRESENT(int_eps)) THEN
DEALLOCATE (max_contraction_j, max_contraction_k)
END IF
END DO
IF (ALLOCATED(ccp_buffer)) DEALLOCATE (ccp_buffer)
@ -2917,8 +2910,7 @@ CONTAINS
IF (ncoi*ncoj > 0) THEN
ALLOCATE (dij_contr(nsgfi(iset), nsgfj(jset)))
ALLOCATE (dij(ncoi, ncoj, 3))
dij(:, :, :) = 0.0_dp
ALLOCATE (dij(ncoi, ncoj, 3), SOURCE=0.0_dp)
ri = 0.0_dp
rj = rij
@ -3097,8 +3089,7 @@ CONTAINS
IF (ncoi*ncoj > 0) THEN
ALLOCATE (dij_contr(nsgfi(iset), nsgfj(jset)))
ALLOCATE (dij(ncoi, ncoj, 3))
dij(:, :, :) = 0.0_dp
ALLOCATE (dij(ncoi, ncoj, 3), SOURCE=0.0_dp)
ri = 0.0_dp
rj = rij
@ -3343,11 +3334,8 @@ CONTAINS
sgfj = first_sgf_j(1, jset)
IF (ncoi*ncoj > 0) THEN
ALLOCATE (sij_contr(nsgfi(iset), nsgfj(jset)))
sij_contr(:, :) = 0.0_dp
ALLOCATE (sij(ncoi, ncoj))
sij(:, :) = 0.0_dp
ALLOCATE (sij_contr(nsgfi(iset), nsgfj(jset)), SOURCE=0.0_dp)
ALLOCATE (sij(ncoi, ncoj), SOURCE=0.0_dp)
ri = 0.0_dp
rj = rij

12
src/rpa_gw_im_time_util.F
View file

@ -575,14 +575,10 @@ CONTAINS
ALLOCATE (buffer_rec(0:para_env%num_pe - 1))
ALLOCATE (buffer_send(0:para_env%num_pe - 1))
ALLOCATE (num_entries_rec(0:para_env%num_pe - 1))
ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1))
ALLOCATE (num_entries_send(0:para_env%num_pe - 1))
ALLOCATE (num_blocks_send(0:para_env%num_pe - 1))
num_entries_rec = 0
num_blocks_rec = 0
num_entries_send = 0
num_blocks_send = 0
ALLOCATE (num_entries_rec(0:para_env%num_pe - 1), SOURCE=0)
ALLOCATE (num_blocks_rec(0:para_env%num_pe - 1), SOURCE=0)
ALLOCATE (num_entries_send(0:para_env%num_pe - 1), SOURCE=0)
ALLOCATE (num_blocks_send(0:para_env%num_pe - 1), SOURCE=0)
CALL dbcsr_iterator_readonly_start(iter, mat_orig)
DO WHILE (dbcsr_iterator_blocks_left(iter))

6
src/rpa_gw_kpoints_util.F
View file

@ -290,10 +290,8 @@ CONTAINS
! Test that matrix is square
CALL cp_cfm_get_info(matrix, nrow_global=nrow_global, ncol_global=ncol_global)
CPASSERT(nrow_global == ncol_global)
ALLOCATE (eigenvalues(nrow_global))
eigenvalues(:) = 0.0_dp
ALLOCATE (eigenvalues_exponent(nrow_global))
eigenvalues_exponent(:) = z_zero
ALLOCATE (eigenvalues(nrow_global), SOURCE=0.0_dp)
ALLOCATE (eigenvalues_exponent(nrow_global), SOURCE=z_zero)
! Diagonalize matrix: get eigenvectors and eigenvalues
CALL cp_cfm_heevd(matrix, cfm_work, eigenvalues)