25 #include "../base/base_uses.f90"
30 LOGICAL,
PRIVATE,
PARAMETER :: debug_this_module = .true.
31 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'cp_fm_struct'
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.
41 PUBLIC :: cp_fm_struct_type, cp_fm_struct_p_type
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
93 TYPE cp_fm_struct_p_type
94 TYPE(cp_fm_struct_type),
POINTER :: struct => null()
95 END TYPE cp_fm_struct_p_type
123 ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, &
124 local_leading_dimension, template_fmstruct, square_blocks, force_block)
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
139 #if defined(__SCALAPACK)
140 INTEGER :: iunit, stat
141 INTEGER,
EXTERNAL :: numroc
142 TYPE(cp_logger_type),
POINTER :: logger
145 LOGICAL :: my_square_blocks, my_force_block
147 #if defined(__parallel) && ! defined(__SCALAPACK)
148 cpabort(
"full matrices need scalapack for parallel runs ")
153 fmstruct%nrow_block = optimal_blacs_row_block_size
154 fmstruct%ncol_block = optimal_blacs_col_block_size
156 IF (.NOT.
PRESENT(template_fmstruct))
THEN
157 cpassert(
PRESENT(context))
158 cpassert(
PRESENT(nrow_global))
159 cpassert(
PRESENT(ncol_global))
160 fmstruct%local_leading_dimension = 1
162 fmstruct%context => template_fmstruct%context
163 fmstruct%para_env => template_fmstruct%para_env
164 fmstruct%descriptor = template_fmstruct%descriptor
165 fmstruct%nrow_block = template_fmstruct%nrow_block
166 fmstruct%nrow_global = template_fmstruct%nrow_global
167 fmstruct%ncol_block = template_fmstruct%ncol_block
168 fmstruct%ncol_global = template_fmstruct%ncol_global
169 fmstruct%first_p_pos = template_fmstruct%first_p_pos
170 fmstruct%local_leading_dimension = &
171 template_fmstruct%local_leading_dimension
174 my_force_block = force_block_size
175 IF (
PRESENT(force_block)) my_force_block = force_block
177 IF (
PRESENT(context))
THEN
178 fmstruct%context => context
179 fmstruct%para_env => context%para_env
181 IF (
PRESENT(para_env)) fmstruct%para_env => para_env
182 CALL fmstruct%context%retain()
183 CALL fmstruct%para_env%retain()
185 IF (
PRESENT(nrow_global))
THEN
186 fmstruct%nrow_global = nrow_global
187 fmstruct%local_leading_dimension = 1
189 IF (
PRESENT(ncol_global))
THEN
190 fmstruct%ncol_global = ncol_global
194 IF (
PRESENT(nrow_block))
THEN
195 IF (nrow_block > 0) &
196 fmstruct%nrow_block = nrow_block
198 IF (.NOT. my_force_block)
THEN
199 dumblock = ceiling(real(fmstruct%nrow_global, kind=
dp)/ &
200 REAL(fmstruct%context%num_pe(1), kind=
dp))
201 fmstruct%nrow_block = max(1, min(fmstruct%nrow_block, dumblock))
203 IF (
PRESENT(ncol_block))
THEN
204 IF (ncol_block > 0) &
205 fmstruct%ncol_block = ncol_block
207 IF (.NOT. my_force_block)
THEN
208 dumblock = ceiling(real(fmstruct%ncol_global, kind=
dp)/ &
209 REAL(fmstruct%context%num_pe(2), kind=
dp))
210 fmstruct%ncol_block = max(1, min(fmstruct%ncol_block, dumblock))
214 my_square_blocks = fmstruct%nrow_global == fmstruct%ncol_global
215 IF (
PRESENT(square_blocks)) my_square_blocks = square_blocks
216 IF (my_square_blocks)
THEN
217 fmstruct%nrow_block = min(fmstruct%nrow_block, fmstruct%ncol_block)
218 fmstruct%ncol_block = fmstruct%nrow_block
221 ALLOCATE (fmstruct%nrow_locals(0:(fmstruct%context%num_pe(1) - 1)), &
222 fmstruct%ncol_locals(0:(fmstruct%context%num_pe(2) - 1)))
223 IF (.NOT.
PRESENT(template_fmstruct)) &
224 fmstruct%first_p_pos = (/0, 0/)
225 IF (
PRESENT(first_p_pos)) fmstruct%first_p_pos = first_p_pos
227 fmstruct%nrow_locals = 0
228 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 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 fmstruct%context%num_pe(2))
238 CALL fmstruct%para_env%sum(fmstruct%nrow_locals)
239 CALL fmstruct%para_env%sum(fmstruct%ncol_locals)
240 fmstruct%nrow_locals(:) = fmstruct%nrow_locals(:)/fmstruct%context%num_pe(2)
241 fmstruct%ncol_locals(:) = fmstruct%ncol_locals(:)/fmstruct%context%num_pe(1)
243 IF (sum(fmstruct%ncol_locals) .NE. fmstruct%ncol_global .OR. &
244 sum(fmstruct%nrow_locals) .NE. fmstruct%nrow_global)
THEN
249 WRITE (iunit, *)
"mepos", fmstruct%context%mepos(1:2),
"numpe", fmstruct%context%num_pe(1:2)
250 WRITE (iunit, *)
"ncol_global", fmstruct%ncol_global
251 WRITE (iunit, *)
"nrow_global", fmstruct%nrow_global
252 WRITE (iunit, *)
"ncol_locals", fmstruct%ncol_locals
253 WRITE (iunit, *)
"nrow_locals", fmstruct%nrow_locals
257 IF (sum(fmstruct%ncol_locals) .NE. fmstruct%ncol_global) &
258 cpabort(
"sum of local cols not equal global cols")
259 IF (sum(fmstruct%nrow_locals) .NE. fmstruct%nrow_global) &
260 cpabort(
"sum of local row not equal global rows")
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
269 fmstruct%local_leading_dimension = max(fmstruct%local_leading_dimension, &
270 fmstruct%nrow_locals(fmstruct%context%mepos(1)))
271 IF (
PRESENT(local_leading_dimension))
THEN
272 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 cp_to_string(fmstruct%local_leading_dimension)//
")")
276 fmstruct%local_leading_dimension = local_leading_dimension
279 NULLIFY (fmstruct%row_indices, fmstruct%col_indices)
280 fmstruct%ref_count = 1
282 IF (
PRESENT(descriptor))
THEN
283 fmstruct%descriptor = descriptor
285 fmstruct%descriptor = 0
286 #if defined(__SCALAPACK)
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 fmstruct%local_leading_dimension, stat)
306 TYPE(cp_fm_struct_type),
INTENT(INOUT) :: fmstruct
308 cpassert(fmstruct%ref_count > 0)
309 fmstruct%ref_count = fmstruct%ref_count + 1
320 TYPE(cp_fm_struct_type),
POINTER :: fmstruct
322 IF (
ASSOCIATED(fmstruct))
THEN
323 cpassert(fmstruct%ref_count > 0)
324 fmstruct%ref_count = fmstruct%ref_count - 1
325 IF (fmstruct%ref_count < 1)
THEN
328 IF (
ASSOCIATED(fmstruct%row_indices))
THEN
329 DEALLOCATE (fmstruct%row_indices)
331 IF (
ASSOCIATED(fmstruct%col_indices))
THEN
332 DEALLOCATE (fmstruct%col_indices)
334 IF (
ASSOCIATED(fmstruct%nrow_locals))
THEN
335 DEALLOCATE (fmstruct%nrow_locals)
337 IF (
ASSOCIATED(fmstruct%ncol_locals))
THEN
338 DEALLOCATE (fmstruct%ncol_locals)
340 DEALLOCATE (fmstruct)
357 TYPE(cp_fm_struct_type),
POINTER :: fmstruct1, fmstruct2
362 cpassert(
ASSOCIATED(fmstruct1))
363 cpassert(
ASSOCIATED(fmstruct2))
364 cpassert(fmstruct1%ref_count > 0)
365 cpassert(fmstruct2%ref_count > 0)
366 IF (
ASSOCIATED(fmstruct1, fmstruct2))
THEN
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 fmstruct2%local_leading_dimension)
377 res = res .AND. (fmstruct1%descriptor(i) == fmstruct1%descriptor(i))
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
420 INTEGER i, nprow, npcol, myprow, mypcol
421 #if defined(__SCALAPACK)
422 INTEGER,
EXTERNAL :: indxl2g
425 IF (
PRESENT(para_env)) para_env => fmstruct%para_env
426 IF (
PRESENT(context)) context => fmstruct%context
427 IF (
PRESENT(descriptor)) descriptor = fmstruct%descriptor
428 IF (
PRESENT(ncol_block)) ncol_block = fmstruct%ncol_block
429 IF (
PRESENT(nrow_block)) nrow_block = fmstruct%nrow_block
430 IF (
PRESENT(nrow_global)) nrow_global = fmstruct%nrow_global
431 IF (
PRESENT(ncol_global)) ncol_global = fmstruct%ncol_global
432 IF (
PRESENT(first_p_pos)) first_p_pos = fmstruct%first_p_pos
433 IF (
PRESENT(nrow_locals)) nrow_locals => fmstruct%nrow_locals
434 IF (
PRESENT(ncol_locals)) ncol_locals => fmstruct%ncol_locals
435 IF (
PRESENT(local_leading_dimension)) local_leading_dimension = &
436 fmstruct%local_leading_dimension
438 myprow = fmstruct%context%mepos(1)
439 mypcol = fmstruct%context%mepos(2)
440 nprow = fmstruct%context%num_pe(1)
441 npcol = fmstruct%context%num_pe(2)
443 IF (
PRESENT(nrow_local)) nrow_local = fmstruct%nrow_locals(myprow)
444 IF (
PRESENT(ncol_local)) ncol_local = fmstruct%ncol_locals(mypcol)
446 IF (
PRESENT(row_indices))
THEN
447 row_indices => fmstruct%row_indices
448 IF (.NOT.
ASSOCIATED(row_indices))
THEN
450 ALLOCATE (fmstruct%row_indices(max(fmstruct%nrow_locals(myprow), 1)))
451 row_indices => fmstruct%row_indices
453 DO i = 1,
SIZE(row_indices)
455 indxl2g(i, fmstruct%nrow_block, myprow, fmstruct%first_p_pos(1), nprow)
458 DO i = 1,
SIZE(row_indices)
465 IF (
PRESENT(col_indices))
THEN
466 col_indices => fmstruct%col_indices
467 IF (.NOT.
ASSOCIATED(col_indices))
THEN
468 ALLOCATE (fmstruct%col_indices(max(fmstruct%ncol_locals(mypcol), 1)))
469 col_indices => fmstruct%col_indices
471 DO i = 1,
SIZE(col_indices)
473 indxl2g(i, fmstruct%ncol_block, mypcol, fmstruct%first_p_pos(2), npcol)
476 DO i = 1,
SIZE(col_indices)
491 TYPE(cp_fm_struct_type),
INTENT(IN) :: fmstruct
492 INTEGER,
INTENT(IN) :: io_unit
494 INTEGER,
PARAMETER :: oblock_size = 8
496 CHARACTER(len=30) :: fm
499 WRITE (fm,
"(A,I2,A)")
"(A,I5,A,I5,A,", oblock_size,
"I6)"
501 WRITE (io_unit,
'(A,I12)')
"CP_FM_STRUCT | No. of matrix columns: ", fmstruct%ncol_global
502 WRITE (io_unit,
'(A,I12)')
"CP_FM_STRUCT | No. of matrix rows: ", fmstruct%nrow_global
503 WRITE (io_unit,
'(A,I12)')
"CP_FM_STRUCT | No. of block columns: ", fmstruct%ncol_block
504 WRITE (io_unit,
'(A,I12)')
"CP_FM_STRUCT | No. of block rows: ", fmstruct%nrow_block
506 WRITE (io_unit,
'(A)')
"CP_FM_STRUCT | Number of local columns: "
507 DO oblock = 0, (
SIZE(fmstruct%ncol_locals) - 1)/oblock_size
508 WRITE (io_unit, fm)
"CP_FM_STRUCT | CPUs ", &
509 oblock*oblock_size,
"..", (oblock + 1)*oblock_size - 1,
": ", &
510 fmstruct%ncol_locals(oblock*oblock_size:min(
SIZE(fmstruct%ncol_locals), (oblock + 1)*oblock_size) - 1)
513 WRITE (io_unit,
'(A)')
"CP_FM_STRUCT | Number of local rows: "
514 DO oblock = 0, (
SIZE(fmstruct%nrow_locals) - 1)/oblock_size
515 WRITE (io_unit, fm)
"CP_FM_STRUCT | CPUs ", &
516 oblock*oblock_size,
"..", (oblock + 1)*oblock_size - 1,
": ", &
517 fmstruct%nrow_locals(oblock*oblock_size:min(
SIZE(fmstruct%nrow_locals), (oblock + 1)*oblock_size) - 1)
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
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, &
544 TYPE(mp_para_env_type),
POINTER :: para_env
547 ncol_global=ncol_global, nrow_block=nrow_block, &
548 ncol_block=ncol_block)
549 newdim_row = nrow_global
550 newdim_col = ncol_global
551 nprocs_row = context%num_pe(1)
552 nprocs_col = context%num_pe(2)
553 para_env => struct%para_env
556 IF (ncol_global == 0)
THEN
566 n_doubled_items_in_partially_filled_block = 2*mod(ncol_global, ncol_block)
567 nfilled_blocks = ncol_global/ncol_block
568 nfilled_blocks_remain = mod(nfilled_blocks, nprocs_col)
569 newdim_col = 2*(nfilled_blocks/nprocs_col)
570 IF (n_doubled_items_in_partially_filled_block > ncol_block)
THEN
577 newdim_col = newdim_col + 1
580 n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - ncol_block
581 ELSE IF (nfilled_blocks_remain > 0)
THEN
586 newdim_col = newdim_col + 1
587 n_doubled_items_in_partially_filled_block = 0
590 newdim_col = (newdim_col*nprocs_col + nfilled_blocks_remain)*ncol_block + n_doubled_items_in_partially_filled_block
595 IF (nrow_global == 0)
THEN
598 n_doubled_items_in_partially_filled_block = 2*mod(nrow_global, nrow_block)
599 nfilled_blocks = nrow_global/nrow_block
600 nfilled_blocks_remain = mod(nfilled_blocks, nprocs_row)
601 newdim_row = 2*(nfilled_blocks/nprocs_row)
602 IF (n_doubled_items_in_partially_filled_block > nrow_block)
THEN
603 newdim_row = newdim_row + 1
604 n_doubled_items_in_partially_filled_block = n_doubled_items_in_partially_filled_block - nrow_block
605 ELSE IF (nfilled_blocks_remain > 0)
THEN
606 newdim_row = newdim_row + 1
607 n_doubled_items_in_partially_filled_block = 0
610 newdim_row = (newdim_row*nprocs_row + nfilled_blocks_remain)*nrow_block + n_doubled_items_in_partially_filled_block
618 nrow_global=newdim_row, &
619 ncol_global=newdim_col, &
620 ncol_block=ncol_block, &
621 nrow_block=nrow_block, &
622 square_blocks=.false.)
632 INTEGER,
INTENT(IN),
OPTIONAL :: nrow_block, ncol_block
633 LOGICAL,
INTENT(IN),
OPTIONAL :: force_block
635 IF (
PRESENT(ncol_block)) optimal_blacs_col_block_size = ncol_block
636 IF (
PRESENT(nrow_block)) optimal_blacs_row_block_size = nrow_block
637 IF (
PRESENT(force_block)) force_block_size = force_block
648 res = optimal_blacs_row_block_size
658 res = optimal_blacs_col_block_size
methods related to the blacs parallel environment
subroutine, public cp_blacs_env_release(blacs_env)
releases the given blacs_env
represent the structure of a full matrix
subroutine, public cp_fm_struct_create(fmstruct, para_env, context, nrow_global, ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, local_leading_dimension, template_fmstruct, square_blocks, force_block)
allocates and initializes a full matrix structure
integer function, public cp_fm_struct_get_nrow_block()
...
integer function, public cp_fm_struct_get_ncol_block()
...
subroutine, public cp_fm_struct_config(nrow_block, ncol_block, force_block)
allows to modify the default settings for matrix creation
subroutine, public cp_fm_struct_get(fmstruct, para_env, context, descriptor, ncol_block, nrow_block, nrow_global, ncol_global, first_p_pos, row_indices, col_indices, nrow_local, ncol_local, nrow_locals, ncol_locals, local_leading_dimension)
returns the values of various attributes of the matrix structure
subroutine, public cp_fm_struct_double(fmstruct, struct, context, col, row)
creates a struct with twice the number of blocks on each core. If matrix A has to be multiplied with ...
logical function, public cp_fm_struct_equivalent(fmstruct1, fmstruct2)
returns true if the two matrix structures are equivalent, false otherwise.
subroutine, public cp_fm_struct_retain(fmstruct)
retains a full matrix structure
subroutine, public cp_fm_struct_write_info(fmstruct, io_unit)
Write nicely formatted info about the FM struct to the given I/O unit.
subroutine, public cp_fm_struct_release(fmstruct)
releases a full matrix structure
various routines to log and control the output. The idea is that decisions about where to log should ...
recursive integer function, public cp_logger_get_default_unit_nr(logger, local, skip_not_ionode)
asks the default unit number of the given logger. try to use cp_logger_get_unit_nr
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
Defines the basic variable types.
integer, parameter, public dp
Machine interface based on Fortran 2003 and POSIX.
subroutine, public m_flush(lunit)
flushes units if the &GLOBAL flag is set accordingly
Interface to the message passing library MPI.
subroutine, public mp_para_env_release(para_env)
releases the para object (to be called when you don't want anymore the shared copy of this object)