1!--------------------------------------------------------------------------------------------------!
2!   CP2K: A general program to perform molecular dynamics simulations                              !
3!   Copyright (C) 2000 - 2019  CP2K developers group                                               !
4!--------------------------------------------------------------------------------------------------!
5
6! **************************************************************************************************
7!> \brief Types used to generate the molecular SCF guess
8!> \par History
9!>       10.2014 created [Rustam Z Khaliullin]
10!> \author Rustam Z Khaliullin
11! **************************************************************************************************
12MODULE mscfg_types
13   USE dbcsr_api,                       ONLY: &
14        dbcsr_add, dbcsr_complete_redistribute, dbcsr_create, dbcsr_distribution_get, &
15        dbcsr_distribution_new, dbcsr_distribution_release, dbcsr_distribution_type, &
16        dbcsr_finalize, dbcsr_get_info, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, &
17        dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_nfullcols_total, &
18        dbcsr_nfullrows_total, dbcsr_release, dbcsr_reserve_block2d, dbcsr_set, dbcsr_type, &
19        dbcsr_type_no_symmetry, dbcsr_work_create
20   USE kinds,                           ONLY: dp
21#include "./base/base_uses.f90"
22
23   IMPLICIT NONE
24
25   PRIVATE
26
27   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mscfg_types'
28
29   INTEGER, PARAMETER, PUBLIC               :: mscfg_max_moset_size = 2
30
31   ! Public types
32   PUBLIC :: molecular_scf_guess_env_type
33
34   ! Public subroutines
35   PUBLIC :: molecular_scf_guess_env_init, &
36             molecular_scf_guess_env_destroy, &
37             get_matrix_from_submatrices
38
39   ! Contains data pertaining to molecular_scf_guess calculations
40   TYPE molecular_scf_guess_env_type
41
42      ! Useful flags to pass around
43      LOGICAL                                           :: is_fast_dirty, &
44                                                           is_crystal
45
46      ! Real data
47      INTEGER                                           :: nfrags
48      REAL(KIND=dp), DIMENSION(:), ALLOCATABLE          :: energy_of_frag
49      INTEGER, DIMENSION(:), ALLOCATABLE                :: nmosets_of_frag
50      TYPE(dbcsr_type), DIMENSION(:, :), ALLOCATABLE  :: mos_of_frag
51
52   END TYPE
53
54CONTAINS
55
56! **************************************************************************************************
57!> \brief Allocates data
58!> \param env ...
59!> \param nfrags   number of entries
60!> \par History
61!>       2014.10 created [Rustam Z Khaliullin]
62!> \author Rustam Z Khaliullin
63! **************************************************************************************************
64   SUBROUTINE molecular_scf_guess_env_init(env, nfrags)
65
66      TYPE(molecular_scf_guess_env_type)                 :: env
67      INTEGER, INTENT(IN)                                :: nfrags
68
69      CHARACTER(len=*), PARAMETER :: routineN = 'molecular_scf_guess_env_init', &
70         routineP = moduleN//':'//routineN
71
72! check if the number of fragments is already set
73!IF (env%nfrags.ne.0) THEN
74!   ! do not allow re-initialization
75!   ! to prevent recursive calls
76!   CPPostcondition(.FALSE.,cp_failure_level,routineP,failure)
77!ENDIF
78
79      env%nfrags = nfrags
80      IF (nfrags .GT. 0) THEN
81         ALLOCATE (env%energy_of_frag(nfrags))
82         ALLOCATE (env%nmosets_of_frag(nfrags))
83         ALLOCATE (env%mos_of_frag(nfrags, mscfg_max_moset_size))
84      ENDIF
85
86   END SUBROUTINE molecular_scf_guess_env_init
87
88! **************************************************************************************************
89!> \brief Destroyes both data and environment
90!> \param env ...
91!> \par History
92!>       2014.10 created [Rustam Z Khaliullin]
93!> \author Rustam Z Khaliullin
94! **************************************************************************************************
95   SUBROUTINE molecular_scf_guess_env_destroy(env)
96
97      TYPE(molecular_scf_guess_env_type)                 :: env
98
99      CHARACTER(len=*), PARAMETER :: routineN = 'molecular_scf_guess_env_destroy', &
100         routineP = moduleN//':'//routineN
101
102      INTEGER                                            :: ifrag, jfrag
103
104      IF (ALLOCATED(env%mos_of_frag)) THEN
105         DO ifrag = 1, SIZE(env%mos_of_frag, 1)
106            DO jfrag = 1, env%nmosets_of_frag(ifrag)
107               CALL dbcsr_release(env%mos_of_frag(ifrag, jfrag))
108            ENDDO
109         ENDDO
110         DEALLOCATE (env%mos_of_frag)
111      ENDIF
112      IF (ALLOCATED(env%energy_of_frag)) DEALLOCATE (env%energy_of_frag)
113      IF (ALLOCATED(env%nmosets_of_frag)) DEALLOCATE (env%nmosets_of_frag)
114
115      env%nfrags = 0
116
117   END SUBROUTINE molecular_scf_guess_env_destroy
118
119! **************************************************************************************************
120!> \brief Creates a distributed matrix from MOs on fragments
121!> \param mscfg_env   env containing MOs of fragments
122!> \param matrix_out   all existing blocks will be deleted!
123!> \param iset   which set of MOs in mscfg_env has to be converted (e.g. spin)
124!> \par History
125!>       10.2014 created [Rustam Z Khaliullin]
126!> \author Rustam Z Khaliullin
127! **************************************************************************************************
128   SUBROUTINE get_matrix_from_submatrices(mscfg_env, matrix_out, iset)
129
130      TYPE(molecular_scf_guess_env_type), INTENT(IN)     :: mscfg_env
131      TYPE(dbcsr_type), INTENT(INOUT)                    :: matrix_out
132      INTEGER, INTENT(IN)                                :: iset
133
134      CHARACTER(len=*), PARAMETER :: routineN = 'get_matrix_from_submatrices', &
135         routineP = moduleN//':'//routineN
136
137      INTEGER                                            :: handle, ifrag
138      INTEGER, DIMENSION(2)                              :: matrix_size, offset, submatrix_size
139      TYPE(dbcsr_type)                                   :: matrix_temp
140
141      CALL timeset(routineN, handle)
142
143      CPASSERT(iset .LE. mscfg_max_moset_size)
144
145      CALL dbcsr_create(matrix_temp, &
146                        template=matrix_out, &
147                        matrix_type=dbcsr_type_no_symmetry)
148      CALL dbcsr_set(matrix_out, 0.0_dp)
149
150      matrix_size(1) = dbcsr_nfullrows_total(matrix_out)
151      matrix_size(2) = dbcsr_nfullcols_total(matrix_out)
152
153      ! assume that the initial offset is zero
154      offset(1) = 0
155      offset(2) = 0
156
157      DO ifrag = 1, mscfg_env%nfrags
158
159         CPASSERT(iset .LE. mscfg_env%nmosets_of_frag(ifrag))
160
161         submatrix_size(1) = dbcsr_nfullrows_total(mscfg_env%mos_of_frag(ifrag, iset))
162         submatrix_size(2) = dbcsr_nfullcols_total(mscfg_env%mos_of_frag(ifrag, iset))
163
164         CALL copy_submatrix_into_matrix(mscfg_env%mos_of_frag(ifrag, iset), &
165                                         matrix_temp, offset, submatrix_size, matrix_size)
166
167         CALL dbcsr_add(matrix_out, matrix_temp, 1.0_dp, 1.0_dp)
168
169         offset(1) = offset(1) + submatrix_size(1)
170         offset(2) = offset(2) + submatrix_size(2)
171
172      ENDDO
173
174      ! Check that the accumulated size of submatrices
175      ! is exactly the same as the size of the big matrix
176      ! This is to prevent unexpected conversion errors
177      ! If however such conversion is intended - remove these safeguards
178      CPASSERT(offset(1) .EQ. matrix_size(1))
179      CPASSERT(offset(2) .EQ. matrix_size(2))
180
181      CALL dbcsr_release(matrix_temp)
182
183      CALL timestop(handle)
184
185   END SUBROUTINE get_matrix_from_submatrices
186
187! **************************************************************************************************
188!> \brief Copies a distributed dbcsr submatrix into a distributed dbcsr matrix
189!> \param submatrix_in ...
190!> \param matrix_out   all existing blocks will be deleted!
191!> \param offset ...
192!> \param submatrix_size ...
193!> \param matrix_size ...
194!> \par History
195!>       10.2014 created [Rustam Z Khaliullin]
196!> \author Rustam Z Khaliullin
197! **************************************************************************************************
198   SUBROUTINE copy_submatrix_into_matrix(submatrix_in, matrix_out, &
199                                         offset, submatrix_size, matrix_size)
200
201      TYPE(dbcsr_type), INTENT(IN)                       :: submatrix_in
202      TYPE(dbcsr_type), INTENT(INOUT)                    :: matrix_out
203      INTEGER, DIMENSION(2), INTENT(IN)                  :: offset, submatrix_size, matrix_size
204
205      CHARACTER(len=*), PARAMETER :: routineN = 'copy_submatrix_into_matrix', &
206         routineP = moduleN//':'//routineN
207
208      INTEGER                                            :: add_blocks_after, dimen, iblock_col, &
209                                                            iblock_row, iblock_size, nblocks, &
210                                                            nblocks_new, start_index, trailing_size
211      INTEGER, DIMENSION(2)                              :: add_blocks_before
212      INTEGER, DIMENSION(:), POINTER :: blk_distr, blk_sizes, block_sizes_new, col_distr_new, &
213         col_sizes_new, distr_new_array, row_distr_new, row_sizes_new
214      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: data_p, p_new_block
215      TYPE(dbcsr_distribution_type)                      :: dist_new, dist_qs
216      TYPE(dbcsr_iterator_type)                          :: iter
217      TYPE(dbcsr_type)                                   :: matrix_new
218
219! obtain distribution of the submatrix
220
221      CALL dbcsr_get_info(submatrix_in, distribution=dist_qs)
222
223      DO dimen = 1, 2 ! 1 - row, 2 - column dimension
224
225         add_blocks_before(dimen) = 0
226         add_blocks_after = 0
227         start_index = 1
228         trailing_size = matrix_size(dimen) - offset(dimen) - submatrix_size(dimen)
229         IF (offset(dimen) .GT. 0) THEN
230            add_blocks_before(dimen) = add_blocks_before(dimen) + 1
231            start_index = 2
232         ENDIF
233         IF (trailing_size .GT. 0) THEN
234            add_blocks_after = add_blocks_after + 1
235         ENDIF
236
237         IF (dimen == 1) THEN !rows
238            CALL dbcsr_distribution_get(dist_qs, row_dist=blk_distr)
239            CALL dbcsr_get_info(submatrix_in, row_blk_size=blk_sizes)
240         ELSE !columns
241            CALL dbcsr_distribution_get(dist_qs, col_dist=blk_distr)
242            CALL dbcsr_get_info(submatrix_in, col_blk_size=blk_sizes)
243         ENDIF
244         nblocks = SIZE(blk_sizes) ! number of blocks in the small matrix
245
246         nblocks_new = nblocks + add_blocks_before(dimen) + add_blocks_after
247         ALLOCATE (block_sizes_new(nblocks_new))
248         ALLOCATE (distr_new_array(nblocks_new))
249         !IF (ASSOCIATED(cluster_distr)) THEN
250         !ALLOCATE (cluster_distr_new(nblocks_new))
251         !END IF
252         IF (add_blocks_before(dimen) .GT. 0) THEN
253            block_sizes_new(1) = offset(dimen)
254            distr_new_array(1) = 0
255            !IF (ASSOCIATED(cluster_distr)) THEN
256            !cluster_distr_new(1) = 0
257            !END IF
258         ENDIF
259         block_sizes_new(start_index:nblocks + start_index - 1) = blk_sizes(1:nblocks)
260         distr_new_array(start_index:nblocks + start_index - 1) = blk_distr(1:nblocks)
261         !IF (ASSOCIATED(cluster_distr)) THEN
262         !cluster_distr_new(start_index:nblocks+start_index-1) = cluster_distr(1:nblocks)
263         !END IF
264         IF (add_blocks_after .GT. 0) THEN
265            block_sizes_new(nblocks_new) = trailing_size
266            distr_new_array(nblocks_new) = 0
267            !IF (ASSOCIATED(cluster_distr)) THEN
268            !cluster_distr_new(nblocks_new) = 0
269            !END IF
270         ENDIF
271
272         ! create final arrays
273         IF (dimen == 1) THEN !rows
274            row_sizes_new => block_sizes_new
275            row_distr_new => distr_new_array
276            !row_cluster_new => cluster_distr_new
277         ELSE !columns
278            col_sizes_new => block_sizes_new
279            col_distr_new => distr_new_array
280            !col_cluster_new => cluster_distr_new
281         ENDIF
282      ENDDO ! both rows and columns are done
283
284      ! Create the distribution
285      CALL dbcsr_distribution_new(dist_new, template=dist_qs, &
286                                  row_dist=row_distr_new, col_dist=col_distr_new, &
287                                  !row_cluster=row_cluster_new, col_cluster=col_cluster_new, &
288                                  reuse_arrays=.TRUE.)
289
290      ! Create big the matrix
291      CALL dbcsr_create(matrix_new, "BIG_AND_FAKE", &
292                        dist_new, dbcsr_type_no_symmetry, &
293                        row_sizes_new, col_sizes_new, &
294                        reuse_arrays=.TRUE.)
295      CALL dbcsr_distribution_release(dist_new)
296
297      !CALL dbcsr_finalize(matrix_new)
298
299      ! copy blocks of the small matrix to the big matrix
300      !mynode = dbcsr_mp_mynode(dbcsr_distribution_mp(dbcsr_distribution(matrix_new)))
301      CALL dbcsr_work_create(matrix_new, work_mutable=.TRUE.)
302
303      ! iterate over local blocks of the small matrix
304      CALL dbcsr_iterator_start(iter, submatrix_in)
305
306      DO WHILE (dbcsr_iterator_blocks_left(iter))
307
308         CALL dbcsr_iterator_next_block(iter, iblock_row, iblock_col, data_p, row_size=iblock_size)
309
310         ! it is important that distribution of the big matrix is the same as
311         ! that of the small matrix but has the same number of columns and rows
312         ! as the super-system matrix. this is necessary for complete redistribute
313         ! to work
314         NULLIFY (p_new_block)
315         CALL dbcsr_reserve_block2d(matrix_new, &
316                                    iblock_row + add_blocks_before(1), &
317                                    iblock_col + add_blocks_before(2), &
318                                    p_new_block)
319
320         CPASSERT(ASSOCIATED(p_new_block))
321         CPASSERT(SIZE(p_new_block, 1) .EQ. SIZE(data_p, 1))
322         CPASSERT(SIZE(p_new_block, 2) .EQ. SIZE(data_p, 2))
323
324         p_new_block(:, :) = data_p(:, :)
325
326      ENDDO
327      CALL dbcsr_iterator_stop(iter)
328
329      CALL dbcsr_finalize(matrix_new)
330
331      ! finally call complete redistribute to get the matrix of the entire system
332      CALL dbcsr_set(matrix_out, 0.0_dp)
333      CALL dbcsr_complete_redistribute(matrix_new, matrix_out)
334      CALL dbcsr_release(matrix_new)
335
336   END SUBROUTINE copy_submatrix_into_matrix
337
338END MODULE mscfg_types
339
340