1C 2C Copyright (C) by Argonne National Laboratory 3C See COPYRIGHT in top-level directory 4C 5 6 program main 7 implicit none 8 include 'mpif.h' 9 integer ierr, errs 10 integer i, ans, size, rank, color, comm, newcomm 11 integer maxSize, displ 12 parameter (maxSize=128) 13 integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) 14 integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) 15 integer sbuf(maxSize), rbuf(maxSize) 16 17 errs = 0 18 19 call mtest_init( ierr ) 20 21C Get a comm 22 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) 23 call mpi_comm_size( comm, size, ierr ) 24 if (size .gt. maxSize) then 25 call mpi_comm_rank( comm, rank, ierr ) 26 color = 1 27 if (rank .lt. maxSize) color = 0 28 call mpi_comm_split( comm, color, rank, newcomm, ierr ) 29 call mpi_comm_free( comm, ierr ) 30 comm = newcomm 31 call mpi_comm_size( comm, size, ierr ) 32 endif 33 call mpi_comm_rank( comm, rank, ierr ) 34C 35 if (size .le. maxSize) then 36C Initialize the data. Just use this as an all to all 37C Use the same test as alltoallwf.c , except displacements are in units of 38C integers instead of bytes 39 do i=1, size 40 scounts(i) = 1 41 sdispls(i) = (i-1) 42 stypes(i) = MPI_INTEGER 43 sbuf(i) = rank * size + i 44 rcounts(i) = 1 45 rdispls(i) = (i-1) 46 rtypes(i) = MPI_INTEGER 47 rbuf(i) = -1 48 enddo 49 call mpi_alltoallv( sbuf, scounts, sdispls, stypes, 50 & rbuf, rcounts, rdispls, rtypes, comm, ierr ) 51C 52C check rbuf(i) = data from the ith location of the ith send buf, or 53C rbuf(i) = (i-1) * size + i 54 do i=1, size 55 ans = (i-1) * size + rank + 1 56 if (rbuf(i) .ne. ans) then 57 errs = errs + 1 58 print *, rank, ' rbuf(', i, ') = ', rbuf(i), 59 & ' expected ', ans 60 endif 61 enddo 62C 63C A halo-exchange example - mostly zero counts 64C 65 do i=1, size 66 scounts(i) = 0 67 sdispls(i) = 0 68 stypes(i) = MPI_INTEGER 69 sbuf(i) = -1 70 rcounts(i) = 0 71 rdispls(i) = 0 72 rtypes(i) = MPI_INTEGER 73 rbuf(i) = -1 74 enddo 75 76C 77C Note that the arrays are 1-origin 78 displ = 0 79 if (rank .gt. 0) then 80 scounts(1+rank-1) = 1 81 rcounts(1+rank-1) = 1 82 sdispls(1+rank-1) = displ 83 rdispls(1+rank-1) = rank - 1 84 sbuf(1+displ) = rank 85 displ = displ + 1 86 endif 87 scounts(1+rank) = 1 88 rcounts(1+rank) = 1 89 sdispls(1+rank) = displ 90 rdispls(1+rank) = rank 91 sbuf(1+displ) = rank 92 displ = displ + 1 93 if (rank .lt. size-1) then 94 scounts(1+rank+1) = 1 95 rcounts(1+rank+1) = 1 96 sdispls(1+rank+1) = displ 97 rdispls(1+rank+1) = rank+1 98 sbuf(1+displ) = rank 99 displ = displ + 1 100 endif 101 102 call mpi_alltoallv( sbuf, scounts, sdispls, stypes, 103 & rbuf, rcounts, rdispls, rtypes, comm, ierr ) 104C 105C Check the neighbor values are correctly moved 106C 107 if (rank .gt. 0) then 108 if (rbuf(1+rank-1) .ne. rank-1) then 109 errs = errs + 1 110 print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1), 111 & 'expected ', rank-1 112 endif 113 endif 114 if (rbuf(1+rank) .ne. rank) then 115 errs = errs + 1 116 print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank), 117 & 'expected ', rank 118 endif 119 if (rank .lt. size-1) then 120 if (rbuf(1+rank+1) .ne. rank+1) then 121 errs = errs + 1 122 print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1), 123 & 'expected ', rank+1 124 endif 125 endif 126 do i=0,rank-2 127 if (rbuf(1+i) .ne. -1) then 128 errs = errs + 1 129 print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i), 130 & 'expected -1' 131 endif 132 enddo 133 do i=rank+2,size-1 134 if (rbuf(1+i) .ne. -1) then 135 errs = errs + 1 136 print *, rank, ' rbuf(', i, ') = ', rbuf(1+i), 137 & 'expected -1' 138 endif 139 enddo 140 endif 141 call mpi_comm_free( comm, ierr ) 142 143 call mtest_finalize( errs ) 144 end 145 146