testsuite: add library dependencies for tests
[mpich.git] / test / mpi / f77 / topo / dgraph_wgtf.f
1 C -*- Mode: Fortran; -*- 
2 C
3 C  (C) 2011 by Argonne National Laboratory.
4 C      See COPYRIGHT in top-level directory.
5 C
6 C     This program is Fortran version of dgraph_unwgt.c
7 C     Specify a distributed graph of a bidirectional ring of the MPI_COMM_WORLD,
8 C     i.e. everyone only talks to left and right neighbors.
9
10       logical function validate_dgraph(dgraph_comm)
11       implicit none
12       include 'mpif.h'
13
14       integer     dgraph_comm
15       integer     comm_topo
16       integer     src_sz, dest_sz
17       integer     ierr;
18       logical     wgt_flag;
19       integer     srcs(2), dests(2)
20       integer     src_wgts(2), dest_wgts(2)
21
22       integer     world_rank, world_size;
23       integer     idx, nbr_sep
24
25       comm_topo = MPI_UNDEFINED
26       call MPI_Topo_test(dgraph_comm, comm_topo, ierr);
27       if (comm_topo .ne. MPI_DIST_GRAPH) then
28           validate_dgraph = .false.
29           write(6,*) "dgraph_comm is NOT of type MPI_DIST_GRAPH."
30           return
31       endif
32
33       call MPI_Dist_graph_neighbors_count(dgraph_comm,
34      &                                    src_sz, dest_sz, wgt_flag,
35      &                                    ierr)
36       if (ierr .ne. MPI_SUCCESS) then
37           validate_dgraph = .false.
38           write(6,*) "MPI_Dist_graph_neighbors_count() fails!"
39           return
40       endif
41       if (.not. wgt_flag) then
42           validate_dgraph = .false.
43           write(6,*) "dgraph_comm is created with MPI_UNWEIGHTED!"
44           return
45       endif
46
47       if (src_sz .ne. 2 .or. dest_sz .ne. 2) then
48           validate_dgraph = .false.
49           write(6,*) "source or destination edge array is not size 2." 
50           write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz
51           return
52       endif
53
54       call MPI_Dist_graph_neighbors(dgraph_comm,
55      &                              src_sz, srcs, src_wgts,
56      &                              dest_sz, dests, dest_wgts,
57      &                              ierr)
58       if (ierr .ne. MPI_SUCCESS) then
59           validate_dgraph = .false.
60           write(6,*) "MPI_Dist_graph_neighbors() fails!"
61           return
62       endif
63
64 C     Check if the neighbors returned from MPI are really
65 C     the nearest neighbors that within a ring.
66       call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
67       call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
68  
69       do idx = 1, src_sz
70           nbr_sep = iabs(srcs(idx) - world_rank)
71           if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
72               validate_dgraph = .false.
73               write(6,"('srcs[',I3,']=',I3,
74      &                  ' is NOT a neighbor of my rank',I3)")
75      &              idx, srcs(idx), world_rank
76               return
77           endif
78       enddo
79       if (src_wgts(1) .ne. src_wgts(2)) then
80           validate_dgraph = .false.
81           write(6,"('src_wgts = [',I3,',',I3,']')")
82      &          src_wgts(1), src_wgts(2)
83           return
84       endif
85       do idx = 1, dest_sz
86           nbr_sep = iabs(dests(idx) - world_rank)
87           if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
88               validate_dgraph = .false.
89               write(6,"('dests[',I3,']=',I3,
90      &                  ' is NOT a neighbor of my rank',I3)")
91      &              idx, dests(idx), world_rank
92               return
93           endif
94       enddo
95       if (dest_wgts(1) .ne. dest_wgts(2)) then
96           validate_dgraph = .false.
97           write(6,"('dest_wgts = [',I3,',',I3,']')")
98      &          dest_wgts(1), dest_wgts(2)
99           return
100       endif
101
102       validate_dgraph = .true.
103       return
104       end
105
106       integer function ring_rank(world_size, in_rank)
107       implicit none
108       integer world_size, in_rank
109       if (in_rank .ge. 0 .and. in_rank .lt. world_size) then
110           ring_rank = in_rank
111           return
112       endif
113       if (in_rank .lt. 0 ) then
114           ring_rank = in_rank + world_size
115           return
116       endif
117       if (in_rank .ge. world_size) then
118           ring_rank = in_rank - world_size
119           return
120       endif
121       ring_rank = -99999
122       return
123       end
124
125
126
127       program dgraph_unwgt
128       implicit none
129       include 'mpif.h'
130
131       integer    ring_rank
132       external   ring_rank
133       logical    validate_dgraph
134       external   validate_dgraph
135       integer    errs, ierr
136
137       integer    dgraph_comm
138       integer    world_size, world_rank
139       integer    src_sz, dest_sz
140       integer    degs(1)
141       integer    srcs(2), dests(2)
142       integer    src_wgts(2), dest_wgts(2)
143
144       errs = 0
145       call MTEST_Init(ierr) 
146       call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
147       call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
148
149       srcs(1)      = world_rank
150       degs(1)      = 2;
151       dests(1)     = ring_rank(world_size, world_rank-1)
152       dests(2)     = ring_rank(world_size, world_rank+1)
153       dest_wgts(1) = 1
154       dest_wgts(2) = 1
155       call MPI_Dist_graph_create(MPI_COMM_WORLD, 1, srcs, degs, dests,
156      &                           dest_wgts, MPI_INFO_NULL,
157      &                          .true., dgraph_comm, ierr)
158       if (ierr .ne. MPI_SUCCESS) then
159           write(6,*) "MPI_Dist_graph_create() fails!"
160           call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
161           stop
162       endif
163       if (.not. validate_dgraph(dgraph_comm)) then
164           write(6,*) "MPI_Dist_graph_create() does not create "
165      &               //"a bidirectional ring graph!"
166           call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
167           stop
168       endif
169       call MPI_Comm_free(dgraph_comm, ierr)
170
171       src_sz       = 2
172       srcs(1)      = ring_rank(world_size, world_rank-1)
173       srcs(2)      = ring_rank(world_size, world_rank+1)
174       src_wgts(1)  = 1
175       src_wgts(2)  = 1
176       dest_sz      = 2
177       dests(1)     = ring_rank(world_size, world_rank-1)
178       dests(2)     = ring_rank(world_size, world_rank+1)
179       dest_wgts(1) = 1
180       dest_wgts(2) = 1
181       call MPI_Dist_graph_create_adjacent(MPI_COMM_WORLD,
182      &                                    src_sz, srcs, src_wgts,
183      &                                    dest_sz, dests, dest_wgts,
184      &                                    MPI_INFO_NULL, .true.,
185      &                                    dgraph_comm, ierr)
186       if (ierr .ne. MPI_SUCCESS) then
187           write(6,*) "MPI_Dist_graph_create_adjacent() fails!"
188           call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
189           stop
190       endif
191       if (.not. validate_dgraph(dgraph_comm)) then
192           write(6,*) "MPI_Dist_graph_create_adjacent() does not create "
193      &               //"a bidirectional ring graph!"
194           call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
195           stop
196       endif
197       call MPI_Comm_free(dgraph_comm, ierr)
198
199       call MTEST_Finalize(errs)
200       call MPI_Finalize(ierr)
201       end