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
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)
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)
879 TYPE(
cp_cfm_type),
INTENT(IN) :: source, destination
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
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
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
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
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)