! This file created from test/mpi/f77/topo/dgraph_wgtf.f with f77tof90 ! -*- Mode: Fortran; -*- ! ! (C) 2011 by Argonne National Laboratory. ! See COPYRIGHT in top-level directory. ! ! This program is Fortran version of dgraph_unwgt.c ! Specify a distributed graph of a bidirectional ring of the MPI_COMM_WORLD, ! i.e. everyone only talks to left and right neighbors. logical function validate_dgraph(dgraph_comm) use mpi integer dgraph_comm integer comm_topo integer src_sz, dest_sz integer ierr; logical wgt_flag; integer srcs(2), dests(2) integer src_wgts(2), dest_wgts(2) integer world_rank, world_size; integer idx, nbr_sep comm_topo = MPI_UNDEFINED call MPI_Topo_test(dgraph_comm, comm_topo, ierr); if (comm_topo .ne. MPI_DIST_GRAPH) then validate_dgraph = .false. write(6,*) "dgraph_comm is NOT of type MPI_DIST_GRAPH." return endif call MPI_Dist_graph_neighbors_count(dgraph_comm, & & src_sz, dest_sz, wgt_flag, & & ierr) if (ierr .ne. MPI_SUCCESS) then validate_dgraph = .false. write(6,*) "MPI_Dist_graph_neighbors_count() fails!" return endif if (.not. wgt_flag) then validate_dgraph = .false. write(6,*) "dgraph_comm is created with MPI_UNWEIGHTED!" return endif if (src_sz .ne. 2 .or. dest_sz .ne. 2) then validate_dgraph = .false. write(6,*) "source or destination edge array is not size 2." write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz return endif call MPI_Dist_graph_neighbors(dgraph_comm, & & src_sz, srcs, src_wgts, & & dest_sz, dests, dest_wgts, & & ierr) if (ierr .ne. MPI_SUCCESS) then validate_dgraph = .false. write(6,*) "MPI_Dist_graph_neighbors() fails!" return endif ! Check if the neighbors returned from MPI are really ! the nearest neighbors that within a ring. call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr) call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr) do idx = 1, src_sz nbr_sep = iabs(srcs(idx) - world_rank) if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then validate_dgraph = .false. write(6,"('srcs[',I3,']=',I3, & & ' is NOT a neighbor of my rank',I3)") & & idx, srcs(idx), world_rank return endif enddo if (src_wgts(1) .ne. src_wgts(2)) then validate_dgraph = .false. write(6,"('src_wgts = [',I3,',',I3,']')") & & src_wgts(1), src_wgts(2) return endif do idx = 1, dest_sz nbr_sep = iabs(dests(idx) - world_rank) if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then validate_dgraph = .false. write(6,"('dests[',I3,']=',I3, & & ' is NOT a neighbor of my rank',I3)") & & idx, dests(idx), world_rank return endif enddo if (dest_wgts(1) .ne. dest_wgts(2)) then validate_dgraph = .false. write(6,"('dest_wgts = [',I3,',',I3,']')") & & dest_wgts(1), dest_wgts(2) return endif validate_dgraph = .true. return end integer function ring_rank(world_size, in_rank) integer world_size, in_rank if (in_rank .ge. 0 .and. in_rank .lt. world_size) then ring_rank = in_rank return endif if (in_rank .lt. 0 ) then ring_rank = in_rank + world_size return endif if (in_rank .ge. world_size) then ring_rank = in_rank - world_size return endif ring_rank = -99999 return end program dgraph_unwgt use mpi integer ring_rank external ring_rank logical validate_dgraph external validate_dgraph integer errs, ierr integer dgraph_comm integer world_size, world_rank integer src_sz, dest_sz integer degs(1) integer srcs(2), dests(2) integer src_wgts(2), dest_wgts(2) errs = 0 call MTEST_Init(ierr) call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr) call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr) srcs(1) = world_rank degs(1) = 2; dests(1) = ring_rank(world_size, world_rank-1) dests(2) = ring_rank(world_size, world_rank+1) dest_wgts(1) = 1 dest_wgts(2) = 1 call MPI_Dist_graph_create(MPI_COMM_WORLD, 1, srcs, degs, dests, & & dest_wgts, MPI_INFO_NULL, & & .true., dgraph_comm, ierr) if (ierr .ne. MPI_SUCCESS) then write(6,*) "MPI_Dist_graph_create() fails!" call MPI_Abort(MPI_COMM_WORLD, 1, ierr) stop endif if (.not. validate_dgraph(dgraph_comm)) then write(6,*) "MPI_Dist_graph_create() does not create " & & //"a bidirectional ring graph!" call MPI_Abort(MPI_COMM_WORLD, 1, ierr) stop endif call MPI_Comm_free(dgraph_comm, ierr) src_sz = 2 srcs(1) = ring_rank(world_size, world_rank-1) srcs(2) = ring_rank(world_size, world_rank+1) src_wgts(1) = 1 src_wgts(2) = 1 dest_sz = 2 dests(1) = ring_rank(world_size, world_rank-1) dests(2) = ring_rank(world_size, world_rank+1) dest_wgts(1) = 1 dest_wgts(2) = 1 call MPI_Dist_graph_create_adjacent(MPI_COMM_WORLD, & & src_sz, srcs, src_wgts, & & dest_sz, dests, dest_wgts, & & MPI_INFO_NULL, .true., & & dgraph_comm, ierr) if (ierr .ne. MPI_SUCCESS) then write(6,*) "MPI_Dist_graph_create_adjacent() fails!" call MPI_Abort(MPI_COMM_WORLD, 1, ierr) stop endif if (.not. validate_dgraph(dgraph_comm)) then write(6,*) "MPI_Dist_graph_create_adjacent() does not create " & & //"a bidirectional ring graph!" call MPI_Abort(MPI_COMM_WORLD, 1, ierr) stop endif call MPI_Comm_free(dgraph_comm, ierr) call MTEST_Finalize(errs) call MPI_Finalize(ierr) end