1! 2! Copyright (C) by Argonne National Laboratory 3! See COPYRIGHT in top-level directory 4! 5 6subroutine PMPIR_Dist_graph_create_adjacent_f08(comm_old, indegree, sources, sourceweights, & 7 outdegree, destinations, destweights, info, reorder, comm_dist_graph, ierror) 8 use, intrinsic :: iso_c_binding, only : c_int, c_ptr, c_loc, c_associated 9 use :: mpi_f08, only : MPI_Comm, MPI_Info 10 use :: mpi_f08, only : MPI_UNWEIGHTED, MPI_WEIGHTS_EMPTY, MPIR_C_MPI_UNWEIGHTED, MPIR_C_MPI_WEIGHTS_EMPTY 11 use :: mpi_c_interface, only : c_Comm, c_Info 12 use :: mpi_c_interface, only : MPIR_Dist_graph_create_adjacent_c 13 14 implicit none 15 16 type(MPI_Comm), intent(in) :: comm_old 17 integer, intent(in) :: indegree 18 integer, intent(in) :: sources(indegree) 19 integer, intent(in), target :: sourceweights(indegree) 20 integer, intent(in) :: outdegree 21 integer, intent(in) :: destinations(outdegree) 22 integer, intent(in), target :: destweights(outdegree) 23 type(MPI_Info), intent(in) :: info 24 logical, intent(in) :: reorder 25 type(MPI_Comm), intent(out) :: comm_dist_graph 26 integer, optional, intent(out) :: ierror 27 28 integer(c_Comm) :: comm_old_c 29 integer(c_int) :: indegree_c 30 integer(c_int) :: sources_c(indegree) 31 integer(c_int), target :: sourceweights_c(indegree) 32 integer(c_int) :: outdegree_c 33 integer(c_int) :: destinations_c(outdegree) 34 integer(c_int), target :: destweights_c(outdegree) 35 integer(c_Info) :: info_c 36 integer(c_int) :: reorder_c 37 integer(c_Comm) :: comm_dist_graph_c 38 integer(c_int) :: ierror_c 39 40 type(c_ptr) :: sourceweights_cptr, destweights_cptr 41 42 reorder_c = merge(1, 0, reorder) 43 44 if (c_int == kind(0)) then 45 if (c_associated(c_loc(sourceweights), c_loc(MPI_UNWEIGHTED))) then 46 sourceweights_cptr = MPIR_C_MPI_UNWEIGHTED 47 else if (c_associated(c_loc(sourceweights), c_loc(MPI_WEIGHTS_EMPTY))) then 48 sourceweights_cptr = MPIR_C_MPI_WEIGHTS_EMPTY 49 else 50 sourceweights_cptr = c_loc(sourceweights) 51 end if 52 53 if (c_associated(c_loc(destweights), c_loc(MPI_UNWEIGHTED))) then 54 destweights_cptr = MPIR_C_MPI_UNWEIGHTED 55 else if (c_associated(c_loc(destweights), c_loc(MPI_WEIGHTS_EMPTY))) then 56 destweights_cptr = MPIR_C_MPI_WEIGHTS_EMPTY 57 else 58 destweights_cptr = c_loc(destweights) 59 end if 60 61 ierror_c = MPIR_Dist_graph_create_adjacent_c(comm_old%MPI_VAL, indegree, sources, sourceweights_cptr, outdegree, & 62 destinations, destweights_cptr, info%MPI_VAL, reorder_c, comm_dist_graph%MPI_VAL) 63 else 64 comm_old_c = comm_old%MPI_VAL 65 indegree_c = indegree 66 sources_c = sources 67 outdegree_c = outdegree 68 destinations_c = destinations 69 info_c = info%MPI_VAL 70 71 if (c_associated(c_loc(sourceweights), c_loc(MPI_UNWEIGHTED))) then 72 sourceweights_cptr = MPIR_C_MPI_UNWEIGHTED 73 else if (c_associated(c_loc(sourceweights), c_loc(MPI_WEIGHTS_EMPTY))) then 74 sourceweights_cptr = MPIR_C_MPI_WEIGHTS_EMPTY 75 else 76 sourceweights_c = sourceweights 77 sourceweights_cptr = c_loc(sourceweights_c) 78 end if 79 80 if (c_associated(c_loc(destweights), c_loc(MPI_UNWEIGHTED))) then 81 destweights_cptr = MPIR_C_MPI_UNWEIGHTED 82 else if (c_associated(c_loc(destweights), c_loc(MPI_WEIGHTS_EMPTY))) then 83 destweights_cptr = MPIR_C_MPI_WEIGHTS_EMPTY 84 else 85 destweights_c = destweights 86 destweights_cptr = c_loc(destweights_c) 87 end if 88 89 ierror_c = MPIR_Dist_graph_create_adjacent_c(comm_old_c, indegree_c, sources_c, sourceweights_cptr, outdegree_c, & 90 destinations_c, destweights_cptr, info_c, reorder_c, comm_dist_graph_c) 91 92 comm_dist_graph%MPI_VAL = comm_dist_graph_c 93 endif 94 95 if(present(ierror)) ierror = ierror_c 96 97end subroutine PMPIR_Dist_graph_create_adjacent_f08 98