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
58 INTEGER,
INTENT(IN) :: nspin
59 INTEGER,
DIMENSION(:),
INTENT(IN) :: nelectron_spin
60 INTEGER,
INTENT(IN) :: ounit
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
73 TYPE(dbcsr_iterator_type) :: iter
74 TYPE(dbcsr_type),
POINTER :: matrix_p
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)
subroutine, public calculate_atomic_orbitals(atomic_kind, qs_kind, agrid, iunit, pmat, fmat, density, wavefunction, wfninfo, confine, xc_section, nocc)
...
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.
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.