From 6b2ed3993235b0e5fbea6fbb230b70115026808f Mon Sep 17 00:00:00 2001 From: Juerg Hutter Date: Wed, 3 Dec 2025 09:21:11 +0100 Subject: [PATCH] Make initialization of array in cp_fm_create optional. (#4579) --- src/bse_util.F | 6 ++-- src/fm/cp_cfm_types.F | 11 ++++-- src/fm/cp_fm_pool_types.F | 2 +- src/fm/cp_fm_types.F | 69 ++++++++++++++++++++++++++++++++---- src/gw_large_cell_gamma.F | 2 +- src/gw_utils.F | 3 +- src/mp2_ri_grad.F | 2 +- src/parallel_gemm_api.F | 16 ++++++++- src/qs_dcdr.F | 8 ++--- src/qs_dcdr_utils.F | 11 +++--- src/qs_density_matrices.F | 25 +++---------- src/qs_linres_current.F | 12 +++---- src/qs_linres_methods.F | 2 +- src/qs_linres_polar_utils.F | 11 +++--- src/qs_mfp.F | 2 +- src/qs_mo_methods.F | 2 +- src/qs_mo_types.F | 2 ++ src/qs_tddfpt2_eigensolver.F | 4 +-- src/qs_tddfpt2_soc.F | 8 ++--- src/qs_vcd.F | 4 +-- src/qs_vcd_utils.F | 12 +++---- src/qs_wf_history_methods.F | 4 +-- src/rpa_grad.F | 2 +- src/rpa_gw.F | 2 +- src/rpa_main.F | 2 +- src/s_square_methods.F | 4 +-- src/xas_tdp_utils.F | 24 ++++++------- 27 files changed, 157 insertions(+), 95 deletions(-) diff --git a/src/bse_util.F b/src/bse_util.F index bdc861e6a5..eff3dc9f32 100644 --- a/src/bse_util.F +++ b/src/bse_util.F @@ -1280,9 +1280,9 @@ CONTAINS CALL cp_fm_struct_create(fm_struct_ij, para_env, context, dimen_RI, homo_red*homo_red) CALL cp_fm_struct_create(fm_struct_ab, para_env, context, dimen_RI, virt_red*virt_red) - CALL cp_fm_create(fm_mat_S_trunc, fm_struct_ia, "fm_S_trunc") - CALL cp_fm_create(fm_mat_S_ij_trunc, fm_struct_ij, "fm_S_ij_trunc") - CALL cp_fm_create(fm_mat_S_ab_trunc, fm_struct_ab, "fm_S_ab_trunc") + CALL cp_fm_create(fm_mat_S_trunc, fm_struct_ia, name="fm_S_trunc", set_zero=.TRUE.) + CALL cp_fm_create(fm_mat_S_ij_trunc, fm_struct_ij, name="fm_S_ij_trunc", set_zero=.TRUE.) + CALL cp_fm_create(fm_mat_S_ab_trunc, fm_struct_ab, name="fm_S_ab_trunc", set_zero=.TRUE.) !Copy parts of original matrices to truncated ones IF (mp2_env%bse%bse_cutoff_occ > 0 .OR. mp2_env%bse%bse_cutoff_empty > 0) THEN diff --git a/src/fm/cp_cfm_types.F b/src/fm/cp_cfm_types.F index 193f05eb6e..3d7903b81b 100644 --- a/src/fm/cp_cfm_types.F +++ b/src/fm/cp_cfm_types.F @@ -114,13 +114,15 @@ CONTAINS !> \param matrix matrix to be created !> \param matrix_struct structure of the matrix !> \param name name of the matrix +!> \param set_zero ... !> \note !> preferred allocation routine ! ************************************************************************************************** - SUBROUTINE cp_cfm_create(matrix, matrix_struct, name) + SUBROUTINE cp_cfm_create(matrix, matrix_struct, name, set_zero) TYPE(cp_cfm_type), INTENT(OUT) :: matrix TYPE(cp_fm_struct_type), INTENT(IN), TARGET :: matrix_struct CHARACTER(len=*), INTENT(in), OPTIONAL :: name + LOGICAL, INTENT(in), OPTIONAL :: set_zero INTEGER :: ncol_local, npcol, nprow, nrow_local TYPE(cp_blacs_env_type), POINTER :: context @@ -137,8 +139,11 @@ CONTAINS ncol_local = MAX(1, matrix_struct%ncol_locals(context%mepos(2))) ALLOCATE (matrix%local_data(nrow_local, ncol_local)) - ! do not initialise created matrix as it is up to the user to do so - !CALL zcopy(nrow_local*ncol_local, z_zero, 0, matrix%local_data, 1) + IF (PRESENT(set_zero)) THEN + IF (set_zero) THEN + matrix%local_data(1:nrow_local, 1:ncol_local) = z_zero + END IF + END IF IF (PRESENT(name)) THEN matrix%name = name diff --git a/src/fm/cp_fm_pool_types.F b/src/fm/cp_fm_pool_types.F index 531e165a95..79abb2b38e 100644 --- a/src/fm/cp_fm_pool_types.F +++ b/src/fm/cp_fm_pool_types.F @@ -197,7 +197,7 @@ CONTAINS element = el DEALLOCATE (el) ELSE - CALL cp_fm_create(element, matrix_struct=pool%el_struct) + CALL cp_fm_create(element, matrix_struct=pool%el_struct, set_zero=.TRUE.) END IF IF (PRESENT(name)) THEN diff --git a/src/fm/cp_fm_types.F b/src/fm/cp_fm_types.F index 67865cdd9c..b054815b3a 100644 --- a/src/fm/cp_fm_types.F +++ b/src/fm/cp_fm_types.F @@ -55,6 +55,7 @@ MODULE cp_fm_types cp_fm_get_element, & cp_fm_get_diag, & ! get diagonal cp_fm_set_all, & ! set all elements and diagonal + cp_fm_set_all_submatrix, & ! set a submatrix to a given value cp_fm_set_submatrix, & ! set a submatrix to given values cp_fm_get_submatrix, & ! get a submatrix of given values cp_fm_init_random, & @@ -154,17 +155,18 @@ CONTAINS !> \param matrix_struct the structure of matrix !> \param name ... !> \param use_sp ... +!> \param set_zero ... !> \par History !> 08.2002 created [fawzi] !> \author Fawzi Mohamed !> \note !> preferred allocation routine ! ************************************************************************************************** - SUBROUTINE cp_fm_create(matrix, matrix_struct, name, use_sp) + SUBROUTINE cp_fm_create(matrix, matrix_struct, name, use_sp, set_zero) TYPE(cp_fm_type), INTENT(OUT) :: matrix TYPE(cp_fm_struct_type), INTENT(IN), TARGET :: matrix_struct CHARACTER(LEN=*), INTENT(in), OPTIONAL :: name - LOGICAL, INTENT(in), OPTIONAL :: use_sp + LOGICAL, INTENT(in), OPTIONAL :: use_sp, set_zero CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_fm_create' @@ -197,11 +199,14 @@ CONTAINS ALLOCATE (matrix%local_data(nrow_local, ncol_local)) END IF - ! JVDV we should remove this, as it is up to the user to zero afterwards - IF (matrix%use_sp) THEN - matrix%local_data_sp(1:nrow_local, 1:ncol_local) = 0.0_sp - ELSE - matrix%local_data(1:nrow_local, 1:ncol_local) = 0.0_dp + IF (PRESENT(set_zero)) THEN + IF (set_zero) THEN + IF (matrix%use_sp) THEN + matrix%local_data_sp(1:nrow_local, 1:ncol_local) = 0.0_sp + ELSE + matrix%local_data(1:nrow_local, 1:ncol_local) = 0.0_dp + END IF + END IF END IF IF (PRESENT(name)) THEN @@ -864,6 +869,56 @@ CONTAINS END SUBROUTINE cp_fm_set_submatrix +! ************************************************************************************************** +!> \brief sets a submatrix of a full matrix to a given value +!> fm(start_row:start_row+n_rows,start_col:start_col+n_cols) = value +!> \param fm the full to change +!> \param new_value ... +!> \param start_row the starting row of matrix +!> \param start_col the starting col of matrix +!> \param n_rows the number of rows to change +!> \param n_cols the number of columns to change +!> \par History +!> 07.2002 created borrowing from Joost's blacs_replicated_copy [fawzi] +!> 12.2025 created from cp_fm_set_submatrix +!> \author JGH +! ************************************************************************************************** + SUBROUTINE cp_fm_set_all_submatrix(fm, new_value, start_row, start_col, n_rows, n_cols) + TYPE(cp_fm_type), INTENT(IN) :: fm + REAL(KIND=dp), INTENT(in) :: new_value + INTEGER, INTENT(in) :: start_row, start_col, n_rows, n_cols + + INTEGER :: i, i0, j, j0, ncol_global, ncol_local, & + nrow_global, nrow_local, this_col, & + this_row + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + REAL(KIND=dp), DIMENSION(:, :), POINTER :: full_block + + CPASSERT(.NOT. fm%use_sp) + + full_block => fm%local_data + + CALL cp_fm_get_info(matrix=fm, & + nrow_global=nrow_global, ncol_global=ncol_global, & + nrow_local=nrow_local, ncol_local=ncol_local, & + row_indices=row_indices, col_indices=col_indices) + + i0 = start_row + j0 = start_col + DO j = 1, ncol_local + this_col = col_indices(j) - j0 + 1 + IF (this_col >= 1 .AND. this_col <= n_cols) THEN + DO i = 1, nrow_local + this_row = row_indices(i) - i0 + 1 + IF (this_row >= 1 .AND. this_row <= n_rows) THEN + full_block(i, j) = new_value + END IF + END DO + END IF + END DO + + END SUBROUTINE cp_fm_set_all_submatrix + ! ************************************************************************************************** !> \brief gets a submatrix of a full matrix !> op(target_m)(1:n_rows,1:n_cols) diff --git a/src/gw_large_cell_gamma.F b/src/gw_large_cell_gamma.F index 24c6779bdc..0c656e5d0d 100644 --- a/src/gw_large_cell_gamma.F +++ b/src/gw_large_cell_gamma.F @@ -1514,7 +1514,7 @@ CONTAINS ALLOCATE (fm_W_MIC_time(bs_env%num_time_freq_points)) DO i_t = 1, bs_env%num_time_freq_points - CALL cp_fm_create(fm_W_MIC_time(i_t), bs_env%fm_RI_RI%matrix_struct) + CALL cp_fm_create(fm_W_MIC_time(i_t), bs_env%fm_RI_RI%matrix_struct, set_zero=.TRUE.) END DO CALL timestop(handle) diff --git a/src/gw_utils.F b/src/gw_utils.F index 8b773c3a28..55cae6079d 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -1721,7 +1721,8 @@ CONTAINS DO img = 1, dft_control%nimages ! safe fm_V_xc_R in fm_matrix because saving in dbcsr matrix caused trouble... CALL copy_dbcsr_to_fm(matrix_ks_kp(ispin, img)%matrix, bs_env%fm_work_mo(1)) - CALL cp_fm_create(bs_env%fm_V_xc_R(img, ispin), bs_env%fm_work_mo(1)%matrix_struct) + CALL cp_fm_create(bs_env%fm_V_xc_R(img, ispin), bs_env%fm_work_mo(1)%matrix_struct, & + set_zero=.TRUE.) ! store h_ks(v_xc = 0) in fm_V_xc_R CALL cp_fm_scale_and_add(alpha=1.0_dp, matrix_a=bs_env%fm_V_xc_R(img, ispin), & beta=1.0_dp, matrix_b=bs_env%fm_work_mo(1)) diff --git a/src/mp2_ri_grad.F b/src/mp2_ri_grad.F index 06f752f251..703d2dd9da 100644 --- a/src/mp2_ri_grad.F +++ b/src/mp2_ri_grad.F @@ -1336,7 +1336,7 @@ CONTAINS CALL cp_fm_struct_create(fm_struct_tmp, para_env=para_env, context=blacs_env, & nrow_global=homo, ncol_global=virtual) - CALL cp_fm_create(mp2_env%ri_grad%L_jb(kspin), fm_struct_tmp, name="fm_L_jb") + CALL cp_fm_create(mp2_env%ri_grad%L_jb(kspin), fm_struct_tmp, name="fm_L_jb", set_zero=.TRUE.) CALL cp_fm_struct_release(fm_struct_tmp) ! first Virtual diff --git a/src/parallel_gemm_api.F b/src/parallel_gemm_api.F index 98becb4ac8..edaa63cb3d 100644 --- a/src/parallel_gemm_api.F +++ b/src/parallel_gemm_api.F @@ -21,6 +21,7 @@ MODULE parallel_gemm_api USE cp_cfm_types, ONLY: cp_cfm_type USE cp_fm_basic_linalg, ONLY: cp_fm_gemm USE cp_fm_types, ONLY: cp_fm_get_mm_type,& + cp_fm_set_all_submatrix,& cp_fm_type USE input_constants, ONLY: do_cosma,& do_scalapack @@ -75,7 +76,10 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'parallel_gemm_fm' - INTEGER :: handle, my_multi + INTEGER :: cfc, cfr, handle, my_multi + + MARK_USED(cfc) + MARK_USED(cfr) my_multi = cp_fm_get_mm_type() @@ -92,6 +96,16 @@ CONTAINS CASE (do_cosma) #if defined(__COSMA) CALL timeset(routineN//"_cosma", handle) + !> This seems not to be correct in COSMA! See BLAS definition: + !> On entry, BETA specifies the scalar beta. When BETA is + !> supplied as zero then C need not be set on input. + IF (beta == 0.0_dp) THEN + cfr = 1 + cfc = 1 + IF (PRESENT(c_first_row)) cfr = c_first_row + IF (PRESENT(c_first_col)) cfc = c_first_col + CALL cp_fm_set_all_submatrix(matrix_c, 0.0_dp, cfr, cfc, m, n) + END IF CALL offload_activate_chosen_device() CALL cosma_pdgemm(transa=transa, transb=transb, m=m, n=n, k=k, alpha=alpha, & matrix_a=matrix_a, matrix_b=matrix_b, beta=beta, matrix_c=matrix_c, & diff --git a/src/qs_dcdr.F b/src/qs_dcdr.F index a987dbdab2..925dfc422c 100644 --- a/src/qs_dcdr.F +++ b/src/qs_dcdr.F @@ -311,13 +311,13 @@ CONTAINS psi0_order(ispin) = mo_coeff END DO + DO ispin = 1, dcdr_env%nspins + CALL cp_fm_set_all(psi1(ispin), 0.0_dp) + CALL cp_fm_set_all(h1_psi0(ispin), 0.0_dp) + END DO ! Restart IF (linres_control%linres_restart) THEN CALL dcdr_read_restart(qs_env, lr_section, psi1, dcdr_env%lambda, dcdr_env%beta, "dCdR") - ELSE - DO ispin = 1, dcdr_env%nspins - CALL cp_fm_set_all(psi1(ispin), 0.0_dp) - END DO END IF IF (output_unit > 0) THEN diff --git a/src/qs_dcdr_utils.F b/src/qs_dcdr_utils.F index 7a84ba1a7f..03e98acfb9 100644 --- a/src/qs_dcdr_utils.F +++ b/src/qs_dcdr_utils.F @@ -228,6 +228,7 @@ CONTAINS CALL cp_fm_get_info(mo_coeff, nrow_global=nao, ncol_block=max_block) ALLOCATE (vecbuffer(nao, max_block)) + vecbuffer = 0.0_dp ! ! read headers IF (rst_unit > 0) READ (rst_unit, IOSTAT=iostat) lambda_tmp, beta_tmp, nspins_tmp, nao_tmp @@ -847,11 +848,11 @@ CONTAINS ALLOCATE (dcdr_env%op_dR(nspins)) DO ispin = 1, nspins - CALL cp_fm_create(dcdr_env%dCR(ispin), dcdr_env%likemos_fm_struct(ispin)%struct) - CALL cp_fm_create(dcdr_env%dCR_prime(ispin), dcdr_env%likemos_fm_struct(ispin)%struct) - CALL cp_fm_create(dcdr_env%mo_coeff(ispin), dcdr_env%likemos_fm_struct(ispin)%struct) - CALL cp_fm_create(dcdr_env%chc(ispin), dcdr_env%momo_fm_struct(ispin)%struct) - CALL cp_fm_create(dcdr_env%op_dR(ispin), dcdr_env%likemos_fm_struct(ispin)%struct) + CALL cp_fm_create(dcdr_env%dCR(ispin), dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) + CALL cp_fm_create(dcdr_env%dCR_prime(ispin), dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) + CALL cp_fm_create(dcdr_env%mo_coeff(ispin), dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) + CALL cp_fm_create(dcdr_env%chc(ispin), dcdr_env%momo_fm_struct(ispin)%struct, set_zero=.TRUE.) + CALL cp_fm_create(dcdr_env%op_dR(ispin), dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) CALL get_mo_set(mo_set=mos(ispin), mo_coeff=mo_coeff) CALL cp_fm_to_fm(mo_coeff, dcdr_env%mo_coeff(ispin)) diff --git a/src/qs_density_matrices.F b/src/qs_density_matrices.F index 776afe27e7..8956278ac5 100644 --- a/src/qs_density_matrices.F +++ b/src/qs_density_matrices.F @@ -233,7 +233,7 @@ CONTAINS CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol_global, ncol_global=ncol_global, & para_env=mo_set%mo_coeff%matrix_struct%para_env, & context=mo_set%mo_coeff%matrix_struct%context) - CALL cp_fm_create(h_block, fm_struct_tmp, name="h block") + CALL cp_fm_create(h_block, fm_struct_tmp, name="h block", set_zero=.TRUE.) IF (do_symm) CALL cp_fm_create(h_block_t, fm_struct_tmp, name="h block t") CALL cp_fm_struct_release(fm_struct_tmp) @@ -371,24 +371,9 @@ CONTAINS CALL timeset(routineN, handle) -! CALL cp_fm_get_info(matrix=mo_set%mo_coeff, ncol_global=ncol, nrow_global=nrow) -! CALL cp_fm_create(scrv, mo_set%mo_coeff%matrix_struct, "scr vectors") -! CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & -! para_env=mo_set%mo_coeff%matrix_struct%para_env, & -! context=mo_set%mo_coeff%matrix_struct%context) -! CALL cp_fm_create(ksmat, fm_struct_tmp, name="KS") -! CALL cp_fm_struct_release(fm_struct_tmp) -! CALL cp_dbcsr_sm_fm_multiply(ks_matrix, mo_set%mo_coeff, scrv, ncol) -! CALL parallel_gemm("T", "N", ncol, ncol, nrow, 1.0_dp, mo_set%mo_coeff, scrv, 0.0_dp, ksmat) -! CALL parallel_gemm("N", "N", nrow, ncol, ncol, 1.0_dp, mo_set%mo_coeff, ksmat, 0.0_dp, scrv) -! CALL dbcsr_set(w_matrix, 0.0_dp) -! CALL cp_dbcsr_plus_fm_fm_t(w_matrix, matrix_v=scrv, matrix_g=psi1, & -! ncol=mo_set%homo, symmetry_mode=1) -! CALL cp_fm_release(scrv) -! CALL cp_fm_release(ksmat) CALL cp_fm_get_info(matrix=mo_set%mo_coeff, ncol_global=ncol, nrow_global=nrow) nocc = mo_set%homo - CALL cp_fm_create(scrv, mo_set%mo_coeff%matrix_struct, "scr vectors") + CALL cp_fm_create(scrv, mo_set%mo_coeff%matrix_struct, "scr vectors", set_zero=.TRUE.) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=nocc, ncol_global=nocc, & para_env=mo_set%mo_coeff%matrix_struct%para_env, & context=mo_set%mo_coeff%matrix_struct%context) @@ -436,7 +421,7 @@ CONTAINS falpha = focc - CALL cp_fm_create(hcvec, c0vec%matrix_struct, "hcvec") + CALL cp_fm_create(hcvec, c0vec%matrix_struct, name="hcvec", set_zero=.TRUE.) CALL cp_fm_get_info(hcvec, matrix_struct=fm_struct, nrow_global=nao, ncol_global=norb) CPASSERT(nocc <= norb .AND. nocc > 0) norb = nocc @@ -482,7 +467,7 @@ CONTAINS CALL timeset(routineN, handle) CALL cp_fm_get_info(matrix=mos_active, ncol_global=ncol, nrow_global=nrow) - CALL cp_fm_create(scrv, mos_active%matrix_struct, "scr vectors") + CALL cp_fm_create(scrv, mos_active%matrix_struct, name="scr vectors", set_zero=.TRUE.) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & para_env=mos_active%matrix_struct%para_env, & context=mos_active%matrix_struct%context) @@ -526,7 +511,7 @@ CONTAINS CALL timeset(routineN, handle) CALL cp_fm_get_info(matrix=mos_active, ncol_global=ncol, nrow_global=nrow) - CALL cp_fm_create(scrv, mos_active%matrix_struct, "scr vectors") + CALL cp_fm_create(scrv, mos_active%matrix_struct, name="scr vectors", set_zero=.TRUE.) CALL cp_fm_struct_create(fm_struct_tmp, nrow_global=ncol, ncol_global=ncol, & para_env=mos_active%matrix_struct%para_env, & context=mos_active%matrix_struct%context) diff --git a/src/qs_linres_current.F b/src/qs_linres_current.F index ab120a12b2..36a0ff7399 100644 --- a/src/qs_linres_current.F +++ b/src/qs_linres_current.F @@ -2418,13 +2418,13 @@ CONTAINS ncol_global=max_states, para_env=para_env, & context=mo_coeff%matrix_struct%context) DO idir = 1, 3 - CALL cp_fm_create(p_rxp(idir), tmp_fm_struct) - CALL cp_fm_create(r_p1(idir), tmp_fm_struct) - CALL cp_fm_create(r_p2(idir), tmp_fm_struct) + CALL cp_fm_create(p_rxp(idir), tmp_fm_struct, set_zero=.TRUE.) + CALL cp_fm_create(r_p1(idir), tmp_fm_struct, set_zero=.TRUE.) + CALL cp_fm_create(r_p2(idir), tmp_fm_struct, set_zero=.TRUE.) DO idir2 = 1, 9 - CALL cp_fm_create(rr_rxp(idir2, idir), tmp_fm_struct) - CALL cp_fm_create(rr_p1(idir2, idir), tmp_fm_struct) - CALL cp_fm_create(rr_p2(idir2, idir), tmp_fm_struct) + CALL cp_fm_create(rr_rxp(idir2, idir), tmp_fm_struct, set_zero=.TRUE.) + CALL cp_fm_create(rr_p1(idir2, idir), tmp_fm_struct, set_zero=.TRUE.) + CALL cp_fm_create(rr_p2(idir2, idir), tmp_fm_struct, set_zero=.TRUE.) END DO END DO CALL cp_fm_struct_release(tmp_fm_struct) diff --git a/src/qs_linres_methods.F b/src/qs_linres_methods.F index 38258861b8..9926192aa1 100644 --- a/src/qs_linres_methods.F +++ b/src/qs_linres_methods.F @@ -297,7 +297,7 @@ CONTAINS CALL cp_fm_struct_create(tmp_fm_struct, nrow_global=nmo, & ncol_global=nmo, para_env=para_env, & context=mo_coeff%matrix_struct%context) - CALL cp_fm_create(chc(ispin), tmp_fm_struct) + CALL cp_fm_create(chc(ispin), tmp_fm_struct, set_zero=.TRUE.) CALL cp_fm_struct_release(tmp_fm_struct) END DO ! diff --git a/src/qs_linres_polar_utils.F b/src/qs_linres_polar_utils.F index 1d59d7b005..de4b251aa9 100644 --- a/src/qs_linres_polar_utils.F +++ b/src/qs_linres_polar_utils.F @@ -447,17 +447,16 @@ CONTAINS CALL get_polar_env(polar_env=polar_env, & psi1_dBerry=psi1_dBerry, & dBerry_psi0=dBerry_psi0) + DO idir = 1, 3 + DO ispin = 1, nspins + CALL cp_fm_set_all(psi1_dBerry(idir, ispin), 0.0_dp) + END DO + END DO ! Restart IF (linres_control%linres_restart) THEN DO idir = 1, 3 CALL linres_read_restart(qs_env, lr_section, psi1_dBerry(idir, :), idir, "psi1_dBerry") END DO - ELSE - DO idir = 1, 3 - DO ispin = 1, nspins - CALL cp_fm_set_all(psi1_dBerry(idir, ispin), 0.0_dp) - END DO - END DO END IF loop_idir: DO idir = 1, 3 IF (iounit > 0) THEN diff --git a/src/qs_mfp.F b/src/qs_mfp.F index 0e8a47487b..f4be58509b 100644 --- a/src/qs_mfp.F +++ b/src/qs_mfp.F @@ -1188,7 +1188,7 @@ CONTAINS ! allocate the vectors ASSOCIATE (psi0_order => vcd_env%dcdr_env%mo_coeff) - CALL cp_fm_create(psi1(1), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) + CALL cp_fm_create(psi1(1), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) CALL cp_fm_create(h1_psi0(1), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) ! Restart diff --git a/src/qs_mo_methods.F b/src/qs_mo_methods.F index e3fba3aec6..0b1c94ff76 100644 --- a/src/qs_mo_methods.F +++ b/src/qs_mo_methods.F @@ -103,7 +103,7 @@ CONTAINS CALL cp_fm_get_info(matrix=vmatrix, nrow_global=n, ncol_global=ncol_global) IF (ncol > ncol_global) CPABORT("Wrong ncol value") - CALL cp_fm_create(svmatrix, vmatrix%matrix_struct, "SV") + CALL cp_fm_create(svmatrix, vmatrix%matrix_struct, "SV", set_zero=.TRUE.) CALL cp_dbcsr_sm_fm_multiply(matrix_s, vmatrix, svmatrix, ncol) NULLIFY (fm_struct_tmp) diff --git a/src/qs_mo_types.F b/src/qs_mo_types.F index e4c97b6d5c..8848791b55 100644 --- a/src/qs_mo_types.F +++ b/src/qs_mo_types.F @@ -32,6 +32,7 @@ MODULE qs_mo_types USE cp_fm_types, ONLY: cp_fm_create,& cp_fm_get_info,& cp_fm_release,& + cp_fm_set_all,& cp_fm_to_fm,& cp_fm_type USE kinds, ONLY: dp @@ -268,6 +269,7 @@ CONTAINS CPASSERT(ASSOCIATED(fm_struct)) CALL cp_fm_create(mo_set%mo_coeff, fm_struct, name=name) END IF + CALL cp_fm_set_all(mo_set%mo_coeff, 0.0_dp) CALL cp_fm_get_info(mo_set%mo_coeff, nrow_global=nao, ncol_global=nmo) CPASSERT(nao >= mo_set%nao) diff --git a/src/qs_tddfpt2_eigensolver.F b/src/qs_tddfpt2_eigensolver.F index 5dd1c4ccdf..d79cc93e1d 100644 --- a/src/qs_tddfpt2_eigensolver.F +++ b/src/qs_tddfpt2_eigensolver.F @@ -611,8 +611,8 @@ CONTAINS CALL cp_fm_get_info(krylov_vects(1, 1), context=blacs_env_global) CALL cp_fm_struct_create(fm_struct, nrow_global=nkvs, ncol_global=nkvs, context=blacs_env_global) - CALL cp_fm_create(Atilde_fm, fm_struct) - CALL cp_fm_create(evects_Atilde_fm, fm_struct) + CALL cp_fm_create(Atilde_fm, fm_struct, set_zero=.TRUE.) + CALL cp_fm_create(evects_Atilde_fm, fm_struct, set_zero=.TRUE.) CALL cp_fm_struct_release(fm_struct) ! *** compute upper-diagonal reduced action matrix *** diff --git a/src/qs_tddfpt2_soc.F b/src/qs_tddfpt2_soc.F index 862abcbf98..40dbedac70 100644 --- a/src/qs_tddfpt2_soc.F +++ b/src/qs_tddfpt2_soc.F @@ -1459,9 +1459,9 @@ CONTAINS nrow_global=ntot, ncol_global=1) CALL cp_cfm_get_info(soc_evecs_cfm, matrix_struct=full_struct) - CALL cp_cfm_create(dip_cfm, dip_struct) - CALL cp_cfm_create(work1_cfm, full_struct) - CALL cp_cfm_create(work2_cfm, full_struct) + CALL cp_cfm_create(dip_cfm, dip_struct, set_zero=.TRUE.) + CALL cp_cfm_create(work1_cfm, full_struct, set_zero=.TRUE.) + CALL cp_cfm_create(work2_cfm, full_struct, set_zero=.TRUE.) ALLOCATE (transdip(ntot, 1)) @@ -1601,7 +1601,7 @@ CONTAINS nrow_global=ntot, ncol_global=ntot) ALLOCATE (amew_op(dim_op)) DO i = 1, dim_op - CALL cp_fm_create(amew_op(i), full_struct) + CALL cp_fm_create(amew_op(i), full_struct, set_zero=.TRUE.) END DO !i ! Deal with the GS-GS contribution <0|0> = 2*sum_j diff --git a/src/qs_vcd.F b/src/qs_vcd.F index 705563a791..6259e70a45 100644 --- a/src/qs_vcd.F +++ b/src/qs_vcd.F @@ -625,7 +625,7 @@ CONTAINS deltaR => vcd_env%dcdr_env%deltaR) ! build the full matrices - CALL cp_fm_create(buf, vcd_env%dcdr_env%likemos_fm_struct(ispin)%struct) + CALL cp_fm_create(buf, vcd_env%dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) CALL cp_fm_create(matrix_dSdV_mo, vcd_env%dcdr_env%momo_fm_struct(ispin)%struct) ! STEP 1: dCV contribution (dipvel + commutator) @@ -1073,7 +1073,7 @@ CONTAINS END IF ASSOCIATE (psi0_order => vcd_env%dcdr_env%mo_coeff) - CALL cp_fm_create(psi1(ispin), vcd_env%dcdr_env%likemos_fm_struct(ispin)%struct) + CALL cp_fm_create(psi1(ispin), vcd_env%dcdr_env%likemos_fm_struct(ispin)%struct, set_zero=.TRUE.) CALL cp_fm_create(h1_psi0(ispin), vcd_env%dcdr_env%likemos_fm_struct(ispin)%struct) ! Restart diff --git a/src/qs_vcd_utils.F b/src/qs_vcd_utils.F index 398aaf4d5e..04ebc769f1 100644 --- a/src/qs_vcd_utils.F +++ b/src/qs_vcd_utils.F @@ -220,17 +220,17 @@ CONTAINS ALLOCATE (vcd_env%op_dV(nspins)) ALLOCATE (vcd_env%op_dB(nspins)) DO ispin = 1, nspins - CALL cp_fm_create(vcd_env%dCV(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) - CALL cp_fm_create(vcd_env%dCV_prime(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) - CALL cp_fm_create(vcd_env%op_dV(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) - CALL cp_fm_create(vcd_env%op_dB(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) + CALL cp_fm_create(vcd_env%dCV(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) + CALL cp_fm_create(vcd_env%dCV_prime(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) + CALL cp_fm_create(vcd_env%op_dV(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) + CALL cp_fm_create(vcd_env%op_dB(ispin), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) END DO ALLOCATE (vcd_env%dCB(3)) ALLOCATE (vcd_env%dCB_prime(3)) DO i = 1, 3 - CALL cp_fm_create(vcd_env%dCB(i), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) - CALL cp_fm_create(vcd_env%dCB_prime(i), vcd_env%dcdr_env%likemos_fm_struct(1)%struct) + CALL cp_fm_create(vcd_env%dCB(i), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) + CALL cp_fm_create(vcd_env%dCB_prime(i), vcd_env%dcdr_env%likemos_fm_struct(1)%struct, set_zero=.TRUE.) END DO ! DBCSR matrices diff --git a/src/qs_wf_history_methods.F b/src/qs_wf_history_methods.F index d66ed23683..fe11c07f14 100644 --- a/src/qs_wf_history_methods.F +++ b/src/qs_wf_history_methods.F @@ -866,12 +866,12 @@ CONTAINS nrow_global=n, & ncol_global=k, & matrix_struct=matrix_struct) - CALL cp_fm_create(fm_tmp, matrix_struct) + CALL cp_fm_create(fm_tmp, matrix_struct, set_zero=.TRUE.) CALL cp_fm_struct_create(matrix_struct_new, & template_fmstruct=matrix_struct, & nrow_global=k, & ncol_global=k) - CALL cp_fm_create(csc, matrix_struct_new) + CALL cp_fm_create(csc, matrix_struct_new, set_zero=.TRUE.) CALL cp_fm_struct_release(matrix_struct_new) ! first the most recent t1_state => wfi_get_snapshot(wf_history, & diff --git a/src/rpa_grad.F b/src/rpa_grad.F index a1eafb914e..0ed1a0fbb0 100644 --- a/src/rpa_grad.F +++ b/src/rpa_grad.F @@ -187,7 +187,7 @@ CONTAINS ALLOCATE (rpa_grad%fm_Y(nspins)) DO ispin = 1, nspins - CALL cp_fm_create(rpa_grad%fm_Y(ispin), fm_mat_S(ispin)%matrix_struct) + CALL cp_fm_create(rpa_grad%fm_Y(ispin), fm_mat_S(ispin)%matrix_struct, set_zero=.TRUE.) END DO IF (do_ri_sos_laplace_mp2) THEN diff --git a/src/rpa_gw.F b/src/rpa_gw.F index 7ee2508170..b0b955cbd1 100644 --- a/src/rpa_gw.F +++ b/src/rpa_gw.F @@ -279,7 +279,7 @@ CONTAINS DO jquad = 1, num_integ_points - CALL cp_fm_create(fm_mat_W(jquad), fm_mat_Q%matrix_struct) + CALL cp_fm_create(fm_mat_W(jquad), fm_mat_Q%matrix_struct, set_zero=.TRUE.) CALL cp_fm_to_fm(fm_mat_Q, fm_mat_W(jquad)) CALL cp_fm_set_all(fm_mat_W(jquad), 0.0_dp) diff --git a/src/rpa_main.F b/src/rpa_main.F index ed9b8620e1..c508885932 100644 --- a/src/rpa_main.F +++ b/src/rpa_main.F @@ -969,7 +969,7 @@ CONTAINS CALL cp_fm_struct_create(fm_struct, context=blacs_env_Q, nrow_global=dimen_RI, & ncol_global=dimen_RI, para_env=para_env_RPA) DO ispin = 1, SIZE(fm_mat_Q) - CALL cp_fm_create(fm_mat_Q(ispin), fm_struct, name="fm_mat_Q") + CALL cp_fm_create(fm_mat_Q(ispin), fm_struct, name="fm_mat_Q", set_zero=.TRUE.) END DO CALL cp_fm_struct_release(fm_struct) diff --git a/src/s_square_methods.F b/src/s_square_methods.F index effebf8a07..2f95e3957a 100644 --- a/src/s_square_methods.F +++ b/src/s_square_methods.F @@ -121,7 +121,7 @@ CONTAINS CALL cp_fm_struct_release(fm_struct_tmp) ! Create S*C(beta) CALL cp_fm_get_info(c_beta, matrix_struct=fm_struct_tmp) - CALL cp_fm_create(scb, fm_struct_tmp, name="S*C(beta)") + CALL cp_fm_create(scb, fm_struct_tmp, name="S*C(beta)", set_zero=.TRUE.) ! Compute S*C(beta) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, c_beta, scb, nbeta) ! Compute C(alpha)^T*S*C(beta) @@ -148,7 +148,7 @@ CONTAINS CALL parallel_gemm('N', 'T', nao, nalpha, nbeta, -strength, scb, catscb, 1.0_dp, mo_derivs(1)) ! Create S*C(alpha) CALL cp_fm_get_info(c_alpha, matrix_struct=fm_struct_tmp) - CALL cp_fm_create(sca, fm_struct_tmp, name="S*C(alpha)") + CALL cp_fm_create(sca, fm_struct_tmp, name="S*C(alpha)", set_zero=.TRUE.) ! Compute S*C(alpha) CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, c_alpha, sca, nalpha) ! Add -strength*S*C(alpha)*C(alpha)^T*S*C(beta) to the beta MO derivatives diff --git a/src/xas_tdp_utils.F b/src/xas_tdp_utils.F index db4735bde2..d498eba5b2 100644 --- a/src/xas_tdp_utils.F +++ b/src/xas_tdp_utils.F @@ -1589,8 +1589,8 @@ CONTAINS ! Creating the real and the imaginary part of the SOC perturbation matrix CALL cp_fm_struct_create(full_struct, context=blacs_env, para_env=para_env, & nrow_global=ntot, ncol_global=ntot) - CALL cp_fm_create(real_fm, full_struct) - CALL cp_fm_create(img_fm, full_struct) + CALL cp_fm_create(real_fm, full_struct, set_zero=.TRUE.) + CALL cp_fm_create(img_fm, full_struct, set_zero=.TRUE.) ! Put the excitation energies on the diagonal of the real matrix. Element 1,1 is the ground state DO isc = 1, nsc @@ -1722,7 +1722,7 @@ CONTAINS ! some more useful work matrices CALL cp_fm_struct_create(work_struct, context=blacs_env, para_env=para_env, & nrow_global=nex, ncol_global=nex) - CALL cp_fm_create(work_fm, work_struct) + CALL cp_fm_create(work_fm, work_struct, set_zero=.TRUE.) ! Looping over the excited states, computing the SOC and filling the perturbation matrix ! There are 3 loops to do: sc-sc, sc-sf and sf-sf @@ -2007,8 +2007,8 @@ CONTAINS CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) CALL cp_fm_struct_create(full_struct, context=blacs_env, para_env=para_env, & nrow_global=ntot, ncol_global=ntot) - CALL cp_fm_create(real_fm, full_struct) - CALL cp_fm_create(img_fm, full_struct) + CALL cp_fm_create(real_fm, full_struct, set_zero=.TRUE.) + CALL cp_fm_create(img_fm, full_struct, set_zero=.TRUE.) ! Put the excitation energies on the diagonal of the real matrix DO isg = 1, nsg @@ -2406,7 +2406,7 @@ CONTAINS nrow_global=ntot, ncol_global=ntot) ALLOCATE (amew_op(dim_op)) DO i = 1, dim_op - CALL cp_fm_create(amew_op(i), full_struct) + CALL cp_fm_create(amew_op(i), full_struct, set_zero=.TRUE.) END DO ! Before looping, need to evaluate sum_j,sigma , for each dimension @@ -2419,8 +2419,8 @@ CONTAINS CALL cp_fm_get_info(mo_coeff, matrix_struct=vec_struct) CALL cp_fm_struct_create(prod_struct, context=blacs_env, para_env=para_env, & nrow_global=homo, ncol_global=homo) - CALL cp_fm_create(vec_work, vec_struct) - CALL cp_fm_create(prod_work, prod_struct) + CALL cp_fm_create(vec_work, vec_struct, set_zero=.TRUE.) + CALL cp_fm_create(prod_work, prod_struct, set_zero=.TRUE.) DO i = 1, dim_op @@ -2637,7 +2637,7 @@ CONTAINS nrow_global=ntot, ncol_global=ntot) ALLOCATE (amew_op(dim_op)) DO i = 1, dim_op - CALL cp_fm_create(amew_op(i), full_struct) + CALL cp_fm_create(amew_op(i), full_struct, set_zero=.TRUE.) END DO !i ! Deal with the GS-GS contribution <0|0> = 2*sum_j @@ -2994,9 +2994,9 @@ CONTAINS CALL cp_fm_struct_create(dip_struct, context=blacs_env, para_env=para_env, & nrow_global=ntot, ncol_global=1) CALL cp_cfm_get_info(soc_evecs_cfm, matrix_struct=full_struct) - CALL cp_cfm_create(dip_cfm, dip_struct) - CALL cp_cfm_create(work1_cfm, full_struct) - CALL cp_cfm_create(work2_cfm, full_struct) + CALL cp_cfm_create(dip_cfm, dip_struct, set_zero=.TRUE.) + CALL cp_cfm_create(work1_cfm, full_struct, set_zero=.TRUE.) + CALL cp_cfm_create(work2_cfm, full_struct, set_zero=.TRUE.) ALLOCATE (transdip(ntot, 1)) !get the dipole in the AMEW basis