30 #include "../base/base_uses.f90"
35 LOGICAL,
PRIVATE,
PARAMETER :: debug_this_module = .true.
36 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'cp_cfm_types'
37 INTEGER,
PARAMETER,
PRIVATE :: src_tag = 3, dest_tag = 5, send_tag = 7, recv_tag = 11
39 PUBLIC :: cp_cfm_type, cp_cfm_p_type, copy_cfm_info_type
55 INTERFACE cp_cfm_to_cfm
56 MODULE PROCEDURE cp_cfm_to_cfm_matrix, &
69 CHARACTER(len=60) :: name =
""
70 TYPE(cp_fm_struct_type),
POINTER :: matrix_struct => null()
71 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER,
CONTIGUOUS :: local_data => null()
79 TYPE(cp_cfm_type),
POINTER :: matrix => null()
80 END TYPE cp_cfm_p_type
89 TYPE copy_cfm_info_type
91 INTEGER :: send_size = -1
93 INTEGER,
DIMENSION(2) :: nlocal_recv = -1
95 INTEGER,
DIMENSION(2) :: nblock_src = -1
97 INTEGER,
DIMENSION(2) :: src_num_pe = -1
99 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: recv_disp
101 TYPE(mp_request_type),
ALLOCATABLE,
DIMENSION(:) :: recv_request, send_request
103 INTEGER,
DIMENSION(:),
POINTER :: recv_col_indices => null(), recv_row_indices => null()
105 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: src_blacs2mpi
107 COMPLEX(kind=dp),
ALLOCATABLE,
DIMENSION(:) :: recv_buf, send_buf
108 END TYPE copy_cfm_info_type
121 TYPE(cp_cfm_type),
INTENT(OUT) :: matrix
122 TYPE(cp_fm_struct_type),
TARGET,
INTENT(IN) :: matrix_struct
123 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: name
125 INTEGER :: ncol_local, npcol, nprow, nrow_local
126 TYPE(cp_blacs_env_type),
POINTER :: context
128 #if defined(__parallel) && ! defined(__SCALAPACK)
129 cpabort(
"full matrices need ScaLAPACK for parallel run")
132 context => matrix_struct%context
133 matrix%matrix_struct => matrix_struct
136 nprow = context%num_pe(1)
137 npcol = context%num_pe(2)
138 NULLIFY (matrix%local_data)
140 nrow_local = matrix_struct%local_leading_dimension
141 ncol_local = max(1, matrix_struct%ncol_locals(context%mepos(2)))
142 ALLOCATE (matrix%local_data(nrow_local, ncol_local))
147 IF (
PRESENT(name))
THEN
150 matrix%name =
'full complex matrix'
159 TYPE(cp_cfm_type),
INTENT(INOUT) :: matrix
161 IF (
ASSOCIATED(matrix%local_data))
THEN
162 DEALLOCATE (matrix%local_data)
179 TYPE(cp_cfm_type),
INTENT(IN) :: matrix
180 COMPLEX(kind=dp),
INTENT(in) :: alpha
181 COMPLEX(kind=dp),
INTENT(in),
OPTIONAL :: beta
183 INTEGER :: irow_local, nrow_local
184 #if defined(__SCALAPACK)
185 INTEGER :: icol_local, ncol_local
186 INTEGER,
DIMENSION(:),
POINTER :: col_indices, row_indices
189 CALL zcopy(
SIZE(matrix%local_data), alpha, 0, matrix%local_data(1, 1), 1)
191 IF (
PRESENT(beta))
THEN
192 #if defined(__SCALAPACK)
193 CALL cp_cfm_get_info(matrix, nrow_local=nrow_local, ncol_local=ncol_local, &
194 row_indices=row_indices, col_indices=col_indices)
199 DO WHILE (irow_local <= nrow_local .AND. icol_local <= ncol_local)
200 IF (row_indices(irow_local) < col_indices(icol_local))
THEN
201 irow_local = irow_local + 1
202 ELSE IF (row_indices(irow_local) > col_indices(icol_local))
THEN
203 icol_local = icol_local + 1
205 matrix%local_data(irow_local, icol_local) = beta
206 irow_local = irow_local + 1
207 icol_local = icol_local + 1
211 nrow_local = min(matrix%matrix_struct%nrow_global, matrix%matrix_struct%ncol_global)
213 DO irow_local = 1, nrow_local
214 matrix%local_data(irow_local, irow_local) = beta
232 TYPE(cp_cfm_type),
INTENT(IN) :: matrix
233 INTEGER,
INTENT(in) :: irow_global, icol_global
234 COMPLEX(kind=dp),
INTENT(out) :: alpha
236 #if defined(__SCALAPACK)
237 INTEGER :: icol_local, ipcol, iprow, irow_local, &
238 mypcol, myprow, npcol, nprow
239 INTEGER,
DIMENSION(9) :: desca
240 TYPE(cp_blacs_env_type),
POINTER :: context
243 #if defined(__SCALAPACK)
244 context => matrix%matrix_struct%context
245 myprow = context%mepos(1)
246 mypcol = context%mepos(2)
247 nprow = context%num_pe(1)
248 npcol = context%num_pe(2)
250 desca(:) = matrix%matrix_struct%descriptor(:)
252 CALL infog2l(irow_global, icol_global, desca, nprow, npcol, myprow, mypcol, &
253 irow_local, icol_local, iprow, ipcol)
255 IF ((iprow == myprow) .AND. (ipcol == mypcol))
THEN
256 alpha = matrix%local_data(irow_local, icol_local)
257 CALL context%ZGEBS2D(
'All',
' ', 1, 1, alpha, 1)
259 CALL context%ZGEBR2D(
'All',
' ', 1, 1, alpha, 1, iprow, ipcol)
263 alpha = matrix%local_data(irow_global, icol_global)
279 TYPE(cp_cfm_type),
INTENT(IN) :: matrix
280 INTEGER,
INTENT(in) :: irow_global, icol_global
281 COMPLEX(kind=dp),
INTENT(in) :: alpha
283 #if defined(__SCALAPACK)
284 INTEGER :: icol_local, ipcol, iprow, irow_local, &
285 mypcol, myprow, npcol, nprow
286 INTEGER,
DIMENSION(9) :: desca
287 TYPE(cp_blacs_env_type),
POINTER :: context
290 #if defined(__SCALAPACK)
291 context => matrix%matrix_struct%context
292 myprow = context%mepos(1)
293 mypcol = context%mepos(2)
294 nprow = context%num_pe(1)
295 npcol = context%num_pe(2)
297 desca(:) = matrix%matrix_struct%descriptor(:)
299 CALL infog2l(irow_global, icol_global, desca, nprow, npcol, myprow, mypcol, &
300 irow_local, icol_local, iprow, ipcol)
302 IF ((iprow == myprow) .AND. (ipcol == mypcol))
THEN
303 matrix%local_data(irow_local, icol_local) = alpha
307 matrix%local_data(irow_global, icol_global) = alpha
333 TYPE(cp_cfm_type),
INTENT(IN) :: fm
334 COMPLEX(kind=dp),
DIMENSION(:, :),
INTENT(out) :: target_m
335 INTEGER,
INTENT(in),
OPTIONAL :: start_row, start_col, n_rows, n_cols
336 LOGICAL,
INTENT(in),
OPTIONAL :: transpose
338 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_get_submatrix'
340 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: local_data
341 INTEGER :: end_col_global, end_col_local, end_row_global, end_row_local, handle, i, j, &
342 ncol_global, ncol_local, nrow_global, nrow_local, start_col_global, start_col_local, &
343 start_row_global, start_row_local, this_col
344 INTEGER,
DIMENSION(:),
POINTER :: col_indices, row_indices
345 LOGICAL :: do_zero, tr_a
346 TYPE(mp_para_env_type),
POINTER :: para_env
348 CALL timeset(routinen, handle)
350 IF (
SIZE(target_m) /= 0)
THEN
351 #if defined(__SCALAPACK)
358 IF (
PRESENT(transpose)) tr_a = transpose
363 IF (
PRESENT(start_row)) start_row_global = start_row
364 IF (
PRESENT(start_col)) start_col_global = start_col
367 end_row_global =
SIZE(target_m, 2)
368 end_col_global =
SIZE(target_m, 1)
370 end_row_global =
SIZE(target_m, 1)
371 end_col_global =
SIZE(target_m, 2)
373 IF (
PRESENT(n_rows)) end_row_global = n_rows
374 IF (
PRESENT(n_cols)) end_col_global = n_cols
376 end_row_global = end_row_global + start_row_global - 1
377 end_col_global = end_col_global + start_col_global - 1
380 nrow_global=nrow_global, ncol_global=ncol_global, &
381 nrow_local=nrow_local, ncol_local=ncol_local, &
382 row_indices=row_indices, col_indices=col_indices)
383 IF (end_row_global > nrow_global)
THEN
384 end_row_global = nrow_global
387 IF (end_col_global > ncol_global)
THEN
388 end_col_global = ncol_global
394 DO start_row_local = 1, nrow_local
395 IF (row_indices(start_row_local) >= start_row_global)
EXIT
398 DO end_row_local = start_row_local, nrow_local
399 IF (row_indices(end_row_local) > end_row_global)
EXIT
401 end_row_local = end_row_local - 1
403 DO start_col_local = 1, ncol_local
404 IF (col_indices(start_col_local) >= start_col_global)
EXIT
407 DO end_col_local = start_col_local, ncol_local
408 IF (col_indices(end_col_local) > end_col_global)
EXIT
410 end_col_local = end_col_local - 1
412 para_env => fm%matrix_struct%para_env
413 local_data => fm%local_data
420 CALL zcopy(
SIZE(target_m),
z_zero, 0, target_m(1, 1), 1)
423 DO j = start_col_local, end_col_local
424 this_col = col_indices(j) - start_col_global + 1
425 DO i = start_row_local, end_row_local
426 target_m(this_col, row_indices(i) - start_row_global + 1) = local_data(i, j)
430 DO j = start_col_local, end_col_local
431 this_col = col_indices(j) - start_col_global + 1
432 DO i = start_row_local, end_row_local
433 target_m(row_indices(i) - start_row_global + 1, this_col) = local_data(i, j)
438 CALL para_env%sum(target_m)
441 CALL timestop(handle)
469 start_col, n_rows, n_cols, alpha, beta, transpose)
470 TYPE(cp_cfm_type),
INTENT(IN) :: matrix
471 COMPLEX(kind=dp),
DIMENSION(:, :),
INTENT(in) :: new_values
472 INTEGER,
INTENT(in),
OPTIONAL :: start_row, start_col, n_rows, n_cols
473 COMPLEX(kind=dp),
INTENT(in),
OPTIONAL :: alpha, beta
474 LOGICAL,
INTENT(in),
OPTIONAL :: transpose
476 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_set_submatrix'
478 COMPLEX(kind=dp) :: al, be
479 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: local_data
480 INTEGER :: end_col_global, end_col_local, end_row_global, end_row_local, handle, i, j, &
481 ncol_global, ncol_local, nrow_global, nrow_local, start_col_global, start_col_local, &
482 start_row_global, start_row_local, this_col
483 INTEGER,
DIMENSION(:),
POINTER :: col_indices, row_indices
486 CALL timeset(routinen, handle)
490 IF (
PRESENT(alpha)) al = alpha
491 IF (
PRESENT(beta)) be = beta
496 IF (
PRESENT(start_row)) start_row_global = start_row
497 IF (
PRESENT(start_col)) start_col_global = start_col
500 IF (
PRESENT(transpose)) tr_a = transpose
503 end_row_global =
SIZE(new_values, 2)
504 end_col_global =
SIZE(new_values, 1)
506 end_row_global =
SIZE(new_values, 1)
507 end_col_global =
SIZE(new_values, 2)
509 IF (
PRESENT(n_rows)) end_row_global = n_rows
510 IF (
PRESENT(n_cols)) end_col_global = n_cols
512 end_row_global = end_row_global + start_row_global - 1
513 end_col_global = end_col_global + start_col_global - 1
516 nrow_global=nrow_global, ncol_global=ncol_global, &
517 nrow_local=nrow_local, ncol_local=ncol_local, &
518 row_indices=row_indices, col_indices=col_indices)
519 IF (end_row_global > nrow_global) end_row_global = nrow_global
520 IF (end_col_global > ncol_global) end_col_global = ncol_global
524 DO start_row_local = 1, nrow_local
525 IF (row_indices(start_row_local) >= start_row_global)
EXIT
528 DO end_row_local = start_row_local, nrow_local
529 IF (row_indices(end_row_local) > end_row_global)
EXIT
531 end_row_local = end_row_local - 1
533 DO start_col_local = 1, ncol_local
534 IF (col_indices(start_col_local) >= start_col_global)
EXIT
537 DO end_col_local = start_col_local, ncol_local
538 IF (col_indices(end_col_local) > end_col_global)
EXIT
540 end_col_local = end_col_local - 1
542 local_data => matrix%local_data
546 DO j = start_col_local, end_col_local
547 this_col = col_indices(j) - start_col_global + 1
548 DO i = start_row_local, end_row_local
549 local_data(i, j) = new_values(this_col, row_indices(i) - start_row_global + 1)
553 DO j = start_col_local, end_col_local
554 this_col = col_indices(j) - start_col_global + 1
555 DO i = start_row_local, end_row_local
556 local_data(i, j) = new_values(row_indices(i) - start_row_global + 1, this_col)
562 DO j = start_col_local, end_col_local
563 this_col = col_indices(j) - start_col_global + 1
564 DO i = start_row_local, end_row_local
565 local_data(i, j) = al*new_values(this_col, row_indices(i) - start_row_global + 1) + &
570 DO j = start_col_local, end_col_local
571 this_col = col_indices(j) - start_col_global + 1
572 DO i = start_row_local, end_row_local
573 local_data(i, j) = al*new_values(row_indices(i) - start_row_global + 1, this_col) + &
580 CALL timestop(handle)
604 nrow_block, ncol_block, nrow_local, ncol_local, &
605 row_indices, col_indices, local_data, context, &
606 matrix_struct, para_env)
607 TYPE(cp_cfm_type),
INTENT(IN) :: matrix
608 CHARACTER(len=*),
INTENT(OUT),
OPTIONAL :: name
609 INTEGER,
INTENT(OUT),
OPTIONAL :: nrow_global, ncol_global, nrow_block, &
610 ncol_block, nrow_local, ncol_local
611 INTEGER,
DIMENSION(:),
OPTIONAL,
POINTER :: row_indices, col_indices
612 COMPLEX(kind=dp),
CONTIGUOUS,
DIMENSION(:, :), &
613 OPTIONAL,
POINTER :: local_data
614 TYPE(cp_blacs_env_type),
OPTIONAL,
POINTER :: context
615 TYPE(cp_fm_struct_type),
OPTIONAL,
POINTER :: matrix_struct
616 TYPE(mp_para_env_type),
OPTIONAL,
POINTER :: para_env
618 IF (
PRESENT(name)) name = matrix%name
619 IF (
PRESENT(matrix_struct)) matrix_struct => matrix%matrix_struct
620 IF (
PRESENT(local_data)) local_data => matrix%local_data
623 ncol_local=ncol_local, nrow_global=nrow_global, &
624 ncol_global=ncol_global, nrow_block=nrow_block, &
625 ncol_block=ncol_block, context=context, &
626 row_indices=row_indices, col_indices=col_indices, para_env=para_env)
636 SUBROUTINE cp_cfm_to_cfm_matrix(source, destination)
637 TYPE(cp_cfm_type),
INTENT(IN) :: source, destination
639 INTEGER :: npcol, nprow
641 nprow = source%matrix_struct%context%num_pe(1)
642 npcol = source%matrix_struct%context%num_pe(2)
646 destination%matrix_struct))
THEN
647 IF (
SIZE(source%local_data, 1) /=
SIZE(destination%local_data, 1) .OR. &
648 SIZE(source%local_data, 2) /=
SIZE(destination%local_data, 2)) &
649 cpabort(
"internal local_data has different sizes")
650 CALL zcopy(
SIZE(source%local_data), source%local_data(1, 1), 1, destination%local_data(1, 1), 1)
652 IF (source%matrix_struct%nrow_global /= destination%matrix_struct%nrow_global) &
653 cpabort(
"cannot copy between full matrixes of differen sizes")
654 IF (source%matrix_struct%ncol_global /= destination%matrix_struct%ncol_global) &
655 cpabort(
"cannot copy between full matrixes of differen sizes")
656 #if defined(__SCALAPACK)
657 CALL pzcopy(source%matrix_struct%nrow_global* &
658 source%matrix_struct%ncol_global, &
659 source%local_data(1, 1), 1, 1, source%matrix_struct%descriptor, 1, &
660 destination%local_data(1, 1), 1, 1, destination%matrix_struct%descriptor, 1)
665 END SUBROUTINE cp_cfm_to_cfm_matrix
675 SUBROUTINE cp_cfm_to_cfm_columns(msource, mtarget, ncol, source_start, &
678 TYPE(cp_cfm_type),
INTENT(IN) :: msource, mtarget
679 INTEGER,
INTENT(IN) :: ncol
680 INTEGER,
INTENT(IN),
OPTIONAL :: source_start, target_start
682 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_to_cfm_columns'
684 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: a, b
685 INTEGER :: handle, n, ss, ts
686 #if defined(__SCALAPACK)
688 INTEGER,
DIMENSION(9) :: desca, descb
691 CALL timeset(routinen, handle)
696 IF (
PRESENT(source_start)) ss = source_start
697 IF (
PRESENT(target_start)) ts = target_start
699 n = msource%matrix_struct%nrow_global
701 a => msource%local_data
702 b => mtarget%local_data
704 #if defined(__SCALAPACK)
705 desca(:) = msource%matrix_struct%descriptor(:)
706 descb(:) = mtarget%matrix_struct%descriptor(:)
708 CALL pzcopy(n, a(1, 1), 1, ss + i, desca, 1, b(1, 1), 1, ts + i, descb, 1)
711 CALL zcopy(ncol*n, a(1, ss), 1, b(1, ts), 1)
714 CALL timestop(handle)
716 END SUBROUTINE cp_cfm_to_cfm_columns
724 SUBROUTINE cp_cfm_to_cfm_triangular(msource, mtarget, uplo)
725 TYPE(cp_cfm_type),
INTENT(IN) :: msource, mtarget
726 CHARACTER(len=*),
INTENT(IN) :: uplo
728 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_to_cfm_triangular'
730 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: aa, bb
731 INTEGER :: handle, ncol, nrow
732 #if defined(__SCALAPACK)
733 INTEGER,
DIMENSION(9) :: desca, descb
736 CALL timeset(routinen, handle)
738 nrow = msource%matrix_struct%nrow_global
739 ncol = msource%matrix_struct%ncol_global
741 aa => msource%local_data
742 bb => mtarget%local_data
744 #if defined(__SCALAPACK)
745 desca(:) = msource%matrix_struct%descriptor(:)
746 descb(:) = mtarget%matrix_struct%descriptor(:)
747 CALL pzlacpy(uplo, nrow, ncol, aa(1, 1), 1, 1, desca, bb(1, 1), 1, 1, descb)
749 CALL zlacpy(uplo, nrow, ncol, aa(1, 1), nrow, bb(1, 1), nrow)
752 CALL timestop(handle)
753 END SUBROUTINE cp_cfm_to_cfm_triangular
766 TYPE(cp_cfm_type),
INTENT(IN) :: msource
767 TYPE(cp_fm_type),
INTENT(IN),
OPTIONAL :: mtargetr, mtargeti
769 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_to_fm'
771 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: zmat
773 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: imat, rmat
775 CALL timeset(routinen, handle)
777 zmat => msource%local_data
778 IF (
PRESENT(mtargetr))
THEN
779 rmat => mtargetr%local_data
781 (
SIZE(rmat, 1) .NE.
SIZE(zmat, 1)) .OR. &
782 (
SIZE(rmat, 2) .NE.
SIZE(zmat, 2)))
THEN
783 cpabort(
"size of local_data of mtargetr differ to msource")
786 rmat = real(zmat, kind=
dp)
790 IF (
PRESENT(mtargeti))
THEN
791 imat => mtargeti%local_data
793 (
SIZE(imat, 1) .NE.
SIZE(zmat, 1)) .OR. &
794 (
SIZE(imat, 2) .NE.
SIZE(zmat, 2)))
THEN
795 cpabort(
"size of local_data of mtargeti differ to msource")
798 imat = real(aimag(zmat), kind=
dp)
803 CALL timestop(handle)
817 TYPE(cp_fm_type),
INTENT(IN),
OPTIONAL :: msourcer, msourcei
818 TYPE(cp_cfm_type),
INTENT(IN) :: mtarget
820 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_fm_to_cfm'
822 COMPLEX(kind=dp),
DIMENSION(:, :),
POINTER :: zmat
823 INTEGER :: handle, mode
824 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: imat, rmat
826 CALL timeset(routinen, handle)
829 zmat => mtarget%local_data
830 IF (
PRESENT(msourcer))
THEN
831 rmat => msourcer%local_data
833 (
SIZE(rmat, 1) .NE.
SIZE(zmat, 1)) .OR. &
834 (
SIZE(rmat, 2) .NE.
SIZE(zmat, 2)))
THEN
835 cpabort(
"size of local_data of msourcer differ to mtarget")
841 IF (
PRESENT(msourcei))
THEN
842 imat => msourcei%local_data
844 (
SIZE(imat, 1) .NE.
SIZE(zmat, 1)) .OR. &
845 (
SIZE(imat, 2) .NE.
SIZE(zmat, 2)))
THEN
846 cpabort(
"size of local_data of msourcei differ to mtarget")
857 zmat(:, :) = cmplx(rmat(:, :), 0.0_dp, kind=
dp)
859 zmat(:, :) = cmplx(0.0_dp, imat(:, :), kind=
dp)
861 zmat(:, :) = cmplx(rmat(:, :), imat(:, :), kind=
dp)
864 CALL timestop(handle)
879 TYPE(cp_cfm_type),
INTENT(IN) :: source, destination
880 TYPE(mp_para_env_type),
INTENT(IN),
POINTER :: para_env
881 TYPE(copy_cfm_info_type),
INTENT(out) :: info
883 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_start_copy_general'
885 INTEGER :: dest_p_i, dest_q_j, global_rank, global_size, handle, i, j, k, mpi_rank, &
886 ncol_block_dest, ncol_block_src, ncol_local_recv, ncol_local_send, ncols, &
887 nrow_block_dest, nrow_block_src, nrow_local_recv, nrow_local_send, nrows, p, q, &
888 recv_rank, recv_size, send_rank, send_size
889 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: all_ranks, dest2global, dest_p, dest_q, &
890 recv_count, send_count, send_disp, &
891 source2global, src_p, src_q
892 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: dest_blacs2mpi
893 INTEGER,
DIMENSION(2) :: dest_block, dest_block_tmp, dest_num_pe, &
894 src_block, src_block_tmp, src_num_pe
895 INTEGER,
DIMENSION(:),
POINTER :: recv_col_indices, recv_row_indices, &
896 send_col_indices, send_row_indices
897 TYPE(cp_fm_struct_type),
POINTER :: recv_dist, send_dist
898 TYPE(mp_request_type),
DIMENSION(6) :: recv_req, send_req
900 CALL timeset(routinen, handle)
904 nrow_local_send =
SIZE(source%local_data, 1)
905 ncol_local_send =
SIZE(source%local_data, 2)
906 ALLOCATE (info%send_buf(nrow_local_send*ncol_local_send))
908 DO j = 1, ncol_local_send
909 DO i = 1, nrow_local_send
911 info%send_buf(k) = source%local_data(i, j)
915 NULLIFY (recv_dist, send_dist)
916 NULLIFY (recv_col_indices, recv_row_indices, send_col_indices, send_row_indices)
919 global_size = para_env%num_pe
920 global_rank = para_env%mepos
926 IF (
ASSOCIATED(destination%matrix_struct))
THEN
927 recv_dist => destination%matrix_struct
928 recv_rank = recv_dist%para_env%mepos
933 IF (
ASSOCIATED(source%matrix_struct))
THEN
934 send_dist => source%matrix_struct
935 send_rank = send_dist%para_env%mepos
941 ALLOCATE (all_ranks(0:global_size - 1))
943 CALL para_env%allgather(send_rank, all_ranks)
944 IF (
ASSOCIATED(destination%matrix_struct))
THEN
945 ALLOCATE (source2global(0:count(all_ranks .NE.
mp_proc_null) - 1))
946 DO i = 0, global_size - 1
948 source2global(all_ranks(i)) = i
953 CALL para_env%allgather(recv_rank, all_ranks)
954 IF (
ASSOCIATED(source%matrix_struct))
THEN
955 ALLOCATE (dest2global(0:count(all_ranks .NE.
mp_proc_null) - 1))
956 DO i = 0, global_size - 1
958 dest2global(all_ranks(i)) = i
962 DEALLOCATE (all_ranks)
969 IF (global_rank == 0)
THEN
971 CALL para_env%irecv(src_block,
mp_any_source, recv_req(1), tag=src_tag)
972 CALL para_env%irecv(dest_block,
mp_any_source, recv_req(2), tag=dest_tag)
973 CALL para_env%irecv(src_num_pe,
mp_any_source, recv_req(3), tag=src_tag)
974 CALL para_env%irecv(dest_num_pe,
mp_any_source, recv_req(4), tag=dest_tag)
977 IF (
ASSOCIATED(source%matrix_struct))
THEN
978 IF ((send_rank == 0))
THEN
980 src_block_tmp = (/send_dist%nrow_block, send_dist%ncol_block/)
981 CALL para_env%isend(src_block_tmp, 0, send_req(1), tag=src_tag)
982 CALL para_env%isend(send_dist%context%num_pe, 0, send_req(2), tag=src_tag)
986 IF (
ASSOCIATED(destination%matrix_struct))
THEN
987 IF ((recv_rank == 0))
THEN
988 dest_block_tmp = (/recv_dist%nrow_block, recv_dist%ncol_block/)
989 CALL para_env%isend(dest_block_tmp, 0, send_req(3), tag=dest_tag)
990 CALL para_env%isend(recv_dist%context%num_pe, 0, send_req(4), tag=dest_tag)
994 IF (global_rank == 0)
THEN
995 CALL mp_waitall(recv_req(1:4))
997 ALLOCATE (info%src_blacs2mpi(0:src_num_pe(1) - 1, 0:src_num_pe(2) - 1), &
998 dest_blacs2mpi(0:dest_num_pe(1) - 1, 0:dest_num_pe(2) - 1))
999 CALL para_env%irecv(info%src_blacs2mpi,
mp_any_source, recv_req(5), tag=src_tag)
1000 CALL para_env%irecv(dest_blacs2mpi,
mp_any_source, recv_req(6), tag=dest_tag)
1003 IF (
ASSOCIATED(source%matrix_struct))
THEN
1004 IF ((send_rank == 0))
THEN
1005 CALL para_env%isend(send_dist%context%blacs2mpi(:, :), 0, send_req(5), tag=src_tag)
1009 IF (
ASSOCIATED(destination%matrix_struct))
THEN
1010 IF ((recv_rank == 0))
THEN
1011 CALL para_env%isend(recv_dist%context%blacs2mpi(:, :), 0, send_req(6), tag=dest_tag)
1015 IF (global_rank == 0)
THEN
1016 CALL mp_waitall(recv_req(5:6))
1020 CALL para_env%bcast(src_block, 0)
1021 CALL para_env%bcast(dest_block, 0)
1022 CALL para_env%bcast(src_num_pe, 0)
1023 CALL para_env%bcast(dest_num_pe, 0)
1024 info%src_num_pe(1:2) = src_num_pe(1:2)
1025 info%nblock_src(1:2) = src_block(1:2)
1026 IF (global_rank /= 0)
THEN
1027 ALLOCATE (info%src_blacs2mpi(0:src_num_pe(1) - 1, 0:src_num_pe(2) - 1), &
1028 dest_blacs2mpi(0:dest_num_pe(1) - 1, 0:dest_num_pe(2) - 1))
1030 CALL para_env%bcast(info%src_blacs2mpi, 0)
1031 CALL para_env%bcast(dest_blacs2mpi, 0)
1033 recv_size = dest_num_pe(1)*dest_num_pe(2)
1034 send_size = src_num_pe(1)*src_num_pe(2)
1035 info%send_size = send_size
1036 CALL mp_waitall(send_req(:))
1053 IF (
ASSOCIATED(destination%matrix_struct))
THEN
1055 col_indices=recv_col_indices)
1056 info%recv_col_indices => recv_col_indices
1057 info%recv_row_indices => recv_row_indices
1058 nrow_block_src = src_block(1)
1059 ncol_block_src = src_block(2)
1060 ALLOCATE (recv_count(0:send_size - 1), info%recv_disp(0:send_size - 1), info%recv_request(0:send_size - 1))
1063 nrow_local_recv = recv_dist%nrow_locals(recv_dist%context%mepos(1))
1064 ncol_local_recv = recv_dist%ncol_locals(recv_dist%context%mepos(2))
1065 info%nlocal_recv(1) = nrow_local_recv
1066 info%nlocal_recv(2) = ncol_local_recv
1068 ALLOCATE (src_p(nrow_local_recv), src_q(ncol_local_recv))
1069 DO i = 1, nrow_local_recv
1072 src_p(i) = mod(((recv_row_indices(i) - 1)/nrow_block_src), src_num_pe(1))
1074 DO j = 1, ncol_local_recv
1076 src_q(j) = mod(((recv_col_indices(j) - 1)/ncol_block_src), src_num_pe(2))
1080 DO q = 0, src_num_pe(2) - 1
1081 ncols = count(src_q .EQ. q)
1082 DO p = 0, src_num_pe(1) - 1
1083 nrows = count(src_p .EQ. p)
1085 recv_count(info%src_blacs2mpi(p, q)) = nrows*ncols
1088 DEALLOCATE (src_p, src_q)
1092 ALLOCATE (info%recv_buf(sum(recv_count(:))))
1093 info%recv_disp(0) = 0
1094 DO i = 1, send_size - 1
1095 info%recv_disp(i) = info%recv_disp(i - 1) + recv_count(i - 1)
1099 DO k = 0, send_size - 1
1100 IF (recv_count(k) .GT. 0)
THEN
1101 CALL para_env%irecv(info%recv_buf(info%recv_disp(k) + 1:info%recv_disp(k) + recv_count(k)), &
1102 source2global(k), info%recv_request(k))
1107 DEALLOCATE (source2global)
1111 IF (
ASSOCIATED(source%matrix_struct))
THEN
1113 col_indices=send_col_indices)
1114 nrow_block_dest = dest_block(1)
1115 ncol_block_dest = dest_block(2)
1116 ALLOCATE (send_count(0:recv_size - 1), send_disp(0:recv_size - 1), info%send_request(0:recv_size - 1))
1119 nrow_local_send = send_dist%nrow_locals(send_dist%context%mepos(1))
1120 ncol_local_send = send_dist%ncol_locals(send_dist%context%mepos(2))
1124 ALLOCATE (dest_p(nrow_local_send), dest_q(ncol_local_send))
1126 DO i = 1, nrow_local_send
1128 dest_p(i) = mod(((send_row_indices(i) - 1)/nrow_block_dest), dest_num_pe(1))
1130 DO j = 1, ncol_local_send
1131 dest_q(j) = mod(((send_col_indices(j) - 1)/ncol_block_dest), dest_num_pe(2))
1135 DO q = 0, dest_num_pe(2) - 1
1136 ncols = count(dest_q .EQ. q)
1137 DO p = 0, dest_num_pe(1) - 1
1138 nrows = count(dest_p .EQ. p)
1139 send_count(dest_blacs2mpi(p, q)) = nrows*ncols
1142 DEALLOCATE (dest_p, dest_q)
1145 ALLOCATE (info%send_buf(sum(send_count(:))))
1147 DO k = 1, recv_size - 1
1148 send_disp(k) = send_disp(k - 1) + send_count(k - 1)
1153 DO j = 1, ncol_local_send
1155 dest_q_j = mod(((send_col_indices(j) - 1)/ncol_block_dest), dest_num_pe(2))
1156 DO i = 1, nrow_local_send
1157 dest_p_i = mod(((send_row_indices(i) - 1)/nrow_block_dest), dest_num_pe(1))
1158 mpi_rank = dest_blacs2mpi(dest_p_i, dest_q_j)
1159 send_count(mpi_rank) = send_count(mpi_rank) + 1
1160 info%send_buf(send_disp(mpi_rank) + send_count(mpi_rank)) = source%local_data(i, j)
1165 DO k = 0, recv_size - 1
1166 IF (send_count(k) .GT. 0)
THEN
1167 CALL para_env%isend(info%send_buf(send_disp(k) + 1:send_disp(k) + send_count(k)), &
1168 dest2global(k), info%send_request(k))
1173 DEALLOCATE (send_count, send_disp, dest2global)
1175 DEALLOCATE (dest_blacs2mpi)
1179 CALL timestop(handle)
1191 TYPE(cp_cfm_type),
INTENT(IN) :: destination
1192 TYPE(copy_cfm_info_type),
INTENT(inout) :: info
1194 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_finish_copy_general'
1196 INTEGER :: handle, i, j, k, mpi_rank, ni, nj, &
1198 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: recv_count, src_p_i
1199 INTEGER,
DIMENSION(:),
POINTER :: recv_col_indices, recv_row_indices
1201 CALL timeset(routinen, handle)
1206 DO j = 1,
SIZE(destination%local_data, 2)
1207 DO i = 1,
SIZE(destination%local_data, 1)
1209 destination%local_data(i, j) = info%send_buf(k)
1212 DEALLOCATE (info%send_buf)
1215 recv_col_indices => info%recv_col_indices
1216 recv_row_indices => info%recv_row_indices
1220 CALL mp_waitall(info%recv_request(:))
1222 nj = info%nlocal_recv(2)
1223 ni = info%nlocal_recv(1)
1224 ALLOCATE (recv_count(0:info%send_size - 1), src_p_i(ni))
1229 src_p_i(i) = mod(((recv_row_indices(i) - 1)/info%nblock_src(1)), info%src_num_pe(1))
1233 src_q_j = mod(((recv_col_indices(j) - 1)/info%nblock_src(2)), info%src_num_pe(2))
1235 mpi_rank = info%src_blacs2mpi(src_p_i(i), src_q_j)
1236 recv_count(mpi_rank) = recv_count(mpi_rank) + 1
1237 destination%local_data(i, j) = info%recv_buf(info%recv_disp(mpi_rank) + recv_count(mpi_rank))
1241 DEALLOCATE (recv_count, src_p_i)
1243 NULLIFY (info%recv_col_indices, info%recv_row_indices)
1244 DEALLOCATE (info%recv_disp, info%recv_request, info%recv_buf, info%src_blacs2mpi)
1247 CALL timestop(handle)
1258 TYPE(copy_cfm_info_type),
INTENT(inout) :: info
1260 CHARACTER(len=*),
PARAMETER :: routinen =
'cp_cfm_cleanup_copy_general'
1264 CALL timeset(routinen, handle)
1270 IF (
ALLOCATED(info%src_blacs2mpi))
DEALLOCATE (info%src_blacs2mpi)
1271 CALL mp_waitall(info%send_request(:))
1272 DEALLOCATE (info%send_request, info%send_buf)
1275 CALL timestop(handle)
methods related to the blacs parallel environment
Represents a complex full matrix distributed on many processors.
subroutine, public cp_cfm_get_submatrix(fm, target_m, start_row, start_col, n_rows, n_cols, transpose)
Extract a sub-matrix from the full matrix: op(target_m)(1:n_rows,1:n_cols) = fm(start_row:start_row+n...
subroutine, public cp_cfm_get_element(matrix, irow_global, icol_global, alpha)
Get the matrix element by its global index.
subroutine, public cp_cfm_create(matrix, matrix_struct, name)
Creates a new full matrix with the given structure.
subroutine, public cp_cfm_release(matrix)
Releases a full matrix.
subroutine, public cp_cfm_set_element(matrix, irow_global, icol_global, alpha)
Set the matrix element (irow_global,icol_global) of the full matrix to alpha.
subroutine, public cp_cfm_start_copy_general(source, destination, para_env, info)
Initiate the copy operation: get distribution data, post MPI isend and irecvs.
subroutine, public cp_fm_to_cfm(msourcer, msourcei, mtarget)
Construct a complex full matrix by taking its real and imaginary parts from two separate real-value f...
subroutine, public cp_cfm_cleanup_copy_general(info)
Complete the copy operation: wait for comms clean up MPI state.
subroutine, public cp_cfm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, matrix_struct, para_env)
Returns information about a full matrix.
subroutine, public cp_cfm_set_submatrix(matrix, new_values, start_row, start_col, n_rows, n_cols, alpha, beta, transpose)
Set a sub-matrix of the full matrix: matrix(start_row:start_row+n_rows,start_col:start_col+n_cols) = ...
subroutine, public cp_cfm_set_all(matrix, alpha, beta)
Set all elements of the full matrix to alpha. Besides, set all diagonal matrix elements to beta (if g...
subroutine, public cp_cfm_to_fm(msource, mtargetr, mtargeti)
Copy real and imaginary parts of a complex full matrix into separate real-value full matrices.
subroutine, public cp_cfm_finish_copy_general(destination, info)
Complete the copy operation: wait for comms, unpack, clean up MPI state.
represent the structure of a full matrix
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
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_release(fmstruct)
releases a full matrix structure
represent a full matrix distributed on many processors
Defines the basic variable types.
integer, parameter, public dp
Definition of mathematical constants and functions.
complex(kind=dp), parameter, public z_one
complex(kind=dp), parameter, public z_zero
Interface to the message passing library MPI.
integer, parameter, public mp_proc_null
logical, parameter, public cp2k_is_parallel
integer, parameter, public mp_any_source
type(mp_request_type), parameter, public mp_request_null