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