Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief represent the structure of a full matrix
10 : !> \par History
11 : !> 08.2002 created [fawzi]
12 : !> \author Fawzi Mohamed
13 : ! **************************************************************************************************
14 : MODULE cp_fm_struct
15 : USE cp_blacs_env, ONLY: cp_blacs_env_release,&
16 : cp_blacs_env_type
17 : USE cp_log_handling, ONLY: cp_get_default_logger,&
18 : cp_logger_get_default_unit_nr,&
19 : cp_logger_type,&
20 : cp_to_string
21 : USE kinds, ONLY: dp
22 : USE machine, ONLY: m_flush
23 : USE message_passing, ONLY: mp_para_env_release,&
24 : mp_para_env_type
25 : #include "../base/base_uses.f90"
26 :
27 : IMPLICIT NONE
28 : PRIVATE
29 :
30 : LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE.
31 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_fm_struct'
32 :
33 : ! the default blacs block sizes
34 : ! consider using #ifdefs to give them the optimal values
35 : ! these can be changed using scf_control
36 : ! *** these are used by default
37 : INTEGER, PRIVATE :: optimal_blacs_col_block_size = 32
38 : INTEGER, PRIVATE :: optimal_blacs_row_block_size = 32
39 : LOGICAL, PRIVATE :: force_block_size = .FALSE.
40 :
41 : PUBLIC :: cp_fm_struct_type, cp_fm_struct_p_type
42 : PUBLIC :: cp_fm_struct_create, cp_fm_struct_retain, cp_fm_struct_release, &
43 : cp_fm_struct_equivalent, &
44 : cp_fm_struct_get, cp_fm_struct_double, cp_fm_struct_config, &
45 : cp_fm_struct_get_nrow_block, cp_fm_struct_get_ncol_block, &
46 : cp_fm_struct_write_info
47 :
48 : ! **************************************************************************************************
49 : !> \brief keeps the information about the structure of a full matrix
50 : !> \param para_env the parallel environment of the matrices with this structure
51 : !> \param context the blacs context (parallel environment for scalapack),
52 : !> should be compatible with para_env
53 : !> \param descriptor the scalapack descriptor of the matrices, when using
54 : !> scalapack (ncol_block=descriptor(6), ncol_global=descriptor(4),
55 : !> nrow_block=descriptor(5), nrow_global=descriptor(3))
56 : !> \param ncol_block number of columns of a scalapack block
57 : !> \param nrow_block number of rows of a scalapack block
58 : !> \param nrow_global number of rows of the matrix
59 : !> \param ncol_global number of rows
60 : !> \param first_p_pos position of the first processor (for scalapack)
61 : !> \param row_indices real (global) indices of the rows (defined only for
62 : !> the local rows really used)
63 : !> \param col_indices real (global) indices of the cols (defined only for
64 : !> the local cols really used)
65 : !> \param nrow_locals nrow_locals(i) number of local rows of the matrix really
66 : !> used on the processors with context%mepos(1)==i
67 : !> \param ncol_locals ncol_locals(i) number of local rows of the matrix really
68 : !> used on the processors with context%mepos(2)==i
69 : !> \param ref_count reference count (see doc/ReferenceCounting.html)
70 : !> \param local_leading_dimension leading dimension of the data that is
71 : !> stored on this processor
72 : !>
73 : !> readonly attributes:
74 : !> \param nrow_local number of local rows really used on the actual processor
75 : !> \param ncol_local number of local cols really used on the actual processor
76 : !> \note
77 : !> use cp_fm_struct_get to extract information from this structure
78 : !> \par History
79 : !> 08.2002 created [fawzi]
80 : !> \author Fawzi Mohamed
81 : ! **************************************************************************************************
82 : TYPE cp_fm_struct_type
83 : TYPE(mp_para_env_type), POINTER :: para_env => NULL()
84 : TYPE(cp_blacs_env_type), POINTER :: context => NULL()
85 : INTEGER, DIMENSION(9) :: descriptor = -1
86 : INTEGER :: nrow_block = -1, ncol_block = -1, nrow_global = -1, ncol_global = -1
87 : INTEGER, DIMENSION(2) :: first_p_pos = -1
88 : INTEGER, DIMENSION(:), POINTER :: row_indices => NULL(), col_indices => NULL(), &
89 : nrow_locals => NULL(), ncol_locals => NULL()
90 : INTEGER :: ref_count = -1, local_leading_dimension = -1
91 : END TYPE cp_fm_struct_type
92 : ! **************************************************************************************************
93 : TYPE cp_fm_struct_p_type
94 : TYPE(cp_fm_struct_type), POINTER :: struct => NULL()
95 : END TYPE cp_fm_struct_p_type
96 :
97 : CONTAINS
98 :
99 : ! **************************************************************************************************
100 : !> \brief allocates and initializes a full matrix structure
101 : !> \param fmstruct the pointer that will point to the new structure
102 : !> \param para_env the parallel environment
103 : !> \param context the blacs context of this matrix
104 : !> \param nrow_global the number of row of the full matrix
105 : !> \param ncol_global the number of columns of the full matrix
106 : !> \param nrow_block the number of rows of a block of the matrix,
107 : !> omit or set to -1 to use the built-in defaults
108 : !> \param ncol_block the number of columns of a block of the matrix,
109 : !> omit or set to -1 to use the built-in defaults
110 : !> \param descriptor the scalapack descriptor of the matrix (if not given
111 : !> a new one is allocated
112 : !> \param first_p_pos ...
113 : !> \param local_leading_dimension the leading dimension of the locally stored
114 : !> data block
115 : !> \param template_fmstruct a matrix structure where to take the default values
116 : !> \param square_blocks ...
117 : !> \param force_block ...
118 : !> \par History
119 : !> 08.2002 created [fawzi]
120 : !> \author Fawzi Mohamed
121 : ! **************************************************************************************************
122 455037 : SUBROUTINE cp_fm_struct_create(fmstruct, para_env, context, nrow_global, &
123 : ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, &
124 : local_leading_dimension, template_fmstruct, square_blocks, force_block)
125 :
126 : TYPE(cp_fm_struct_type), POINTER :: fmstruct
127 : TYPE(mp_para_env_type), TARGET, OPTIONAL :: para_env
128 : INTEGER, INTENT(in), OPTIONAL :: nrow_global, ncol_global
129 : INTEGER, INTENT(in), OPTIONAL :: nrow_block, ncol_block
130 : INTEGER, INTENT(in), OPTIONAL :: local_leading_dimension
131 : TYPE(cp_blacs_env_type), TARGET, OPTIONAL :: context
132 : INTEGER, DIMENSION(9), INTENT(in), OPTIONAL :: descriptor
133 : INTEGER, OPTIONAL, DIMENSION(2) :: first_p_pos
134 : TYPE(cp_fm_struct_type), POINTER, OPTIONAL :: template_fmstruct
135 : LOGICAL, OPTIONAL, INTENT(in) :: square_blocks
136 : LOGICAL, OPTIONAL, INTENT(in) :: force_block
137 :
138 : INTEGER :: dumblock
139 : #if defined(__SCALAPACK)
140 : INTEGER :: iunit, stat
141 : INTEGER, EXTERNAL :: numroc
142 : TYPE(cp_logger_type), POINTER :: logger
143 : #endif
144 :
145 : LOGICAL :: my_square_blocks, my_force_block
146 :
147 : #if defined(__parallel) && ! defined(__SCALAPACK)
148 : CPABORT("full matrices need scalapack for parallel runs ")
149 : #endif
150 :
151 6370518 : ALLOCATE (fmstruct)
152 :
153 455037 : fmstruct%nrow_block = optimal_blacs_row_block_size
154 455037 : fmstruct%ncol_block = optimal_blacs_col_block_size
155 :
156 455037 : IF (.NOT. PRESENT(template_fmstruct)) THEN
157 412501 : CPASSERT(PRESENT(context))
158 412501 : CPASSERT(PRESENT(nrow_global))
159 412501 : CPASSERT(PRESENT(ncol_global))
160 412501 : fmstruct%local_leading_dimension = 1
161 : ELSE
162 42536 : fmstruct%context => template_fmstruct%context
163 42536 : fmstruct%para_env => template_fmstruct%para_env
164 850720 : fmstruct%descriptor = template_fmstruct%descriptor
165 42536 : fmstruct%nrow_block = template_fmstruct%nrow_block
166 42536 : fmstruct%nrow_global = template_fmstruct%nrow_global
167 42536 : fmstruct%ncol_block = template_fmstruct%ncol_block
168 42536 : fmstruct%ncol_global = template_fmstruct%ncol_global
169 255216 : fmstruct%first_p_pos = template_fmstruct%first_p_pos
170 : fmstruct%local_leading_dimension = &
171 42536 : template_fmstruct%local_leading_dimension
172 : END IF
173 :
174 455037 : my_force_block = force_block_size
175 455037 : IF (PRESENT(force_block)) my_force_block = force_block
176 :
177 455037 : IF (PRESENT(context)) THEN
178 412501 : fmstruct%context => context
179 412501 : fmstruct%para_env => context%para_env
180 : END IF
181 455037 : IF (PRESENT(para_env)) fmstruct%para_env => para_env
182 455037 : CALL fmstruct%context%retain()
183 455037 : CALL fmstruct%para_env%retain()
184 :
185 455037 : IF (PRESENT(nrow_global)) THEN
186 452831 : fmstruct%nrow_global = nrow_global
187 452831 : fmstruct%local_leading_dimension = 1
188 : END IF
189 455037 : IF (PRESENT(ncol_global)) THEN
190 454807 : fmstruct%ncol_global = ncol_global
191 : END IF
192 :
193 : ! try to avoid small left-over blocks (anyway naive)
194 455037 : IF (PRESENT(nrow_block)) THEN
195 124929 : IF (nrow_block > 0) & ! allows setting the number of blocks to -1 to explicitly set to auto
196 71615 : fmstruct%nrow_block = nrow_block
197 : END IF
198 455037 : IF (.NOT. my_force_block) THEN
199 : dumblock = CEILING(REAL(fmstruct%nrow_global, KIND=dp)/ &
200 419161 : REAL(fmstruct%context%num_pe(1), KIND=dp))
201 419161 : fmstruct%nrow_block = MAX(1, MIN(fmstruct%nrow_block, dumblock))
202 : END IF
203 455037 : IF (PRESENT(ncol_block)) THEN
204 133209 : IF (ncol_block > 0) & ! allows setting the number of blocks to -1 to explicitly set to auto
205 79895 : fmstruct%ncol_block = ncol_block
206 : END IF
207 455037 : IF (.NOT. my_force_block) THEN
208 : dumblock = CEILING(REAL(fmstruct%ncol_global, KIND=dp)/ &
209 419161 : REAL(fmstruct%context%num_pe(2), KIND=dp))
210 419161 : fmstruct%ncol_block = MAX(1, MIN(fmstruct%ncol_block, dumblock))
211 : END IF
212 :
213 : ! square matrix -> square blocks (otherwise some op fail)
214 455037 : my_square_blocks = fmstruct%nrow_global == fmstruct%ncol_global
215 455037 : IF (PRESENT(square_blocks)) my_square_blocks = square_blocks
216 455037 : IF (my_square_blocks) THEN
217 281680 : fmstruct%nrow_block = MIN(fmstruct%nrow_block, fmstruct%ncol_block)
218 281680 : fmstruct%ncol_block = fmstruct%nrow_block
219 : END IF
220 :
221 : ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), &
222 2275185 : fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1)))
223 455037 : IF (.NOT. PRESENT(template_fmstruct)) &
224 1237503 : fmstruct%first_p_pos = (/0, 0/)
225 455109 : IF (PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos
226 :
227 1274434 : fmstruct%nrow_locals = 0
228 910074 : fmstruct%ncol_locals = 0
229 : #if defined(__SCALAPACK)
230 : fmstruct%nrow_locals(fmstruct%context%mepos(1)) = &
231 : numroc(fmstruct%nrow_global, fmstruct%nrow_block, &
232 : fmstruct%context%mepos(1), fmstruct%first_p_pos(1), &
233 455037 : fmstruct%context%num_pe(1))
234 : fmstruct%ncol_locals(fmstruct%context%mepos(2)) = &
235 : numroc(fmstruct%ncol_global, fmstruct%ncol_block, &
236 : fmstruct%context%mepos(2), fmstruct%first_p_pos(2), &
237 455037 : fmstruct%context%num_pe(2))
238 2093831 : CALL fmstruct%para_env%sum(fmstruct%nrow_locals)
239 1365111 : CALL fmstruct%para_env%sum(fmstruct%ncol_locals)
240 1274434 : fmstruct%nrow_locals(:) = fmstruct%nrow_locals(:)/fmstruct%context%num_pe(2)
241 910074 : fmstruct%ncol_locals(:) = fmstruct%ncol_locals(:)/fmstruct%context%num_pe(1)
242 :
243 1729471 : IF (SUM(fmstruct%ncol_locals) .NE. fmstruct%ncol_global .OR. &
244 : SUM(fmstruct%nrow_locals) .NE. fmstruct%nrow_global) THEN
245 : ! try to collect some output if this is going to happen again
246 : ! this seems to trigger on blanc, but should really never happen
247 0 : logger => cp_get_default_logger()
248 0 : iunit = cp_logger_get_default_unit_nr(logger, local=.TRUE.)
249 0 : WRITE (iunit, *) "mepos", fmstruct%context%mepos(1:2), "numpe", fmstruct%context%num_pe(1:2)
250 0 : WRITE (iunit, *) "ncol_global", fmstruct%ncol_global
251 0 : WRITE (iunit, *) "nrow_global", fmstruct%nrow_global
252 0 : WRITE (iunit, *) "ncol_locals", fmstruct%ncol_locals
253 0 : WRITE (iunit, *) "nrow_locals", fmstruct%nrow_locals
254 0 : CALL m_flush(iunit)
255 : END IF
256 :
257 910074 : IF (SUM(fmstruct%ncol_locals) .NE. fmstruct%ncol_global) &
258 0 : CPABORT("sum of local cols not equal global cols")
259 1274434 : IF (SUM(fmstruct%nrow_locals) .NE. fmstruct%nrow_global) &
260 0 : CPABORT("sum of local row not equal global rows")
261 : #else
262 : ! block = full matrix
263 : fmstruct%nrow_block = fmstruct%nrow_global
264 : fmstruct%ncol_block = fmstruct%ncol_global
265 : fmstruct%nrow_locals(fmstruct%context%mepos(1)) = fmstruct%nrow_global
266 : fmstruct%ncol_locals(fmstruct%context%mepos(2)) = fmstruct%ncol_global
267 : #endif
268 :
269 : fmstruct%local_leading_dimension = MAX(fmstruct%local_leading_dimension, &
270 455037 : fmstruct%nrow_locals(fmstruct%context%mepos(1)))
271 455037 : IF (PRESENT(local_leading_dimension)) THEN
272 0 : IF (MAX(1, fmstruct%nrow_locals(fmstruct%context%mepos(1))) > local_leading_dimension) &
273 : CALL cp_abort(__LOCATION__, "local_leading_dimension too small ("// &
274 : cp_to_string(local_leading_dimension)//"<"// &
275 0 : cp_to_string(fmstruct%local_leading_dimension)//")")
276 0 : fmstruct%local_leading_dimension = local_leading_dimension
277 : END IF
278 :
279 455037 : NULLIFY (fmstruct%row_indices, fmstruct%col_indices)
280 455037 : fmstruct%ref_count = 1
281 :
282 455037 : IF (PRESENT(descriptor)) THEN
283 0 : fmstruct%descriptor = descriptor
284 : ELSE
285 4550370 : fmstruct%descriptor = 0
286 : #if defined(__SCALAPACK)
287 : ! local leading dimension needs to be at least 1
288 : CALL descinit(fmstruct%descriptor, fmstruct%nrow_global, &
289 : fmstruct%ncol_global, fmstruct%nrow_block, &
290 : fmstruct%ncol_block, fmstruct%first_p_pos(1), &
291 : fmstruct%first_p_pos(2), fmstruct%context, &
292 455037 : fmstruct%local_leading_dimension, stat)
293 455037 : CPASSERT(stat == 0)
294 : #endif
295 : END IF
296 455037 : END SUBROUTINE cp_fm_struct_create
297 :
298 : ! **************************************************************************************************
299 : !> \brief retains a full matrix structure
300 : !> \param fmstruct the structure to retain
301 : !> \par History
302 : !> 08.2002 created [fawzi]
303 : !> \author Fawzi Mohamed
304 : ! **************************************************************************************************
305 1392271 : SUBROUTINE cp_fm_struct_retain(fmstruct)
306 : TYPE(cp_fm_struct_type), INTENT(INOUT) :: fmstruct
307 :
308 1392271 : CPASSERT(fmstruct%ref_count > 0)
309 1392271 : fmstruct%ref_count = fmstruct%ref_count + 1
310 1392271 : END SUBROUTINE cp_fm_struct_retain
311 :
312 : ! **************************************************************************************************
313 : !> \brief releases a full matrix structure
314 : !> \param fmstruct the structure to release
315 : !> \par History
316 : !> 08.2002 created [fawzi]
317 : !> \author Fawzi Mohamed
318 : ! **************************************************************************************************
319 1873801 : SUBROUTINE cp_fm_struct_release(fmstruct)
320 : TYPE(cp_fm_struct_type), POINTER :: fmstruct
321 :
322 1873801 : IF (ASSOCIATED(fmstruct)) THEN
323 1847308 : CPASSERT(fmstruct%ref_count > 0)
324 1847308 : fmstruct%ref_count = fmstruct%ref_count - 1
325 1847308 : IF (fmstruct%ref_count < 1) THEN
326 455037 : CALL cp_blacs_env_release(fmstruct%context)
327 455037 : CALL mp_para_env_release(fmstruct%para_env)
328 455037 : IF (ASSOCIATED(fmstruct%row_indices)) THEN
329 49461 : DEALLOCATE (fmstruct%row_indices)
330 : END IF
331 455037 : IF (ASSOCIATED(fmstruct%col_indices)) THEN
332 50163 : DEALLOCATE (fmstruct%col_indices)
333 : END IF
334 455037 : IF (ASSOCIATED(fmstruct%nrow_locals)) THEN
335 455037 : DEALLOCATE (fmstruct%nrow_locals)
336 : END IF
337 455037 : IF (ASSOCIATED(fmstruct%ncol_locals)) THEN
338 455037 : DEALLOCATE (fmstruct%ncol_locals)
339 : END IF
340 455037 : DEALLOCATE (fmstruct)
341 : END IF
342 : END IF
343 1873801 : NULLIFY (fmstruct)
344 1873801 : END SUBROUTINE cp_fm_struct_release
345 :
346 : ! **************************************************************************************************
347 : !> \brief returns true if the two matrix structures are equivalent, false
348 : !> otherwise.
349 : !> \param fmstruct1 one of the full matrix structures to compare
350 : !> \param fmstruct2 the second of the full matrix structures to compare
351 : !> \return ...
352 : !> \par History
353 : !> 08.2002 created [fawzi]
354 : !> \author Fawzi Mohamed
355 : ! **************************************************************************************************
356 2126339 : FUNCTION cp_fm_struct_equivalent(fmstruct1, fmstruct2) RESULT(res)
357 : TYPE(cp_fm_struct_type), POINTER :: fmstruct1, fmstruct2
358 : LOGICAL :: res
359 :
360 : INTEGER :: i
361 :
362 2126339 : CPASSERT(ASSOCIATED(fmstruct1))
363 2126339 : CPASSERT(ASSOCIATED(fmstruct2))
364 2126339 : CPASSERT(fmstruct1%ref_count > 0)
365 2126339 : CPASSERT(fmstruct2%ref_count > 0)
366 2126339 : IF (ASSOCIATED(fmstruct1, fmstruct2)) THEN
367 : res = .TRUE.
368 : ELSE
369 : res = (fmstruct1%context == fmstruct2%context) .AND. &
370 : (fmstruct1%nrow_global == fmstruct2%nrow_global) .AND. &
371 : (fmstruct1%ncol_global == fmstruct2%ncol_global) .AND. &
372 : (fmstruct1%nrow_block == fmstruct2%nrow_block) .AND. &
373 : (fmstruct1%ncol_block == fmstruct2%ncol_block) .AND. &
374 : (fmstruct1%local_leading_dimension == &
375 463699 : fmstruct2%local_leading_dimension)
376 4636990 : DO i = 1, 9
377 4636990 : res = res .AND. (fmstruct1%descriptor(i) == fmstruct1%descriptor(i))
378 : END DO
379 : END IF
380 2126339 : END FUNCTION cp_fm_struct_equivalent
381 :
382 : ! **************************************************************************************************
383 : !> \brief returns the values of various attributes of the matrix structure
384 : !> \param fmstruct the structure you want info about
385 : !> \param para_env ...
386 : !> \param context ...
387 : !> \param descriptor ...
388 : !> \param ncol_block ...
389 : !> \param nrow_block ...
390 : !> \param nrow_global ...
391 : !> \param ncol_global ...
392 : !> \param first_p_pos ...
393 : !> \param row_indices ...
394 : !> \param col_indices ...
395 : !> \param nrow_local ...
396 : !> \param ncol_local ...
397 : !> \param nrow_locals ...
398 : !> \param ncol_locals ...
399 : !> \param local_leading_dimension ...
400 : !> \par History
401 : !> 08.2002 created [fawzi]
402 : !> \author Fawzi Mohamed
403 : ! **************************************************************************************************
404 5901179 : SUBROUTINE cp_fm_struct_get(fmstruct, para_env, context, &
405 : descriptor, ncol_block, nrow_block, nrow_global, &
406 : ncol_global, first_p_pos, row_indices, &
407 : col_indices, nrow_local, ncol_local, nrow_locals, ncol_locals, &
408 : local_leading_dimension)
409 : TYPE(cp_fm_struct_type), INTENT(INOUT) :: fmstruct
410 : TYPE(mp_para_env_type), POINTER, OPTIONAL :: para_env
411 : TYPE(cp_blacs_env_type), POINTER, OPTIONAL :: context
412 : INTEGER, DIMENSION(9), INTENT(OUT), OPTIONAL :: descriptor
413 : INTEGER, INTENT(out), OPTIONAL :: ncol_block, nrow_block, nrow_global, &
414 : ncol_global, nrow_local, ncol_local, &
415 : local_leading_dimension
416 : INTEGER, DIMENSION(2), INTENT(out), OPTIONAL :: first_p_pos
417 : INTEGER, DIMENSION(:), POINTER, OPTIONAL :: row_indices, col_indices, &
418 : nrow_locals, ncol_locals
419 :
420 : INTEGER i, nprow, npcol, myprow, mypcol
421 : #if defined(__SCALAPACK)
422 : INTEGER, EXTERNAL :: indxl2g
423 : #endif
424 :
425 5901179 : IF (PRESENT(para_env)) para_env => fmstruct%para_env
426 5901179 : IF (PRESENT(context)) context => fmstruct%context
427 5901179 : IF (PRESENT(descriptor)) descriptor = fmstruct%descriptor
428 5901179 : IF (PRESENT(ncol_block)) ncol_block = fmstruct%ncol_block
429 5901179 : IF (PRESENT(nrow_block)) nrow_block = fmstruct%nrow_block
430 5901179 : IF (PRESENT(nrow_global)) nrow_global = fmstruct%nrow_global
431 5901179 : IF (PRESENT(ncol_global)) ncol_global = fmstruct%ncol_global
432 5901911 : IF (PRESENT(first_p_pos)) first_p_pos = fmstruct%first_p_pos
433 5901179 : IF (PRESENT(nrow_locals)) nrow_locals => fmstruct%nrow_locals
434 5901179 : IF (PRESENT(ncol_locals)) ncol_locals => fmstruct%ncol_locals
435 5901179 : IF (PRESENT(local_leading_dimension)) local_leading_dimension = &
436 34950 : fmstruct%local_leading_dimension
437 :
438 5901179 : myprow = fmstruct%context%mepos(1)
439 5901179 : mypcol = fmstruct%context%mepos(2)
440 5901179 : nprow = fmstruct%context%num_pe(1)
441 5901179 : npcol = fmstruct%context%num_pe(2)
442 :
443 5901179 : IF (PRESENT(nrow_local)) nrow_local = fmstruct%nrow_locals(myprow)
444 5901179 : IF (PRESENT(ncol_local)) ncol_local = fmstruct%ncol_locals(mypcol)
445 :
446 5901179 : IF (PRESENT(row_indices)) THEN
447 662309 : row_indices => fmstruct%row_indices
448 662309 : IF (.NOT. ASSOCIATED(row_indices)) THEN
449 : ! the max should go away
450 148383 : ALLOCATE (fmstruct%row_indices(MAX(fmstruct%nrow_locals(myprow), 1)))
451 49461 : row_indices => fmstruct%row_indices
452 : #ifdef __SCALAPACK
453 793994 : DO i = 1, SIZE(row_indices)
454 : row_indices(i) = &
455 793994 : indxl2g(i, fmstruct%nrow_block, myprow, fmstruct%first_p_pos(1), nprow)
456 : END DO
457 : #else
458 : DO i = 1, SIZE(row_indices)
459 : row_indices(i) = i
460 : END DO
461 : #endif
462 : END IF
463 : END IF
464 :
465 5901179 : IF (PRESENT(col_indices)) THEN
466 664233 : col_indices => fmstruct%col_indices
467 664233 : IF (.NOT. ASSOCIATED(col_indices)) THEN
468 150489 : ALLOCATE (fmstruct%col_indices(MAX(fmstruct%ncol_locals(mypcol), 1)))
469 50163 : col_indices => fmstruct%col_indices
470 : #ifdef __SCALAPACK
471 917015 : DO i = 1, SIZE(col_indices)
472 : col_indices(i) = &
473 917015 : indxl2g(i, fmstruct%ncol_block, mypcol, fmstruct%first_p_pos(2), npcol)
474 : END DO
475 : #else
476 : DO i = 1, SIZE(col_indices)
477 : col_indices(i) = i
478 : END DO
479 : #endif
480 : END IF
481 :
482 : END IF
483 5901179 : END SUBROUTINE cp_fm_struct_get
484 :
485 : ! **************************************************************************************************
486 : !> \brief Write nicely formatted info about the FM struct to the given I/O unit
487 : !> \param fmstruct a cp_fm_struct_type instance
488 : !> \param io_unit the I/O unit to use for writing
489 : ! **************************************************************************************************
490 3 : SUBROUTINE cp_fm_struct_write_info(fmstruct, io_unit)
491 : TYPE(cp_fm_struct_type), INTENT(IN) :: fmstruct
492 : INTEGER, INTENT(IN) :: io_unit
493 :
494 : INTEGER, PARAMETER :: oblock_size = 8
495 :
496 : CHARACTER(len=30) :: fm
497 : INTEGER :: oblock
498 :
499 3 : WRITE (fm, "(A,I2,A)") "(A,I5,A,I5,A,", oblock_size, "I6)"
500 :
501 3 : WRITE (io_unit, '(A,I12)') "CP_FM_STRUCT | No. of matrix columns: ", fmstruct%ncol_global
502 3 : WRITE (io_unit, '(A,I12)') "CP_FM_STRUCT | No. of matrix rows: ", fmstruct%nrow_global
503 3 : WRITE (io_unit, '(A,I12)') "CP_FM_STRUCT | No. of block columns: ", fmstruct%ncol_block
504 3 : WRITE (io_unit, '(A,I12)') "CP_FM_STRUCT | No. of block rows: ", fmstruct%nrow_block
505 :
506 3 : WRITE (io_unit, '(A)') "CP_FM_STRUCT | Number of local columns: "
507 6 : DO oblock = 0, (SIZE(fmstruct%ncol_locals) - 1)/oblock_size
508 3 : WRITE (io_unit, fm) "CP_FM_STRUCT | CPUs ", &
509 3 : oblock*oblock_size, "..", (oblock + 1)*oblock_size - 1, ": ", &
510 9 : fmstruct%ncol_locals(oblock*oblock_size:MIN(SIZE(fmstruct%ncol_locals), (oblock + 1)*oblock_size) - 1)
511 : END DO
512 :
513 3 : WRITE (io_unit, '(A)') "CP_FM_STRUCT | Number of local rows: "
514 6 : DO oblock = 0, (SIZE(fmstruct%nrow_locals) - 1)/oblock_size
515 3 : WRITE (io_unit, fm) "CP_FM_STRUCT | CPUs ", &
516 3 : oblock*oblock_size, "..", (oblock + 1)*oblock_size - 1, ": ", &
517 9 : fmstruct%nrow_locals(oblock*oblock_size:MIN(SIZE(fmstruct%nrow_locals), (oblock + 1)*oblock_size) - 1)
518 : END DO
519 3 : END SUBROUTINE cp_fm_struct_write_info
520 :
521 : ! **************************************************************************************************
522 : !> \brief creates a struct with twice the number of blocks on each core.
523 : !> If matrix A has to be multiplied with B anc C, a
524 : !> significant speedup of pdgemm can be acchieved by joining the matrices
525 : !> in a new one with this structure (see arnoldi in rt_matrix_exp)
526 : !> \param fmstruct the struct to create
527 : !> \param struct struct of either A or B
528 : !> \param context ...
529 : !> \param col in which direction the matrix should be enlarged
530 : !> \param row in which direction the matrix should be enlarged
531 : !> \par History
532 : !> 06.2009 created [fschiff]
533 : !> \author Florian Schiffmann
534 : ! **************************************************************************************************
535 5202 : SUBROUTINE cp_fm_struct_double(fmstruct, struct, context, col, row)
536 : TYPE(cp_fm_struct_type), POINTER :: fmstruct
537 : TYPE(cp_fm_struct_type), INTENT(INOUT) :: struct
538 : TYPE(cp_blacs_env_type), INTENT(INOUT), TARGET :: context
539 : LOGICAL, INTENT(in) :: col, row
540 :
541 : INTEGER :: n_doubled_items_in_partially_filled_block, ncol_block, ncol_global, newdim_col, &
542 : newdim_row, nfilled_blocks, nfilled_blocks_remain, nprocs_col, nprocs_row, nrow_block, &
543 : nrow_global
544 : TYPE(mp_para_env_type), POINTER :: para_env
545 :
546 : CALL cp_fm_struct_get(struct, nrow_global=nrow_global, &
547 : ncol_global=ncol_global, nrow_block=nrow_block, &
548 5202 : ncol_block=ncol_block)
549 5202 : newdim_row = nrow_global
550 5202 : newdim_col = ncol_global
551 5202 : nprocs_row = context%num_pe(1)
552 5202 : nprocs_col = context%num_pe(2)
553 5202 : para_env => struct%para_env
554 :
555 5202 : IF (col) THEN
556 5202 : IF (ncol_global == 0) THEN
557 120 : newdim_col = 0
558 : ELSE
559 : ! ncol_block nfilled_blocks_remain * ncol_block
560 : ! |<--->| |<--->|
561 : ! |-----|-----|-----|-----|---|
562 : ! | 0 | 1 | 2 | 0 | 1 | <- context%mepos(2)
563 : ! |-----|-----|-----|-----|---|
564 : ! |<--- nfilled_blocks -->|<-> -- items (columns) in partially filled blocks
565 : ! | * ncol_block |
566 5082 : n_doubled_items_in_partially_filled_block = 2*MOD(ncol_global, ncol_block)
567 5082 : nfilled_blocks = ncol_global/ncol_block
568 5082 : nfilled_blocks_remain = MOD(nfilled_blocks, nprocs_col)
569 5082 : newdim_col = 2*(nfilled_blocks/nprocs_col)
570 5082 : IF (n_doubled_items_in_partially_filled_block > ncol_block) THEN
571 : ! doubled number of columns in a partially filled block does not fit into a single block.
572 : ! Due to cyclic distribution of ScaLAPACK blocks, an extra block for each core needs to be added
573 : ! |-----|-----|-----|----| |-----|-----|-----|-----|-----|-----|-----|-----|-----|---|
574 : ! | 0 | 1 | 2 | 0 | --> | 0 | 1 | 2 | 0 | 1 | 2 | 0 | 1 | 2 | 0|
575 : ! |-----|-----|-----|----| |-----|-----|-----|-----|-----|-----|-----|-----|-----|---|
576 : ! a a a b a1 a1 a1 a2 a2 a2 b1 empty empty b2
577 352 : newdim_col = newdim_col + 1
578 :
579 : ! the number of columns which does not fit into the added extra block
580 352 : n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - ncol_block
581 4730 : ELSE IF (nfilled_blocks_remain > 0) THEN
582 : ! |-----|-----|-----|-----|--| |-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|
583 : ! | 0 | 1 | 2 | 0 | 1| -> | 0 | 1 | 2 | 0 | 1 | 2 | 0 | 1 | 2 | 0 |
584 : ! |-----|-----|-----|-----|--| |-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|
585 : ! a a a b b a1 a1 a1 a2 a2 a2 b1 b1 b2 empty b2
586 0 : newdim_col = newdim_col + 1
587 0 : n_doubled_items_in_partially_filled_block = 0
588 : END IF
589 :
590 5082 : newdim_col = (newdim_col*nprocs_col + nfilled_blocks_remain)*ncol_block + n_doubled_items_in_partially_filled_block
591 : END IF
592 : END IF
593 :
594 5202 : IF (row) THEN
595 0 : IF (nrow_global == 0) THEN
596 0 : newdim_row = 0
597 : ELSE
598 0 : n_doubled_items_in_partially_filled_block = 2*MOD(nrow_global, nrow_block)
599 0 : nfilled_blocks = nrow_global/nrow_block
600 0 : nfilled_blocks_remain = MOD(nfilled_blocks, nprocs_row)
601 0 : newdim_row = 2*(nfilled_blocks/nprocs_row)
602 0 : IF (n_doubled_items_in_partially_filled_block > nrow_block) THEN
603 0 : newdim_row = newdim_row + 1
604 0 : n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - nrow_block
605 0 : ELSE IF (nfilled_blocks_remain > 0) THEN
606 0 : newdim_row = newdim_row + 1
607 0 : n_doubled_items_in_partially_filled_block = 0
608 : END IF
609 :
610 0 : newdim_row = (newdim_row*nprocs_row + nfilled_blocks_remain)*nrow_block + n_doubled_items_in_partially_filled_block
611 : END IF
612 : END IF
613 :
614 : ! square_blocks=.FALSE. ensures that matrix blocks of the doubled matrix will have
615 : ! nrow_block x ncol_block shape even in case of a square doubled matrix
616 : CALL cp_fm_struct_create(fmstruct=fmstruct, para_env=para_env, &
617 : context=context, &
618 : nrow_global=newdim_row, &
619 : ncol_global=newdim_col, &
620 : ncol_block=ncol_block, &
621 : nrow_block=nrow_block, &
622 5202 : square_blocks=.FALSE.)
623 :
624 5202 : END SUBROUTINE cp_fm_struct_double
625 : ! **************************************************************************************************
626 : !> \brief allows to modify the default settings for matrix creation
627 : !> \param nrow_block ...
628 : !> \param ncol_block ...
629 : !> \param force_block ...
630 : ! **************************************************************************************************
631 8989 : SUBROUTINE cp_fm_struct_config(nrow_block, ncol_block, force_block)
632 : INTEGER, INTENT(IN), OPTIONAL :: nrow_block, ncol_block
633 : LOGICAL, INTENT(IN), OPTIONAL :: force_block
634 :
635 8989 : IF (PRESENT(ncol_block)) optimal_blacs_col_block_size = ncol_block
636 8989 : IF (PRESENT(nrow_block)) optimal_blacs_row_block_size = nrow_block
637 8989 : IF (PRESENT(force_block)) force_block_size = force_block
638 :
639 8989 : END SUBROUTINE cp_fm_struct_config
640 :
641 : ! **************************************************************************************************
642 : !> \brief ...
643 : !> \return ...
644 : ! **************************************************************************************************
645 6464 : FUNCTION cp_fm_struct_get_nrow_block() RESULT(res)
646 : INTEGER :: res
647 :
648 6464 : res = optimal_blacs_row_block_size
649 6464 : END FUNCTION cp_fm_struct_get_nrow_block
650 :
651 : ! **************************************************************************************************
652 : !> \brief ...
653 : !> \return ...
654 : ! **************************************************************************************************
655 6464 : FUNCTION cp_fm_struct_get_ncol_block() RESULT(res)
656 : INTEGER :: res
657 :
658 6464 : res = optimal_blacs_col_block_size
659 6464 : END FUNCTION cp_fm_struct_get_ncol_block
660 :
661 0 : END MODULE cp_fm_struct
|
