28 USE dbcsr_api,
ONLY: &
29 dbcsr_add, dbcsr_copy, dbcsr_copy_into_existing, dbcsr_create, dbcsr_multiply, &
30 dbcsr_p_type, dbcsr_release, dbcsr_set, dbcsr_transposed, dbcsr_type, &
31 dbcsr_type_no_symmetry, dbcsr_type_symmetric
53 USE mp2_types,
ONLY: integ_mat_buffer_type,&
54 integ_mat_buffer_type_2d,&
74 #include "./base/base_uses.f90"
80 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'mp2_ri_grad'
111 atomic_kind_set, qs_kind_set, mo_coeff, nmo, homo, dimen_RI, Eigenval, &
112 my_group_L_start, my_group_L_end, my_group_L_size, sab_orb_sub, mat_munu, &
114 TYPE(qs_environment_type),
POINTER :: qs_env
115 TYPE(mp2_type) :: mp2_env
116 TYPE(mp_para_env_type),
POINTER :: para_env, para_env_sub
117 TYPE(cell_type),
POINTER :: cell
118 TYPE(particle_type),
DIMENSION(:),
POINTER :: particle_set
119 TYPE(atomic_kind_type),
DIMENSION(:),
POINTER :: atomic_kind_set
120 TYPE(qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
121 TYPE(cp_fm_type),
DIMENSION(:),
INTENT(IN) :: mo_coeff
122 INTEGER,
INTENT(IN) :: nmo
123 INTEGER,
DIMENSION(:),
INTENT(IN) :: homo
124 INTEGER,
INTENT(IN) :: dimen_ri
125 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: eigenval
126 INTEGER,
INTENT(IN) :: my_group_l_start, my_group_l_end, &
128 TYPE(neighbor_list_set_p_type),
DIMENSION(:), &
129 POINTER :: sab_orb_sub
130 TYPE(dbcsr_p_type),
INTENT(INOUT) :: mat_munu
131 TYPE(cp_blacs_env_type),
POINTER :: blacs_env_sub
133 CHARACTER(LEN=*),
PARAMETER :: routinen =
'calc_ri_mp2_nonsep'
135 INTEGER :: dimen, eri_method, handle, handle2, i, &
136 ikind, ispin, itmp(2), l_counter, lll, &
137 my_p_end, my_p_size, my_p_start, nspins
138 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: atom_of_kind, kind_of, natom_of_kind, &
140 LOGICAL :: alpha_beta, use_virial
141 REAL(kind=
dp) :: cutoff_old, eps_filter, factor, &
142 factor_2c, relative_cutoff_old
143 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: e_cutoff_old
144 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: g_pq_local, g_pq_local_2
145 REAL(kind=
dp),
DIMENSION(3, 3) :: h_stress, pv_virial
146 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: i_tmp2
147 TYPE(cp_eri_mme_param),
POINTER :: eri_param
148 TYPE(cp_fm_struct_type),
POINTER :: fm_struct_tmp
149 TYPE(cp_fm_type),
ALLOCATABLE,
DIMENSION(:) :: l1_mu_i, l2_nu_a
150 TYPE(dbcsr_p_type) :: matrix_p_munu
151 TYPE(dbcsr_p_type),
ALLOCATABLE,
DIMENSION(:) :: mo_coeff_o, mo_coeff_v
152 TYPE(dbcsr_p_type),
ALLOCATABLE,
DIMENSION(:, :) :: g_p_ia
153 TYPE(dbcsr_p_type),
DIMENSION(:),
POINTER :: mat_munu_local, matrix_p_munu_local
154 TYPE(dbcsr_type) :: matrix_p_munu_nosym
155 TYPE(dbcsr_type),
ALLOCATABLE,
DIMENSION(:) :: lag_mu_i_1, lag_nu_a_2, matrix_p_inu
156 TYPE(dft_control_type),
POINTER :: dft_control
157 TYPE(mp2_eri_force),
ALLOCATABLE,
DIMENSION(:) :: force_2c, force_2c_ri, force_3c_aux, &
158 force_3c_orb_mu, force_3c_orb_nu
159 TYPE(pw_c1d_gs_type) :: dvg(3), pot_g, rho_g, rho_g_copy
160 TYPE(pw_env_type),
POINTER :: pw_env_sub
161 TYPE(pw_poisson_type),
POINTER :: poisson_env
162 TYPE(pw_pool_type),
POINTER :: auxbas_pw_pool
163 TYPE(pw_r3d_rs_type) :: psi_l, rho_r
164 TYPE(qs_force_type),
DIMENSION(:),
POINTER :: force, mp2_force
165 TYPE(qs_ks_env_type),
POINTER :: ks_env
166 TYPE(task_list_type),
POINTER :: task_list_sub
167 TYPE(virial_type),
POINTER :: virial
169 CALL timeset(routinen, handle)
171 eri_method = mp2_env%eri_method
172 eri_param => mp2_env%eri_mme_param
176 alpha_beta = (nspins == 2)
179 ALLOCATE (virtual(nspins))
180 virtual(:) = dimen - homo(:)
181 eps_filter = mp2_env%mp2_gpw%eps_filter
182 ALLOCATE (mo_coeff_o(nspins), mo_coeff_v(nspins), g_p_ia(nspins, my_group_l_size))
184 mo_coeff_o(ispin)%matrix => mp2_env%ri_grad%mo_coeff_o(ispin)%matrix
185 mo_coeff_v(ispin)%matrix => mp2_env%ri_grad%mo_coeff_v(ispin)%matrix
186 DO lll = 1, my_group_l_size
187 g_p_ia(ispin, lll)%matrix => mp2_env%ri_grad%G_P_ia(lll, ispin)%matrix
190 DEALLOCATE (mp2_env%ri_grad%G_P_ia)
192 itmp =
get_limit(dimen_ri, para_env_sub%num_pe, para_env_sub%mepos)
195 my_p_size = itmp(2) - itmp(1) + 1
197 ALLOCATE (g_pq_local(dimen_ri, my_group_l_size))
199 g_pq_local(my_p_start:my_p_end, :) = mp2_env%ri_grad%Gamma_PQ
200 DEALLOCATE (mp2_env%ri_grad%Gamma_PQ)
201 g_pq_local(my_p_start:my_p_end, :) = g_pq_local(my_p_start:my_p_end, :)/real(nspins,
dp)
202 CALL para_env_sub%sum(g_pq_local)
204 ALLOCATE (g_pq_local_2(dimen_ri, my_group_l_size))
205 g_pq_local_2 = 0.0_dp
206 g_pq_local_2(my_p_start:my_p_end, :) = mp2_env%ri_grad%Gamma_PQ_2
207 DEALLOCATE (mp2_env%ri_grad%Gamma_PQ_2)
208 g_pq_local_2(my_p_start:my_p_end, :) = g_pq_local_2(my_p_start:my_p_end, :)/real(nspins,
dp)
209 CALL para_env_sub%sum(g_pq_local_2)
213 ALLOCATE (matrix_p_inu(nspins))
215 CALL dbcsr_create(matrix_p_inu(ispin), template=mo_coeff_o(ispin)%matrix)
219 CALL dbcsr_create(matrix_p_munu_nosym, template=mat_munu%matrix, &
220 matrix_type=dbcsr_type_no_symmetry)
223 ALLOCATE (lag_mu_i_1(nspins))
225 CALL dbcsr_create(lag_mu_i_1(ispin), template=mo_coeff_o(ispin)%matrix)
226 CALL dbcsr_set(lag_mu_i_1(ispin), 0.0_dp)
229 ALLOCATE (lag_nu_a_2(nspins))
231 CALL dbcsr_create(lag_nu_a_2(ispin), template=mo_coeff_v(ispin)%matrix)
232 CALL dbcsr_set(lag_nu_a_2(ispin), 0.0_dp)
236 NULLIFY (force, virial)
237 CALL get_qs_env(qs_env=qs_env, force=force, virial=virial)
240 use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)
245 DEALLOCATE (natom_of_kind)
247 mp2_env%ri_grad%mp2_force => mp2_force
252 IF (alpha_beta) factor_2c = -2.0_dp
257 ALLOCATE (matrix_p_munu_local(my_group_l_size))
258 ALLOCATE (mat_munu_local(my_group_l_size))
260 DO lll = my_group_l_start, my_group_l_end
261 l_counter = l_counter + 1
262 ALLOCATE (mat_munu_local(l_counter)%matrix)
263 CALL dbcsr_create(mat_munu_local(l_counter)%matrix, template=mat_munu%matrix, &
264 matrix_type=dbcsr_type_symmetric)
265 CALL dbcsr_copy(mat_munu_local(l_counter)%matrix, mat_munu%matrix)
266 CALL dbcsr_set(mat_munu_local(l_counter)%matrix, 0.0_dp)
268 CALL g_p_transform_mo_to_ao(matrix_p_munu_local(l_counter)%matrix, matrix_p_munu_nosym, mat_munu%matrix, &
269 g_p_ia(:, l_counter), matrix_p_inu, &
270 mo_coeff_v, mo_coeff_o, eps_filter)
273 ALLOCATE (i_tmp2(dimen_ri, my_group_l_size))
274 i_tmp2(:, :) = 0.0_dp
276 basis_type_a=
"RI_AUX", basis_type_b=
"RI_AUX", &
277 hab=i_tmp2, first_b=my_group_l_start, last_b=my_group_l_end, &
278 eri_method=eri_method, pab=g_pq_local, force_a=force_2c)
280 i_tmp2(:, :) = 0.0_dp
282 basis_type_a=
"RI_AUX", basis_type_b=
"RI_AUX", &
283 hab=i_tmp2, first_b=my_group_l_start, last_b=my_group_l_end, &
284 eri_method=eri_method, pab=g_pq_local_2, force_a=force_2c_ri)
289 first_c=my_group_l_start, last_c=my_group_l_end, mat_ab=mat_munu_local, &
290 basis_type_a=
"ORB", basis_type_b=
"ORB", basis_type_c=
"RI_AUX", &
291 sab_nl=sab_orb_sub, eri_method=eri_method, &
292 pabc=matrix_p_munu_local, &
293 force_a=force_3c_orb_mu, force_b=force_3c_orb_nu, force_c=force_3c_aux)
296 DO lll = my_group_l_start, my_group_l_end
297 l_counter = l_counter + 1
299 CALL dbcsr_multiply(
"N",
"T", 1.0_dp, mo_coeff_v(ispin)%matrix, g_p_ia(ispin, l_counter)%matrix, &
300 0.0_dp, matrix_p_inu(ispin), filter_eps=eps_filter)
304 CALL update_lagrangian(mat_munu_local(l_counter)%matrix, matrix_p_inu, lag_mu_i_1, &
305 g_p_ia(:, l_counter), mo_coeff_o, lag_nu_a_2, &
309 DO ikind = 1,
SIZE(force)
310 mp2_force(ikind)%mp2_non_sep(:, :) = factor_2c*force_2c(ikind)%forces(:, :) + &
311 force_3c_orb_mu(ikind)%forces(:, :) + &
312 force_3c_orb_nu(ikind)%forces(:, :) + &
313 force_3c_aux(ikind)%forces(:, :)
316 mp2_force(ikind)%mp2_non_sep(:, :) = mp2_force(ikind)%mp2_non_sep(:, :) + factor_2c*force_2c_ri(ikind)%forces
336 CALL prepare_gpw(qs_env, dft_control, e_cutoff_old, cutoff_old, relative_cutoff_old, para_env_sub, pw_env_sub, &
337 auxbas_pw_pool, poisson_env, task_list_sub, rho_r, rho_g, pot_g, psi_l, sab_orb_sub)
343 CALL auxbas_pw_pool%create_pw(rho_g_copy)
345 CALL auxbas_pw_pool%create_pw(dvg(i))
350 CALL timeset(routinen//
"_loop", handle2)
352 IF (use_virial) h_stress = 0.0_dp
355 DO lll = my_group_l_start, my_group_l_end
356 l_counter = l_counter + 1
358 CALL g_p_transform_mo_to_ao(matrix_p_munu%matrix, matrix_p_munu_nosym, mat_munu%matrix, &
359 g_p_ia(:, l_counter), matrix_p_inu, &
360 mo_coeff_v, mo_coeff_o, eps_filter)
363 qs_kind_set, particle_set, cell, pw_env_sub, poisson_env, &
364 pot_g, mp2_env%potential_parameter, use_virial, &
365 rho_g_copy, dvg, kind_of, atom_of_kind, g_pq_local(:, l_counter), &
366 mp2_force, h_stress, para_env_sub, dft_control, psi_l, factor_2c)
371 qs_kind_set, particle_set, cell, pw_env_sub, poisson_env, &
372 pot_g, mp2_env%ri_metric, use_virial, &
373 rho_g_copy, dvg, kind_of, atom_of_kind, g_pq_local_2(:, l_counter), &
374 mp2_force, h_stress, para_env_sub, dft_control, psi_l, factor_2c)
377 IF (use_virial) pv_virial = virial%pv_virial
381 h_stress = h_stress + (virial%pv_virial - pv_virial)
382 virial%pv_virial = pv_virial
386 CALL update_lagrangian(mat_munu%matrix, matrix_p_inu, lag_mu_i_1, &
387 g_p_ia(:, l_counter), mo_coeff_o, lag_nu_a_2, &
392 ks_env, poisson_env, pot_g, use_virial, rho_g_copy, dvg, &
393 h_stress, para_env_sub, kind_of, atom_of_kind, &
394 qs_kind_set, particle_set, cell, lll, mp2_force, dft_control)
397 CALL timestop(handle2)
400 DEALLOCATE (atom_of_kind)
403 CALL auxbas_pw_pool%give_back_pw(rho_g_copy)
405 CALL auxbas_pw_pool%give_back_pw(dvg(i))
409 CALL cleanup_gpw(qs_env, e_cutoff_old, cutoff_old, relative_cutoff_old, para_env_sub, pw_env_sub, &
410 task_list_sub, auxbas_pw_pool, rho_r, rho_g, pot_g, psi_l)
412 CALL dbcsr_release(matrix_p_munu%matrix)
413 DEALLOCATE (matrix_p_munu%matrix)
417 IF (use_virial) mp2_env%ri_grad%mp2_virial = h_stress
419 DEALLOCATE (g_pq_local)
422 CALL dbcsr_release(matrix_p_munu_nosym)
425 CALL dbcsr_release(matrix_p_inu(ispin))
427 DEALLOCATE (matrix_p_inu, g_p_ia)
431 DO ikind = 1,
SIZE(mp2_force)
432 mp2_force(ikind)%mp2_non_sep(:, :) = force(ikind)%rho_elec(:, :)
433 force(ikind)%rho_elec(:, :) = 0.0_dp
441 ALLOCATE (l1_mu_i(nspins), l2_nu_a(nspins))
446 NULLIFY (fm_struct_tmp)
448 nrow_global=dimen, ncol_global=homo(ispin))
449 CALL cp_fm_create(l1_mu_i(ispin), fm_struct_tmp, name=
"Lag_mu_i")
455 CALL dbcsr_release(lag_mu_i_1(ispin))
457 NULLIFY (fm_struct_tmp)
459 nrow_global=dimen, ncol_global=virtual(ispin))
460 CALL cp_fm_create(l2_nu_a(ispin), fm_struct_tmp, name=
"Lag_nu_a")
466 CALL dbcsr_release(lag_nu_a_2(ispin))
468 DEALLOCATE (lag_mu_i_1, lag_nu_a_2)
472 IF (alpha_beta) factor = 0.50_dp
475 CALL create_w_p(qs_env, mp2_env, mo_coeff(ispin), homo(ispin), virtual(ispin), dimen, para_env, &
476 para_env_sub, eigenval(:, ispin), l1_mu_i(ispin), l2_nu_a(ispin), &
479 DEALLOCATE (l1_mu_i, l2_nu_a)
481 CALL timestop(handle)
496 SUBROUTINE g_p_transform_mo_to_ao(G_P_munu, G_P_munu_nosym, mat_munu, G_P_ia, G_P_inu, &
497 mo_coeff_v, mo_coeff_o, eps_filter)
498 TYPE(dbcsr_type),
POINTER :: g_p_munu
499 TYPE(dbcsr_type),
INTENT(INOUT) :: g_p_munu_nosym, mat_munu
500 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(IN) :: g_p_ia
501 TYPE(dbcsr_type),
DIMENSION(:),
INTENT(INOUT) :: g_p_inu
502 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(IN) :: mo_coeff_v, mo_coeff_o
503 REAL(kind=
dp),
INTENT(IN) :: eps_filter
505 CHARACTER(LEN=*),
PARAMETER :: routinen =
'G_P_transform_MO_to_AO'
509 IF (.NOT.
ASSOCIATED(g_p_munu))
THEN
511 CALL dbcsr_create(g_p_munu, template=mat_munu, &
512 matrix_type=dbcsr_type_symmetric)
515 CALL g_p_transform_alpha_beta(g_p_ia, g_p_inu, g_p_munu_nosym, mo_coeff_v, mo_coeff_o, eps_filter)
518 CALL timeset(routinen//
"_symmetrize", handle)
519 CALL dbcsr_set(g_p_munu, 0.0_dp)
520 CALL dbcsr_transposed(g_p_munu, g_p_munu_nosym)
521 CALL dbcsr_add(g_p_munu, g_p_munu_nosym, &
522 alpha_scalar=2.0_dp, beta_scalar=2.0_dp)
524 CALL dbcsr_copy_into_existing(mat_munu, g_p_munu)
525 CALL dbcsr_copy(g_p_munu, mat_munu)
527 CALL timestop(handle)
529 END SUBROUTINE g_p_transform_mo_to_ao
540 SUBROUTINE g_p_transform_alpha_beta(G_P_ia, G_P_inu, G_P_munu, mo_coeff_v, mo_coeff_o, eps_filter)
541 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(IN) :: g_p_ia
542 TYPE(dbcsr_type),
DIMENSION(:),
INTENT(INOUT) :: g_p_inu
543 TYPE(dbcsr_type),
INTENT(INOUT) :: g_p_munu
544 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(IN) :: mo_coeff_v, mo_coeff_o
545 REAL(kind=
dp),
INTENT(IN) :: eps_filter
547 CHARACTER(LEN=*),
PARAMETER :: routinen =
'G_P_transform_alpha_beta'
549 INTEGER :: handle, ispin
550 REAL(kind=
dp) :: factor
552 CALL timeset(routinen, handle)
554 factor = 1.0_dp/real(
SIZE(g_p_ia),
dp)
556 CALL dbcsr_set(g_p_munu, 0.0_dp)
558 DO ispin = 1,
SIZE(g_p_ia)
560 CALL dbcsr_multiply(
"N",
"T", 1.0_dp, mo_coeff_v(ispin)%matrix, g_p_ia(ispin)%matrix, &
561 0.0_dp, g_p_inu(ispin), filter_eps=eps_filter)
564 CALL dbcsr_multiply(
"N",
"T", factor, g_p_inu(ispin), mo_coeff_o(ispin)%matrix, &
565 1.0_dp, g_p_munu, filter_eps=eps_filter)
568 CALL timestop(handle)
570 END SUBROUTINE g_p_transform_alpha_beta
582 SUBROUTINE update_lagrangian(mat_munu, matrix_P_inu, Lag_mu_i_1, &
583 G_P_ia, mo_coeff_o, Lag_nu_a_2, &
585 TYPE(dbcsr_type),
INTENT(IN) :: mat_munu
586 TYPE(dbcsr_type),
DIMENSION(:),
INTENT(INOUT) :: matrix_p_inu, lag_mu_i_1
587 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(INOUT) :: g_p_ia
588 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(IN) :: mo_coeff_o
589 TYPE(dbcsr_type),
DIMENSION(:),
INTENT(INOUT) :: lag_nu_a_2
590 REAL(kind=
dp),
INTENT(IN) :: eps_filter
592 CHARACTER(LEN=*),
PARAMETER :: routinen =
'update_lagrangian'
594 INTEGER :: handle, ispin
597 CALL timeset(routinen, handle)
599 DO ispin = 1,
SIZE(g_p_ia)
602 CALL dbcsr_multiply(
"N",
"N", 1.0_dp, mat_munu, matrix_p_inu(ispin), &
603 1.0_dp, lag_mu_i_1(ispin), filter_eps=eps_filter)
606 CALL dbcsr_set(matrix_p_inu(ispin), 0.0_dp)
607 CALL dbcsr_multiply(
"N",
"N", 1.0_dp, mat_munu, mo_coeff_o(ispin)%matrix, &
608 0.0_dp, matrix_p_inu(ispin), filter_eps=eps_filter)
612 CALL dbcsr_multiply(
"N",
"N", -1.0_dp, matrix_p_inu(ispin), g_p_ia(ispin)%matrix, &
613 1.0_dp, lag_nu_a_2(ispin), filter_eps=eps_filter)
616 CALL dbcsr_release(g_p_ia(ispin)%matrix)
617 DEALLOCATE (g_p_ia(ispin)%matrix)
620 CALL timestop(handle)
622 END SUBROUTINE update_lagrangian
640 SUBROUTINE create_w_p(qs_env, mp2_env, mo_coeff, homo, virtual, dimen, para_env, para_env_sub, &
641 Eigenval, L1_mu_i, L2_nu_a, factor, kspin)
642 TYPE(qs_environment_type),
POINTER :: qs_env
643 TYPE(mp2_type) :: mp2_env
644 TYPE(cp_fm_type),
INTENT(IN) :: mo_coeff
645 INTEGER,
INTENT(IN) :: homo, virtual, dimen
646 TYPE(mp_para_env_type),
POINTER :: para_env, para_env_sub
647 REAL(kind=
dp),
DIMENSION(:),
INTENT(IN) :: eigenval
648 TYPE(cp_fm_type),
INTENT(INOUT) :: l1_mu_i, l2_nu_a
649 REAL(kind=
dp),
INTENT(IN) :: factor
650 INTEGER,
INTENT(IN) :: kspin
652 CHARACTER(LEN=*),
PARAMETER :: routinen =
'create_W_P'
654 INTEGER :: color_exchange, dummy_proc, handle, handle2, handle3, i_global, i_local, iib, &
655 iii, iproc, itmp(2), j_global, j_local, jjb, max_col_size, max_row_size, &
656 my_b_virtual_end, my_b_virtual_start, mypcol, myprow, ncol_block, ncol_block_1i, &
657 ncol_block_2a, ncol_local, ncol_local_1i, ncol_local_2a, npcol, npcol_1i, npcol_2a, &
658 nprow, nprow_1i, nprow_2a, nrow_block, nrow_block_1i, nrow_block_2a, nrow_local, &
659 nrow_local_1i, nrow_local_2a, number_of_rec, number_of_send, proc_receive, &
660 proc_receive_static, proc_send, proc_send_ex, proc_send_static, proc_send_sub, &
661 proc_shift, rec_col_size
662 INTEGER :: rec_counter, rec_row_size, send_col_size, send_counter, send_pcol, send_prow, &
663 send_row_size, size_rec_buffer, size_send_buffer
664 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: iii_vet, map_rec_size, map_send_size, &
665 pos_info, pos_info_ex, proc_2_send_pos
666 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: grid_2_mepos, mepos_2_grid, my_col_indeces_info_1i, &
667 my_col_indeces_info_2a, my_row_indeces_info_1i, my_row_indeces_info_2a, sizes, sizes_1i, &
669 INTEGER,
ALLOCATABLE,
DIMENSION(:, :, :) :: col_indeces_info_1i, &
670 col_indeces_info_2a, &
671 row_indeces_info_1i, &
673 INTEGER,
DIMENSION(:),
POINTER :: col_indices, col_indices_1i, &
674 col_indices_2a, row_indices, &
675 row_indices_1i, row_indices_2a
676 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: ab_rec, ab_send, mat_rec, mat_send
677 TYPE(cp_blacs_env_type),
POINTER :: blacs_env
678 TYPE(cp_fm_struct_type),
POINTER :: fm_struct_tmp
679 TYPE(cp_fm_type) :: fm_p_ij, l_mu_q
680 TYPE(integ_mat_buffer_type),
ALLOCATABLE, &
681 DIMENSION(:) :: buffer_rec, buffer_send
682 TYPE(integ_mat_buffer_type_2d),
ALLOCATABLE, &
683 DIMENSION(:) :: buffer_cyclic
684 TYPE(mp_para_env_type),
POINTER :: para_env_exchange
685 TYPE(mp_request_type),
ALLOCATABLE,
DIMENSION(:) :: req_send
687 CALL timeset(routinen, handle)
693 NULLIFY (fm_struct_tmp)
695 nrow_global=dimen, ncol_global=dimen)
696 CALL cp_fm_create(l_mu_q, fm_struct_tmp, name=
"Lag_mu_q")
701 ALLOCATE (pos_info(0:para_env%num_pe - 1))
702 CALL para_env%allgather(para_env_sub%mepos, pos_info)
706 nrow_local=nrow_local, &
707 ncol_local=ncol_local, &
708 row_indices=row_indices, &
709 col_indices=col_indices, &
710 nrow_block=nrow_block, &
711 ncol_block=ncol_block)
712 myprow = l_mu_q%matrix_struct%context%mepos(1)
713 mypcol = l_mu_q%matrix_struct%context%mepos(2)
714 nprow = l_mu_q%matrix_struct%context%num_pe(1)
715 npcol = l_mu_q%matrix_struct%context%num_pe(2)
717 ALLOCATE (grid_2_mepos(0:nprow - 1, 0:npcol - 1))
719 grid_2_mepos(myprow, mypcol) = para_env%mepos
720 CALL para_env%sum(grid_2_mepos)
724 nrow_local=nrow_local_1i, &
725 ncol_local=ncol_local_1i, &
726 row_indices=row_indices_1i, &
727 col_indices=col_indices_1i, &
728 nrow_block=nrow_block_1i, &
729 ncol_block=ncol_block_1i)
730 nprow_1i = l1_mu_i%matrix_struct%context%num_pe(1)
731 npcol_1i = l1_mu_i%matrix_struct%context%num_pe(2)
733 ALLOCATE (sizes_1i(2, 0:para_env_sub%num_pe - 1))
734 CALL para_env_sub%allgather([nrow_local_1i, ncol_local_1i], sizes_1i)
738 nrow_local=nrow_local_2a, &
739 ncol_local=ncol_local_2a, &
740 row_indices=row_indices_2a, &
741 col_indices=col_indices_2a, &
742 nrow_block=nrow_block_2a, &
743 ncol_block=ncol_block_2a)
744 nprow_2a = l2_nu_a%matrix_struct%context%num_pe(1)
745 npcol_2a = l2_nu_a%matrix_struct%context%num_pe(2)
747 ALLOCATE (sizes_2a(2, 0:para_env_sub%num_pe - 1))
748 CALL para_env_sub%allgather([nrow_local_2a, ncol_local_2a], sizes_2a)
759 color_exchange = para_env_sub%mepos
760 ALLOCATE (para_env_exchange)
761 CALL para_env_exchange%from_split(para_env, color_exchange)
762 ALLOCATE (pos_info_ex(0:para_env%num_pe - 1))
763 CALL para_env%allgather(para_env_exchange%mepos, pos_info_ex)
764 ALLOCATE (sizes(2, 0:para_env_exchange%num_pe - 1))
765 CALL para_env_exchange%allgather([nrow_local, ncol_local], sizes)
768 CALL timeset(routinen//
"_inx", handle2)
770 max_row_size = maxval(sizes_1i(1, :))
771 max_col_size = maxval(sizes_1i(2, :))
772 ALLOCATE (row_indeces_info_1i(2, max_row_size, 0:para_env_sub%num_pe - 1))
773 ALLOCATE (col_indeces_info_1i(2, max_col_size, 0:para_env_sub%num_pe - 1))
774 ALLOCATE (my_row_indeces_info_1i(2, max_row_size))
775 ALLOCATE (my_col_indeces_info_1i(2, max_col_size))
776 row_indeces_info_1i = 0
777 col_indeces_info_1i = 0
780 DO iib = 1, nrow_local_1i
781 i_global = row_indices_1i(iib)
782 send_prow =
cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
783 l_mu_q%matrix_struct%first_p_pos(1), nprow)
785 l_mu_q%matrix_struct%first_p_pos(1), nprow)
786 my_row_indeces_info_1i(1, iib) = send_prow
787 my_row_indeces_info_1i(2, iib) = i_local
790 DO jjb = 1, ncol_local_1i
791 j_global = col_indices_1i(jjb)
792 send_pcol =
cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
793 l_mu_q%matrix_struct%first_p_pos(2), npcol)
795 l_mu_q%matrix_struct%first_p_pos(2), npcol)
796 my_col_indeces_info_1i(1, jjb) = send_pcol
797 my_col_indeces_info_1i(2, jjb) = j_local
799 CALL para_env_sub%allgather(my_row_indeces_info_1i, row_indeces_info_1i)
800 CALL para_env_sub%allgather(my_col_indeces_info_1i, col_indeces_info_1i)
801 DEALLOCATE (my_row_indeces_info_1i, my_col_indeces_info_1i)
804 max_row_size = maxval(sizes_2a(1, :))
805 max_col_size = maxval(sizes_2a(2, :))
806 ALLOCATE (row_indeces_info_2a(2, max_row_size, 0:para_env_sub%num_pe - 1))
807 ALLOCATE (col_indeces_info_2a(2, max_col_size, 0:para_env_sub%num_pe - 1))
808 ALLOCATE (my_row_indeces_info_2a(2, max_row_size))
809 ALLOCATE (my_col_indeces_info_2a(2, max_col_size))
810 row_indeces_info_2a = 0
811 col_indeces_info_2a = 0
813 DO iib = 1, nrow_local_2a
814 i_global = row_indices_2a(iib)
815 send_prow =
cp_fm_indxg2p(i_global, nrow_block, dummy_proc, &
816 l_mu_q%matrix_struct%first_p_pos(1), nprow)
818 l_mu_q%matrix_struct%first_p_pos(1), nprow)
819 my_row_indeces_info_2a(1, iib) = send_prow
820 my_row_indeces_info_2a(2, iib) = i_local
823 DO jjb = 1, ncol_local_2a
824 j_global = col_indices_2a(jjb) + homo
825 send_pcol =
cp_fm_indxg2p(j_global, ncol_block, dummy_proc, &
826 l_mu_q%matrix_struct%first_p_pos(2), npcol)
828 l_mu_q%matrix_struct%first_p_pos(2), npcol)
829 my_col_indeces_info_2a(1, jjb) = send_pcol
830 my_col_indeces_info_2a(2, jjb) = j_local
832 CALL para_env_sub%allgather(my_row_indeces_info_2a, row_indeces_info_2a)
833 CALL para_env_sub%allgather(my_col_indeces_info_2a, col_indeces_info_2a)
834 DEALLOCATE (my_row_indeces_info_2a, my_col_indeces_info_2a)
835 CALL timestop(handle2)
838 CALL timeset(routinen//
"_subinfo", handle2)
839 ALLOCATE (map_send_size(0:para_env_sub%num_pe - 1))
841 DO jjb = 1, ncol_local_1i
842 send_pcol = col_indeces_info_1i(1, jjb, para_env_sub%mepos)
843 DO iib = 1, nrow_local_1i
844 send_prow = row_indeces_info_1i(1, iib, para_env_sub%mepos)
845 proc_send = grid_2_mepos(send_prow, send_pcol)
846 proc_send_sub = pos_info(proc_send)
847 map_send_size(proc_send_sub) = map_send_size(proc_send_sub) + 1
851 DO jjb = 1, ncol_local_2a
852 send_pcol = col_indeces_info_2a(1, jjb, para_env_sub%mepos)
853 DO iib = 1, nrow_local_2a
854 send_prow = row_indeces_info_2a(1, iib, para_env_sub%mepos)
855 proc_send = grid_2_mepos(send_prow, send_pcol)
856 proc_send_sub = pos_info(proc_send)
857 map_send_size(proc_send_sub) = map_send_size(proc_send_sub) + 1
861 ALLOCATE (map_rec_size(0:para_env_sub%num_pe - 1))
863 CALL para_env_sub%alltoall(map_send_size, map_rec_size, 1)
864 CALL timestop(handle2)
867 CALL timeset(routinen//
"_sub_Bsend", handle2)
870 DO proc_shift = 0, para_env_sub%num_pe - 1
871 proc_send =
modulo(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
872 IF (map_send_size(proc_send) > 0)
THEN
873 number_of_send = number_of_send + 1
877 ALLOCATE (buffer_send(number_of_send))
879 ALLOCATE (proc_2_send_pos(0:para_env_sub%num_pe - 1))
881 DO proc_shift = 0, para_env_sub%num_pe - 1
882 proc_send =
modulo(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
883 size_send_buffer = map_send_size(proc_send)
884 IF (map_send_size(proc_send) > 0)
THEN
885 send_counter = send_counter + 1
887 ALLOCATE (buffer_send(send_counter)%msg(size_send_buffer))
888 buffer_send(send_counter)%msg = 0.0_dp
889 buffer_send(send_counter)%proc = proc_send
890 proc_2_send_pos(proc_send) = send_counter
896 ALLOCATE (iii_vet(number_of_send))
898 DO jjb = 1, ncol_local_1i
899 send_pcol = col_indeces_info_1i(1, jjb, para_env_sub%mepos)
900 DO iib = 1, nrow_local_1i
901 send_prow = row_indeces_info_1i(1, iib, para_env_sub%mepos)
902 proc_send = grid_2_mepos(send_prow, send_pcol)
903 proc_send_sub = pos_info(proc_send)
904 send_counter = proc_2_send_pos(proc_send_sub)
905 iii_vet(send_counter) = iii_vet(send_counter) + 1
906 iii = iii_vet(send_counter)
907 buffer_send(send_counter)%msg(iii) = l1_mu_i%local_data(iib, jjb)
911 DEALLOCATE (l1_mu_i%local_data)
913 DO jjb = 1, ncol_local_2a
914 send_pcol = col_indeces_info_2a(1, jjb, para_env_sub%mepos)
915 DO iib = 1, nrow_local_2a
916 send_prow = row_indeces_info_2a(1, iib, para_env_sub%mepos)
917 proc_send = grid_2_mepos(send_prow, send_pcol)
918 proc_send_sub = pos_info(proc_send)
919 send_counter = proc_2_send_pos(proc_send_sub)
920 iii_vet(send_counter) = iii_vet(send_counter) + 1
921 iii = iii_vet(send_counter)
922 buffer_send(send_counter)%msg(iii) = l2_nu_a%local_data(iib, jjb)
925 DEALLOCATE (l2_nu_a%local_data)
926 DEALLOCATE (proc_2_send_pos)
928 CALL timestop(handle2)
932 CALL timeset(routinen//
"_sub_isendrecv", handle2)
935 DO proc_shift = 0, para_env_sub%num_pe - 1
936 proc_receive =
modulo(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
937 IF (map_rec_size(proc_receive) > 0)
THEN
938 number_of_rec = number_of_rec + 1
941 ALLOCATE (buffer_rec(number_of_rec))
943 DO proc_shift = 0, para_env_sub%num_pe - 1
944 proc_receive =
modulo(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
945 size_rec_buffer = map_rec_size(proc_receive)
946 IF (map_rec_size(proc_receive) > 0)
THEN
947 rec_counter = rec_counter + 1
949 ALLOCATE (buffer_rec(rec_counter)%msg(size_rec_buffer))
950 buffer_rec(rec_counter)%msg = 0.0_dp
951 buffer_rec(rec_counter)%proc = proc_receive
953 IF (proc_receive /= para_env_sub%mepos)
THEN
954 CALL para_env_sub%irecv(buffer_rec(rec_counter)%msg, proc_receive, &
955 buffer_rec(rec_counter)%msg_req)
960 ALLOCATE (req_send(number_of_send))
963 DO proc_shift = 0, para_env_sub%num_pe - 1
964 proc_send =
modulo(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
965 IF (map_send_size(proc_send) > 0)
THEN
966 send_counter = send_counter + 1
967 IF (proc_send == para_env_sub%mepos)
THEN
968 buffer_rec(send_counter)%msg(:) = buffer_send(send_counter)%msg
970 CALL para_env_sub%isend(buffer_send(send_counter)%msg, proc_send, &
971 buffer_send(send_counter)%msg_req)
972 req_send(send_counter) = buffer_send(send_counter)%msg_req
976 DEALLOCATE (map_send_size)
977 CALL timestop(handle2)
983 CALL timeset(routinen//
"_Bcyclic", handle2)
985 ALLOCATE (buffer_cyclic(0:para_env_exchange%num_pe - 1))
986 DO iproc = 0, para_env_exchange%num_pe - 1
987 rec_row_size = sizes(1, iproc)
988 rec_col_size = sizes(2, iproc)
989 ALLOCATE (buffer_cyclic(iproc)%msg(rec_row_size, rec_col_size))
990 buffer_cyclic(iproc)%msg = 0.0_dp
995 DO proc_shift = 0, para_env_sub%num_pe - 1
996 proc_receive =
modulo(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
997 size_rec_buffer = map_rec_size(proc_receive)
998 IF (map_rec_size(proc_receive) > 0)
THEN
999 rec_counter = rec_counter + 1
1002 IF (proc_receive /= para_env_sub%mepos)
CALL buffer_rec(rec_counter)%msg_req%wait()
1004 CALL timeset(routinen//
"_fill", handle3)
1006 DO jjb = 1, sizes_1i(2, proc_receive)
1007 send_pcol = col_indeces_info_1i(1, jjb, proc_receive)
1008 j_local = col_indeces_info_1i(2, jjb, proc_receive)
1009 DO iib = 1, sizes_1i(1, proc_receive)
1010 send_prow = row_indeces_info_1i(1, iib, proc_receive)
1011 proc_send = grid_2_mepos(send_prow, send_pcol)
1012 proc_send_sub = pos_info(proc_send)
1013 IF (proc_send_sub /= para_env_sub%mepos) cycle
1015 i_local = row_indeces_info_1i(2, iib, proc_receive)
1016 proc_send_ex = pos_info_ex(proc_send)
1017 buffer_cyclic(proc_send_ex)%msg(i_local, j_local) = buffer_rec(rec_counter)%msg(iii)
1021 DO jjb = 1, sizes_2a(2, proc_receive)
1022 send_pcol = col_indeces_info_2a(1, jjb, proc_receive)
1023 j_local = col_indeces_info_2a(2, jjb, proc_receive)
1024 DO iib = 1, sizes_2a(1, proc_receive)
1025 send_prow = row_indeces_info_2a(1, iib, proc_receive)
1026 proc_send = grid_2_mepos(send_prow, send_pcol)
1027 proc_send_sub = pos_info(proc_send)
1028 IF (proc_send_sub /= para_env_sub%mepos) cycle
1030 i_local = row_indeces_info_2a(2, iib, proc_receive)
1031 proc_send_ex = pos_info_ex(proc_send)
1032 buffer_cyclic(proc_send_ex)%msg(i_local, j_local) = buffer_rec(rec_counter)%msg(iii)
1035 CALL timestop(handle3)
1038 DEALLOCATE (buffer_rec(rec_counter)%msg)
1041 DEALLOCATE (row_indeces_info_1i)
1042 DEALLOCATE (col_indeces_info_1i)
1043 DEALLOCATE (row_indeces_info_2a)
1044 DEALLOCATE (col_indeces_info_2a)
1045 DEALLOCATE (buffer_rec)
1046 DEALLOCATE (map_rec_size)
1047 CALL timestop(handle2)
1050 CALL timeset(routinen//
"_sub_waitall", handle2)
1051 CALL mp_waitall(req_send(:))
1052 DO send_counter = 1, number_of_send
1053 DEALLOCATE (buffer_send(send_counter)%msg)
1055 DEALLOCATE (buffer_send)
1056 DEALLOCATE (req_send)
1057 CALL timestop(handle2)
1060 CALL timeset(routinen//
"_ring", handle2)
1061 proc_send_static =
modulo(para_env_exchange%mepos + 1, para_env_exchange%num_pe)
1062 proc_receive_static =
modulo(para_env_exchange%mepos - 1, para_env_exchange%num_pe)
1063 max_row_size = maxval(sizes(1, :))
1064 max_col_size = maxval(sizes(2, :))
1065 ALLOCATE (mat_send(max_row_size, max_col_size))
1066 ALLOCATE (mat_rec(max_row_size, max_col_size))
1068 mat_send(1:nrow_local, 1:ncol_local) = buffer_cyclic(para_env_exchange%mepos)%msg(:, :)
1069 DEALLOCATE (buffer_cyclic(para_env_exchange%mepos)%msg)
1070 DO proc_shift = 1, para_env_exchange%num_pe - 1
1071 proc_receive =
modulo(para_env_exchange%mepos - proc_shift, para_env_exchange%num_pe)
1073 rec_row_size = sizes(1, proc_receive)
1074 rec_col_size = sizes(2, proc_receive)
1077 CALL para_env_exchange%sendrecv(mat_send, proc_send_static, &
1078 mat_rec, proc_receive_static)
1081 mat_send(1:rec_row_size, 1:rec_col_size) = mat_rec(1:rec_row_size, 1:rec_col_size) + &
1082 buffer_cyclic(proc_receive)%msg(:, :)
1084 DEALLOCATE (buffer_cyclic(proc_receive)%msg)
1087 CALL para_env_exchange%sendrecv(mat_send, proc_send_static, &
1088 mat_rec, proc_receive_static)
1089 l_mu_q%local_data(1:nrow_local, 1:ncol_local) = mat_rec(1:nrow_local, 1:ncol_local)
1090 DEALLOCATE (buffer_cyclic)
1091 DEALLOCATE (mat_send)
1092 DEALLOCATE (mat_rec)
1093 CALL timestop(handle2)
1098 CALL cp_fm_release(l1_mu_i)
1099 CALL cp_fm_release(l2_nu_a)
1100 DEALLOCATE (pos_info_ex)
1101 DEALLOCATE (grid_2_mepos)
1103 DEALLOCATE (sizes_1i)
1104 DEALLOCATE (sizes_2a)
1108 CALL timeset(routinen//
"_Pij", handle2)
1109 NULLIFY (fm_struct_tmp)
1111 nrow_global=homo, ncol_global=homo)
1112 CALL cp_fm_create(fm_p_ij, fm_struct_tmp, name=
"fm_P_ij")
1118 nrow_local=nrow_local, &
1119 ncol_local=ncol_local, &
1120 row_indices=row_indices, &
1121 col_indices=col_indices)
1124 CALL parallel_gemm(
'T',
'N', homo, homo, dimen, 1.0_dp, &
1125 mo_coeff, l_mu_q, 0.0_dp, fm_p_ij, &
1132 CALL parallel_gemm(
'T',
'N', homo, homo, dimen, -2.0_dp, &
1133 l_mu_q, mo_coeff, 2.0_dp, fm_p_ij, &
1141 DO jjb = 1, ncol_local
1142 j_global = col_indices(jjb)
1143 DO iib = 1, nrow_local
1144 i_global = row_indices(iib)
1146 IF (abs(eigenval(j_global) - eigenval(i_global)) < mp2_env%ri_grad%eps_canonical)
THEN
1147 fm_p_ij%local_data(iib, jjb) = mp2_env%ri_grad%P_ij(kspin)%array(i_global, j_global)
1149 fm_p_ij%local_data(iib, jjb) = &
1150 factor*fm_p_ij%local_data(iib, jjb)/(eigenval(j_global) - eigenval(i_global))
1155 DO jjb = 1, ncol_local
1156 j_global = col_indices(jjb)
1157 DO iib = 1, nrow_local
1158 i_global = row_indices(iib)
1159 fm_p_ij%local_data(iib, jjb) = mp2_env%ri_grad%P_ij(kspin)%array(i_global, j_global)
1164 DEALLOCATE (mp2_env%ri_grad%P_ij(kspin)%array)
1165 CALL timestop(handle2)
1169 IF (.NOT.
ALLOCATED(mp2_env%ri_grad%P_mo))
THEN
1170 ALLOCATE (mp2_env%ri_grad%P_mo(
SIZE(mp2_env%ri_grad%mo_coeff_o)))
1173 CALL timeset(routinen//
"_PMO", handle2)
1174 NULLIFY (fm_struct_tmp)
1176 nrow_global=dimen, ncol_global=dimen)
1177 CALL cp_fm_create(mp2_env%ri_grad%P_mo(kspin), fm_struct_tmp, name=
"P_MP2_MO")
1181 itmp =
get_limit(virtual, para_env_sub%num_pe, para_env_sub%mepos)
1182 my_b_virtual_start = itmp(1)
1183 my_b_virtual_end = itmp(2)
1186 CALL cp_fm_to_fm_submat(fm_p_ij, mp2_env%ri_grad%P_mo(kspin), homo, homo, 1, 1, 1, 1)
1187 CALL cp_fm_release(fm_p_ij)
1190 nrow_local=nrow_local, &
1191 ncol_local=ncol_local, &
1192 row_indices=row_indices, &
1193 col_indices=col_indices, &
1194 nrow_block=nrow_block, &
1195 ncol_block=ncol_block)
1196 myprow = mp2_env%ri_grad%P_mo(kspin)%matrix_struct%context%mepos(1)
1197 mypcol = mp2_env%ri_grad%P_mo(kspin)%matrix_struct%context%mepos(2)
1198 nprow = mp2_env%ri_grad%P_mo(kspin)%matrix_struct%context%num_pe(1)
1199 npcol = mp2_env%ri_grad%P_mo(kspin)%matrix_struct%context%num_pe(2)
1202 CALL parallel_gemm(
'T',
'N', virtual, virtual, dimen, 1.0_dp, &
1203 mo_coeff, l_mu_q, 0.0_dp, mp2_env%ri_grad%P_mo(kspin), &
1204 a_first_col=homo + 1, &
1206 b_first_col=homo + 1, &
1208 c_first_col=homo + 1, &
1209 c_first_row=homo + 1)
1210 CALL parallel_gemm(
'T',
'N', virtual, virtual, dimen, -2.0_dp, &
1211 l_mu_q, mo_coeff, 2.0_dp, mp2_env%ri_grad%P_mo(kspin), &
1212 a_first_col=homo + 1, &
1214 b_first_col=homo + 1, &
1216 c_first_col=homo + 1, &
1217 c_first_row=homo + 1)
1222 DO jjb = 1, ncol_local
1223 j_global = col_indices(jjb)
1224 IF (j_global <= homo) cycle
1225 DO iib = 1, nrow_local
1226 i_global = row_indices(iib)
1227 IF (my_b_virtual_start <= i_global - homo .AND. i_global - homo <= my_b_virtual_end)
THEN
1228 mp2_env%ri_grad%P_mo(kspin)%local_data(iib, jjb) = &
1229 mp2_env%ri_grad%P_ab(kspin)%array(i_global - homo - my_b_virtual_start + 1, j_global - homo)
1235 DO jjb = 1, ncol_local
1236 j_global = col_indices(jjb)
1237 IF (j_global <= homo) cycle
1238 DO iib = 1, nrow_local
1239 i_global = row_indices(iib)
1240 IF (abs(eigenval(i_global) - eigenval(j_global)) < mp2_env%ri_grad%eps_canonical)
THEN
1241 IF (my_b_virtual_start <= i_global - homo .AND. i_global - homo <= my_b_virtual_end)
THEN
1242 mp2_env%ri_grad%P_mo(kspin)%local_data(iib, jjb) = &
1243 mp2_env%ri_grad%P_ab(kspin)%array(i_global - homo - my_b_virtual_start + 1, j_global - homo)
1245 mp2_env%ri_grad%P_mo(kspin)%local_data(iib, jjb) = 0.0_dp
1248 mp2_env%ri_grad%P_mo(kspin)%local_data(iib, jjb) = &
1249 factor*mp2_env%ri_grad%P_mo(kspin)%local_data(iib, jjb)/ &
1250 (eigenval(i_global) - eigenval(j_global))
1255 cpabort(
"Calculation of virt-virt block of density matrix is dealt with elsewhere!")
1260 ALLOCATE (mepos_2_grid(2, 0:para_env_sub%num_pe - 1))
1261 CALL para_env_sub%allgather([myprow, mypcol], mepos_2_grid)
1263 ALLOCATE (sizes(2, 0:para_env_sub%num_pe - 1))
1264 CALL para_env_sub%allgather([nrow_local, ncol_local], sizes)
1266 ALLOCATE (ab_rec(nrow_local, ncol_local))
1267 DO proc_shift = 1, para_env_sub%num_pe - 1
1268 proc_send =
modulo(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
1269 proc_receive =
modulo(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
1271 send_prow = mepos_2_grid(1, proc_send)
1272 send_pcol = mepos_2_grid(2, proc_send)
1274 send_row_size = sizes(1, proc_send)
1275 send_col_size = sizes(2, proc_send)
1277 ALLOCATE (ab_send(send_row_size, send_col_size))
1281 DO iib = 1, send_row_size
1283 mp2_env%ri_grad%P_mo(kspin)%matrix_struct%first_p_pos(1), nprow)
1284 IF (i_global <= homo) cycle
1285 i_global = i_global - homo
1286 IF (.NOT. (my_b_virtual_start <= i_global .AND. i_global <= my_b_virtual_end)) cycle
1287 DO jjb = 1, send_col_size
1289 mp2_env%ri_grad%P_mo(kspin)%matrix_struct%first_p_pos(2), npcol)
1290 IF (j_global <= homo) cycle
1291 j_global = j_global - homo
1292 ab_send(iib, jjb) = mp2_env%ri_grad%P_ab(kspin)%array(i_global - my_b_virtual_start + 1, j_global)
1297 CALL para_env_sub%sendrecv(ab_send, proc_send, &
1298 ab_rec, proc_receive)
1299 mp2_env%ri_grad%P_mo(kspin)%local_data(1:nrow_local, 1:ncol_local) = &
1300 mp2_env%ri_grad%P_mo(kspin)%local_data(1:nrow_local, 1:ncol_local) + &
1301 ab_rec(1:nrow_local, 1:ncol_local)
1303 DEALLOCATE (ab_send)
1306 DEALLOCATE (mepos_2_grid)
1310 DEALLOCATE (mp2_env%ri_grad%P_ab(kspin)%array)
1311 CALL timestop(handle2)
1314 CALL timeset(routinen//
"_WMO", handle2)
1315 IF (.NOT.
ALLOCATED(mp2_env%ri_grad%W_mo))
THEN
1316 ALLOCATE (mp2_env%ri_grad%W_mo(
SIZE(mp2_env%ri_grad%mo_coeff_o)))
1319 CALL cp_fm_create(mp2_env%ri_grad%W_mo(kspin), fm_struct_tmp, name=
"W_MP2_MO")
1323 CALL parallel_gemm(
'T',
'N', dimen, dimen, dimen, 2.0_dp*factor, &
1324 l_mu_q, mo_coeff, 0.0_dp, mp2_env%ri_grad%W_mo(kspin), &
1333 CALL parallel_gemm(
'T',
'N', homo, homo, dimen, -2.0_dp*factor, &
1334 l_mu_q, mo_coeff, 0.0_dp, mp2_env%ri_grad%W_mo(kspin), &
1343 CALL parallel_gemm(
'T',
'N', homo, virtual, dimen, 2.0_dp*factor, &
1344 mo_coeff, l_mu_q, 0.0_dp, mp2_env%ri_grad%W_mo(kspin), &
1347 b_first_col=homo + 1, &
1349 c_first_col=homo + 1, &
1351 CALL timestop(handle2)
1354 CALL timeset(routinen//
"_Ljb", handle2)
1355 IF (.NOT.
ALLOCATED(mp2_env%ri_grad%L_jb))
THEN
1356 ALLOCATE (mp2_env%ri_grad%L_jb(
SIZE(mp2_env%ri_grad%mo_coeff_o)))
1360 nrow_global=homo, ncol_global=virtual)
1361 CALL cp_fm_create(mp2_env%ri_grad%L_jb(kspin), fm_struct_tmp, name=
"fm_L_jb")
1365 CALL parallel_gemm(
'T',
'N', homo, virtual, dimen, 2.0_dp*factor, &
1366 l_mu_q, mo_coeff, 0.0_dp, mp2_env%ri_grad%L_jb(kspin), &
1369 b_first_col=homo + 1, &
1374 CALL parallel_gemm(
'T',
'N', homo, virtual, dimen, 2.0_dp*factor, &
1375 mo_coeff, l_mu_q, 1.0_dp, mp2_env%ri_grad%L_jb(kspin), &
1378 b_first_col=homo + 1, &
1384 CALL cp_fm_release(l_mu_q)
1385 CALL timestop(handle2)
1389 DEALLOCATE (pos_info)
1391 CALL timestop(handle)
1393 END SUBROUTINE create_w_p
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Define the atomic kind types and their sub types.
subroutine, public get_atomic_kind_set(atomic_kind_set, atom_of_kind, kind_of, natom_of_kind, maxatom, natom, nshell, fist_potential_present, shell_present, shell_adiabatic, shell_check_distance, damping_present)
Get attributes of an atomic kind set.
Handles all functions related to the CELL.
methods related to the blacs parallel environment
Defines control structures, which contain the parameters and the settings for the DFT-based calculati...
DBCSR operations in CP2K.
subroutine, public copy_dbcsr_to_fm(matrix, fm)
Copy a DBCSR matrix to a BLACS matrix.
Interface to Minimax-Ewald method for periodic ERI's to be used in CP2K.
represent the structure of a full matrix
subroutine, public cp_fm_struct_create(fmstruct, para_env, context, nrow_global, ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, local_leading_dimension, template_fmstruct, square_blocks, force_block)
allocates and initializes a full matrix structure
subroutine, public cp_fm_struct_release(fmstruct)
releases a full matrix structure
represent a full matrix distributed on many processors
integer function, public cp_fm_indxl2g(INDXLOC, NB, IPROC, ISRCPROC, NPROCS)
wrapper to scalapack function INDXL2G that computes the global index of a distributed matrix entry po...
integer function, public cp_fm_indxg2l(INDXGLOB, NB, IPROC, ISRCPROC, NPROCS)
wrapper to scalapack function INDXG2L that computes the local index of a distributed matrix entry poi...
subroutine, public cp_fm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, nrow_locals, ncol_locals, matrix_struct, para_env)
returns all kind of information about the full matrix
integer function, public cp_fm_indxg2p(INDXGLOB, NB, IPROC, ISRCPROC, NPROCS)
wrapper to scalapack function INDXG2P that computes the process coordinate which possesses the entry ...
subroutine, public cp_fm_to_fm_submat(msource, mtarget, nrow, ncol, s_firstrow, s_firstcol, t_firstrow, t_firstcol)
copy just a part ot the matrix
subroutine, public cp_fm_set_all(matrix, alpha, beta)
set all elements of a matrix to the same value, and optionally the diagonal to a different one
subroutine, public cp_fm_create(matrix, matrix_struct, name, use_sp)
creates a new full matrix with the given structure
Defines the basic variable types.
integer, parameter, public dp
2- and 3-center electron repulsion integral routines based on libint2 Currently available operators: ...
pure logical function, public compare_potential_types(potential1, potential2)
Helper function to compare libint_potential_types.
Interface to the message passing library MPI.
subroutine, public mp_para_env_release(para_env)
releases the para object (to be called when you don't want anymore the shared copy of this object)
type(mp_request_type), parameter, public mp_request_null
Routines to calculate 2c- and 3c-integrals for RI with GPW.
subroutine, public cleanup_gpw(qs_env, e_cutoff_old, cutoff_old, relative_cutoff_old, para_env_sub, pw_env_sub, task_list_sub, auxbas_pw_pool, rho_r, rho_g, pot_g, psi_L)
Cleanup GPW integration for RI-MP2/RI-RPA.
subroutine, public integrate_potential_forces_3c_1c(mat_munu, rho_r, matrix_P_munu, qs_env, pw_env_sub, task_list_sub)
Takes the precomputed potential of an RI wave-function and determines matrix element and gradients wi...
subroutine, public integrate_potential_forces_2c(rho_r, LLL, matrix, rho_g, atomic_kind_set, qs_kind_set, particle_set, cell, pw_env_sub, poisson_env, pot_g, potential_parameter, use_virial, rho_g_copy, dvg, kind_of, atom_of_kind, G_PQ_local, force, h_stress, para_env_sub, dft_control, psi_L, factor)
Integrates the potential of a RI function obtaining the forces and stress tensor.
subroutine, public integrate_potential_forces_3c_2c(matrix_P_munu, rho_r, rho_g, task_list_sub, pw_env_sub, potential_parameter, ks_env, poisson_env, pot_g, use_virial, rho_g_copy, dvg, h_stress, para_env_sub, kind_of, atom_of_kind, qs_kind_set, particle_set, cell, LLL, force, dft_control)
Integrates potential of two Gaussians to a potential.
subroutine, public prepare_gpw(qs_env, dft_control, e_cutoff_old, cutoff_old, relative_cutoff_old, para_env_sub, pw_env_sub, auxbas_pw_pool, poisson_env, task_list_sub, rho_r, rho_g, pot_g, psi_L, sab_orb_sub)
Prepares GPW calculation for RI-MP2/RI-RPA.
Interface to direct methods for electron repulsion integrals for MP2.
subroutine, public mp2_eri_2c_integrate(param, potential_parameter, para_env, qs_env, basis_type_a, basis_type_b, hab, first_b, last_b, eri_method, pab, force_a, force_b, hdab, hadb, reflection_z_a, reflection_z_b, do_reflection_a, do_reflection_b)
high-level integration routine for 2c integrals over CP2K basis sets. Contiguous column-wise distribu...
subroutine, public mp2_eri_3c_integrate(param, potential_parameter, para_env, qs_env, first_c, last_c, mat_ab, basis_type_a, basis_type_b, basis_type_c, sab_nl, eri_method, pabc, force_a, force_b, force_c, mat_dabc, mat_adbc, mat_abdc)
high-level integration routine for 3c integrals (ab|c) over CP2K basis sets. For each local function ...
pure subroutine, public mp2_eri_deallocate_forces(force)
...
Routines to calculate gradients of RI-GPW-MP2 energy using pw.
subroutine, public calc_ri_mp2_nonsep(qs_env, mp2_env, para_env, para_env_sub, cell, particle_set, atomic_kind_set, qs_kind_set, mo_coeff, nmo, homo, dimen_RI, Eigenval, my_group_L_start, my_group_L_end, my_group_L_size, sab_orb_sub, mat_munu, blacs_env_sub)
Calculate the non-separable part of the gradients and update the Lagrangian.
Types needed for MP2 calculations.
basic linear algebra operations for full matrixes
Define the data structure for the particle information.
container for various plainwaves related things
functions related to the poisson solver on regular grids
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
subroutine, public get_qs_env(qs_env, atomic_kind_set, qs_kind_set, cell, super_cell, cell_ref, use_ref_cell, kpoints, dft_control, mos, sab_orb, sab_all, qmmm, qmmm_periodic, sac_ae, sac_ppl, sac_lri, sap_ppnl, sab_vdw, sab_scp, sap_oce, sab_lrc, sab_se, sab_xtbe, sab_tbe, sab_core, sab_xb, sab_xtb_nonbond, sab_almo, sab_kp, sab_kp_nosym, particle_set, energy, force, matrix_h, matrix_h_im, matrix_ks, matrix_ks_im, matrix_vxc, run_rtp, rtp, matrix_h_kp, matrix_h_im_kp, matrix_ks_kp, matrix_ks_im_kp, matrix_vxc_kp, kinetic_kp, matrix_s_kp, matrix_w_kp, matrix_s_RI_aux_kp, matrix_s, matrix_s_RI_aux, matrix_w, matrix_p_mp2, matrix_p_mp2_admm, rho, rho_xc, pw_env, ewald_env, ewald_pw, active_space, mpools, input, para_env, blacs_env, scf_control, rel_control, kinetic, qs_charges, vppl, rho_core, rho_nlcc, rho_nlcc_g, ks_env, ks_qmmm_env, wf_history, scf_env, local_particles, local_molecules, distribution_2d, dbcsr_dist, molecule_kind_set, molecule_set, subsys, cp_subsys, oce, local_rho_set, rho_atom_set, task_list, task_list_soft, rho0_atom_set, rho0_mpole, rhoz_set, ecoul_1c, rho0_s_rs, rho0_s_gs, do_kpoints, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, nkind, natom, nelectron_total, nelectron_spin, efield, neighbor_list_id, linres_control, xas_env, virial, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, results, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, lri_env, lri_density, exstate_env, ec_env, dispersion_env, gcp_env, vee, rho_external, external_vxc, mask, mp2_env, bs_env, kg_env, WannierCentres, atprop, ls_scf_env, do_transport, transport_env, v_hartree_rspace, s_mstruct_changed, rho_changed, potential_changed, forces_up_to_date, mscfg_env, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, rhs)
Get the QUICKSTEP environment.
subroutine, public zero_qs_force(qs_force)
Initialize a Quickstep force data structure.
subroutine, public allocate_qs_force(qs_force, natom_of_kind)
Allocate a Quickstep force data structure.
Define the quickstep kind type and their sub types.
Define the neighbor list data types and the corresponding functionality.
All kind of helpful little routines.
pure integer function, dimension(2), public get_limit(m, n, me)
divide m entries into n parts, return size of part me