diff --git a/src/hfx_ri.F b/src/hfx_ri.F index 43e1e78511..d6c4efab97 100644 --- a/src/hfx_ri.F +++ b/src/hfx_ri.F @@ -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) diff --git a/src/kpoint_coulomb_2c.F b/src/kpoint_coulomb_2c.F index 5e6f7aa161..b22c38694d 100644 --- a/src/kpoint_coulomb_2c.F +++ b/src/kpoint_coulomb_2c.F @@ -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 diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index c809751189..42a39e4486 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -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) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index 0a02295841..dbccab3f03 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -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 diff --git a/src/rpa_gw_im_time_util.F b/src/rpa_gw_im_time_util.F index 343457afb3..7c32eabb1d 100644 --- a/src/rpa_gw_im_time_util.F +++ b/src/rpa_gw_im_time_util.F @@ -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)) diff --git a/src/rpa_gw_kpoints_util.F b/src/rpa_gw_kpoints_util.F index f527142c41..984f3daa5a 100644 --- a/src/rpa_gw_kpoints_util.F +++ b/src/rpa_gw_kpoints_util.F @@ -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)