18 USE dbcsr_api,
ONLY: &
19 dbcsr_add_on_diag, dbcsr_dot, dbcsr_get_info, dbcsr_iterator_blocks_left, &
20 dbcsr_iterator_next_block, dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, &
21 dbcsr_p_type, dbcsr_scale, dbcsr_set, dbcsr_type
25 #include "./base/base_uses.f90"
31 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'qs_atomic_block'
36 REAL(KIND=
dp),
DIMENSION(:, :, :),
POINTER :: mat
37 END TYPE atom_matrix_type
53 qs_kind_set, nspin, nelectron_spin, ounit, para_env)
54 TYPE(dbcsr_p_type),
DIMENSION(:),
INTENT(INOUT) :: pmatrix
55 TYPE(dbcsr_type),
INTENT(INOUT) :: matrix_s
56 TYPE(atomic_kind_type),
DIMENSION(:),
POINTER :: atomic_kind_set
57 TYPE(qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
58 INTEGER,
INTENT(IN) :: nspin
59 INTEGER,
DIMENSION(:),
INTENT(IN) :: nelectron_spin
60 INTEGER,
INTENT(IN) :: ounit
61 TYPE(mp_para_env_type) :: para_env
63 CHARACTER(LEN=*),
PARAMETER :: routinen =
'calculate_atomic_block_dm'
65 INTEGER :: blk, handle, icol, ikind, irow, ispin, &
67 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: kind_of
68 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: nok
69 REAL(
dp),
DIMENSION(:, :),
POINTER :: pdata
70 REAL(kind=
dp) :: rds, rscale, trps1
71 TYPE(atom_matrix_type),
ALLOCATABLE,
DIMENSION(:) :: pmat
72 TYPE(atomic_kind_type),
POINTER :: atomic_kind
73 TYPE(dbcsr_iterator_type) :: iter
74 TYPE(dbcsr_type),
POINTER :: matrix_p
75 TYPE(qs_kind_type),
POINTER :: qs_kind
77 CALL timeset(routinen, handle)
79 nkind =
SIZE(atomic_kind_set)
81 ALLOCATE (pmat(nkind))
82 ALLOCATE (nok(2, nkind))
86 atomic_kind => atomic_kind_set(ikind)
87 qs_kind => qs_kind_set(ikind)
88 NULLIFY (pmat(ikind)%mat)
90 WRITE (unit=ounit, fmt=
"(/,T2,A)") &
91 "Guess for atomic kind: "//trim(atomic_kind%name)
94 pmat=pmat(ikind)%mat, nocc=nocc)
95 nok(1:2, ikind) = nocc(1:2)
99 IF (nspin == 2) rscale = 0.5_dp
102 IF ((ounit > 0) .AND. (nspin > 1))
THEN
103 WRITE (unit=ounit, fmt=
"(/,T2,A,I0)")
"Spin ", ispin
106 matrix_p => pmatrix(ispin)%matrix
107 CALL dbcsr_set(matrix_p, 0.0_dp)
110 CALL dbcsr_iterator_start(iter, matrix_p)
111 DO WHILE (dbcsr_iterator_blocks_left(iter))
112 CALL dbcsr_iterator_next_block(iter, irow, icol, pdata, blk)
113 ikind = kind_of(irow)
114 IF (icol .EQ. irow)
THEN
116 pdata(:, :) = pmat(ikind)%mat(:, :, 1)*rscale + &
117 pmat(ikind)%mat(:, :, 2)*rscale
119 pdata(:, :) = pmat(ikind)%mat(:, :, 1)*rscale - &
120 pmat(ikind)%mat(:, :, 2)*rscale
122 nocc(ispin) = nocc(ispin) + nok(ispin, ikind)
125 CALL dbcsr_iterator_stop(iter)
127 CALL dbcsr_dot(matrix_p, matrix_s, trps1)
130 IF (nelectron_spin(ispin) > 0)
THEN
131 rds = real(nelectron_spin(ispin),
dp)/trps1
133 CALL dbcsr_scale(matrix_p, rds)
137 WRITE (unit=ounit, fmt=
"(T2,A,I1)") &
138 "Re-scaling the density matrix to get the right number of electrons for spin ", ispin
140 WRITE (unit=ounit, fmt=
"(T2,A)") &
141 "Re-scaling the density matrix to get the right number of electrons"
143 WRITE (ounit,
'(T19,A,T44,A,T67,A)')
"# Electrons",
"Trace(P)",
"Scaling factor"
144 WRITE (ounit,
'(T20,I10,T40,F12.3,T67,F14.3)') nelectron_spin(ispin), trps1, rds
148 CALL para_env%sum(nocc)
149 IF (nelectron_spin(ispin) > nocc(ispin))
THEN
151 CALL dbcsr_scale(matrix_p, rds)
152 rds = (1.0_dp - rds)*nelectron_spin(ispin)
153 CALL dbcsr_get_info(matrix_p, nfullcols_total=nc)
154 rds = rds/real(nc, kind=
dp)
155 CALL dbcsr_add_on_diag(matrix_p, rds)
157 WRITE (unit=ounit, fmt=
"(T4,A,/,T4,A,T59,F20.12)") &
158 "More MOs than initial guess orbitals detected", &
159 "Add constant to diagonal elements ", rds
167 IF (
ASSOCIATED(pmat(ikind)%mat))
THEN
168 DEALLOCATE (pmat(ikind)%mat)
173 DEALLOCATE (kind_of, nok)
175 CALL timestop(handle)
calculate the orbitals for a given atomic kind type
subroutine, public calculate_atomic_orbitals(atomic_kind, qs_kind, agrid, iunit, pmat, fmat, density, wavefunction, wfninfo, confine, xc_section, nocc)
...
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.
Defines the basic variable types.
integer, parameter, public dp
Interface to the message passing library MPI.
Routine to return block diagonal density matrix. Blocks correspond to the atomic densities.
subroutine, public calculate_atomic_block_dm(pmatrix, matrix_s, atomic_kind_set, qs_kind_set, nspin, nelectron_spin, ounit, para_env)
returns a block diagonal density matrix. Blocks correspond to the atomic densities.
Define the quickstep kind type and their sub types.