Skip to content

Commit

Permalink
Fix cp_fm_struct_double. Add missing INTENT statements
Browse files Browse the repository at this point in the history
  • Loading branch information
@schulkov
schulkov committed Dec 21, 2019
1 parent 2e6b691 commit e635599
Show file tree
Hide file tree
Showing 8 changed files with 66 additions and 26 deletions.
8 changes: 4 additions & 4 deletions src/efield_tb_methods.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -73,7 +73,7 @@ SUBROUTINE efield_tb_matrix(qs_env, ks_matrix, rho, mcharge, energy, calculate_f
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down Expand Up @@ -121,7 +121,7 @@ SUBROUTINE efield_tb_local(qs_env, ks_matrix, rho, mcharge, energy, calculate_fo
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down Expand Up @@ -270,7 +270,7 @@ SUBROUTINE efield_tb_berry(qs_env, ks_matrix, rho, mcharge, energy, calculate_fo
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down Expand Up @@ -522,7 +522,7 @@ SUBROUTINE dfield_tb_berry(qs_env, ks_matrix, rho, mcharge, energy, calculate_fo
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down
3 changes: 1 addition & 2 deletions src/emd/rt_propagation_methods.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -741,7 +741,7 @@ SUBROUTINE aspc_extrapolate(rtp, matrix_s, aspc_order)
ncol_local=ncol_local)

CALL cp_fm_struct_create(matrix_struct_new, &
template_fmstruct=matrix_struct, &
template_fmstruct=mos_new(2*i)%matrix%matrix_struct, &
nrow_global=k, &
ncol_global=k)
CALL cp_cfm_create(csc, matrix_struct_new)
Expand All @@ -752,7 +752,6 @@ SUBROUTINE aspc_extrapolate(rtp, matrix_s, aspc_order)
! first the most recent

! reorthogonalize vectors

DO icol_local = 1, ncol_local
fm_tmp%local_data(:, icol_local) = mos_new(2*i - 1)%matrix%local_data(:, icol_local)
fm_tmp%local_data(:, icol_local + ncol_local) = mos_new(2*i)%matrix%local_data(:, icol_local)
Expand Down
2 changes: 1 addition & 1 deletion src/ewald_methods_tb.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -88,7 +88,7 @@ SUBROUTINE tb_spme_evaluate(ewald_env, ewald_pw, particle_set, box, &
TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_set
TYPE(cell_type), POINTER :: box
REAL(KIND=dp), DIMENSION(:, :), INTENT(inout) :: gmcharge
REAL(KIND=dp), DIMENSION(:), INTENT(inout) :: mcharge
REAL(KIND=dp), DIMENSION(:), INTENT(in) :: mcharge
LOGICAL, INTENT(in) :: calculate_forces
TYPE(virial_type), POINTER :: virial
LOGICAL, INTENT(in) :: use_virial
Expand Down
67 changes: 53 additions & 14 deletions src/fm/cp_fm_struct.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -559,13 +559,14 @@ END SUBROUTINE cp_fm_struct_write_info
SUBROUTINE cp_fm_struct_double(fmstruct, struct, context, col, row)
TYPE(cp_fm_struct_type), POINTER :: fmstruct, struct
TYPE(cp_blacs_env_type), POINTER :: context
LOGICAL :: col, row
LOGICAL, INTENT(in) :: col, row

CHARACTER(len=*), PARAMETER :: routineN = 'cp_fm_struct_double', &
routineP = moduleN//':'//routineN

INTEGER :: nblocks, ncol_block, ncol_global, nempty, newdim_col, newdim_row, nfilled, &
nprocs_col, nprocs_row, nrow_block, nrow_global
INTEGER :: n_doubled_items_in_partially_filled_block, ncol_block, ncol_global, newdim_col, &
newdim_row, nfilled_blocks, nfilled_blocks_remain, nprocs_col, nprocs_row, nrow_block, &
nrow_global
TYPE(cp_para_env_type), POINTER :: para_env

CALL cp_fm_struct_get(struct, nrow_global=nrow_global, &
Expand All @@ -581,32 +582,70 @@ SUBROUTINE cp_fm_struct_double(fmstruct, struct, context, col, row)
IF (ncol_global == 0) THEN
newdim_col = 0
ELSE
!Divide ncol_global by ncol_block and round up
nblocks = (ncol_global + ncol_block - 1)/ncol_block
nfilled = MOD(nblocks, nprocs_col)
nempty = MOD(nprocs_col - nfilled, nprocs_col)
newdim_col = 2*ncol_global + 2*nempty*ncol_block + 2*MOD(ncol_block - MOD(ncol_global, ncol_block), ncol_block)
! ncol_block nfilled_blocks_remain * ncol_block
! |<--->| |<--->|
! |-----|-----|-----|-----|---|
! | 0 | 1 | 2 | 0 | 1 | <- context%mepos(2)
! |-----|-----|-----|-----|---|
! |<--- nfilled_blocks -->|<-> -- items (columns) in partially filled blocks
! | * ncol_block |
n_doubled_items_in_partially_filled_block = 2*MOD(ncol_global, ncol_block)
nfilled_blocks = ncol_global/ncol_block
nfilled_blocks_remain = MOD(nfilled_blocks, nprocs_col)
newdim_col = 2*(nfilled_blocks/nprocs_col)
IF (n_doubled_items_in_partially_filled_block > ncol_block) THEN
! doubled number of columns in a partially filled block does not fit into a single block.
! Due to cyclic distribution of ScaLAPACK blocks, an extra block for each core needs to be added
! |-----|-----|-----|----| |-----|-----|-----|-----|-----|-----|-----|-----|-----|---|
! | 0 | 1 | 2 | 0 | --> | 0 | 1 | 2 | 0 | 1 | 2 | 0 | 1 | 2 | 0|
! |-----|-----|-----|----| |-----|-----|-----|-----|-----|-----|-----|-----|-----|---|
! a a a b a1 a1 a1 a2 a2 a2 b1 empty empty b2
newdim_col = newdim_col + 1

! the number of columns which does not fit into the added extra block
n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - ncol_block
ELSE IF (nfilled_blocks_remain > 0) THEN
! |-----|-----|-----|-----|--| |-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|
! | 0 | 1 | 2 | 0 | 1| -> | 0 | 1 | 2 | 0 | 1 | 2 | 0 | 1 | 2 | 0 |
! |-----|-----|-----|-----|--| |-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|
! a a a b b a1 a1 a1 a2 a2 a2 b1 b1 b2 empty b2
newdim_col = newdim_col + 1
n_doubled_items_in_partially_filled_block = 0
END IF

newdim_col = (newdim_col*nprocs_col + nfilled_blocks_remain)*ncol_block + n_doubled_items_in_partially_filled_block
END IF
END IF

IF (row) THEN
IF (nrow_global == 0) THEN
newdim_row = 0
ELSE
!Divide nrow_global by nrow_block and round up
nblocks = (nrow_global + nrow_block - 1)/nrow_block
nfilled = MOD(nblocks, nprocs_row)
nempty = MOD(nprocs_row - nfilled, nprocs_row)
newdim_row = 2*nrow_global + 2*nempty*nrow_block + 2*MOD(nrow_block - MOD(nrow_global, nrow_block), nrow_block)
n_doubled_items_in_partially_filled_block = 2*MOD(nrow_global, nrow_block)
nfilled_blocks = nrow_global/nrow_block
nfilled_blocks_remain = MOD(nfilled_blocks, nprocs_row)
newdim_row = 2*(nfilled_blocks/nprocs_row)
IF (n_doubled_items_in_partially_filled_block > nrow_block) THEN
newdim_row = newdim_row + 1
n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - nrow_block
ELSE IF (nfilled_blocks_remain > 0) THEN
newdim_row = newdim_row + 1
n_doubled_items_in_partially_filled_block = 0
END IF

newdim_row = (newdim_row*nprocs_row + nfilled_blocks_remain)*nrow_block + n_doubled_items_in_partially_filled_block
END IF
END IF

! square_blocks=.FALSE. ensures that matrix blocks of the doubled matrix will have
! nrow_block x ncol_block shape even in case of a square doubled matrix
CALL cp_fm_struct_create(fmstruct=fmstruct, para_env=para_env, &
context=context, &
nrow_global=newdim_row, &
ncol_global=newdim_col, &
ncol_block=ncol_block, &
nrow_block=nrow_block)
nrow_block=nrow_block, &
square_blocks=.FALSE.)

END SUBROUTINE cp_fm_struct_double
! **************************************************************************************************
Expand Down
4 changes: 2 additions & 2 deletions src/qs_dftb3_methods.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,9 +74,9 @@ SUBROUTINE build_dftb3_diagonal(qs_env, ks_matrix, rho, mcharge, energy, xgamma,
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
REAL(dp), DIMENSION(:) :: xgamma, zeff
REAL(dp), DIMENSION(:), INTENT(in) :: xgamma, zeff
TYPE(sap_int_type), DIMENSION(:), POINTER :: sap_int
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down
2 changes: 2 additions & 0 deletions src/qs_dispersion_pairpot.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -900,6 +900,8 @@ SUBROUTINE calculate_dispersion_pairpot(qs_env, dispersion_env, energy, calculat
TYPE(virial_type), POINTER :: virial

energy = 0._dp
! make valgrind happy
use_virial = .FALSE.

IF (dispersion_env%type .NE. xc_vdw_fun_pairpot) THEN
RETURN
Expand Down
4 changes: 2 additions & 2 deletions src/xtb_coulomb.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -102,8 +102,8 @@ SUBROUTINE build_xtb_coulomb(qs_env, ks_matrix, rho, charges, mcharge, energy, &
TYPE(qs_environment_type), POINTER :: qs_env
TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
TYPE(qs_rho_type), POINTER :: rho
REAL(dp), DIMENSION(:, :) :: charges
REAL(dp), DIMENSION(:) :: mcharge
REAL(dp), DIMENSION(:, :), INTENT(in) :: charges
REAL(dp), DIMENSION(:), INTENT(in) :: mcharge
TYPE(qs_energy_type), POINTER :: energy
LOGICAL, INTENT(in) :: calculate_forces, just_energy

Expand Down
2 changes: 1 addition & 1 deletion src/xtb_matrices.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1031,7 +1031,7 @@ SUBROUTINE build_xtb_ks_matrix(qs_env, calculate_forces, just_energy)
ELSE
p_matrix => matrix_p(:, 1)
s_matrix => matrix_s(1, 1)%matrix
CALL ao_charges(matrix_p, matrix_s, aocg, para_env)
CALL ao_charges(p_matrix, s_matrix, aocg, para_env)
END IF
DO ikind = 1, nkind
CALL get_atomic_kind(atomic_kind_set(ikind), natom=na)
Expand Down

0 comments on commit e635599

Please sign in to comment.