|
| 1 | +! BSD 3-Clause License |
| 2 | +! |
| 3 | +! Copyright (c) 2016, Sourcery Institute |
| 4 | +! All rights reserved. |
| 5 | +! |
| 6 | +! Redistribution and use in source and binary forms, with or without |
| 7 | +! modification, are permitted provided that the following conditions are met: |
| 8 | +! |
| 9 | +! * Redistributions of source code must retain the above copyright notice, this |
| 10 | +! list of conditions and the following disclaimer. |
| 11 | +! |
| 12 | +! * Redistributions in binary form must reproduce the above copyright notice, |
| 13 | +! this list of conditions and the following disclaimer in the documentation |
| 14 | +! and/or other materials provided with the distribution. |
| 15 | +! |
| 16 | +! * Neither the name of the copyright holder nor the names of its |
| 17 | +! contributors may be used to endorse or promote products derived from |
| 18 | +! this software without specific prior written permission. |
| 19 | +! |
| 20 | +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| 21 | +! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| 22 | +! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE |
| 23 | +! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE |
| 24 | +! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| 25 | +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| 26 | +! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| 27 | +! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, |
| 28 | +! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE |
| 29 | +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| 30 | +program main |
| 31 | + !! summary: Test get_commiunicator function, an OpenCoarrays-specific language extension |
| 32 | + use opencoarrays, only : get_communicator |
| 33 | + |
| 34 | + implicit none |
| 35 | + |
| 36 | + call mpi_matches_caf(get_communicator()) |
| 37 | + !! verify # ranks = # images and image number = rank + 1 |
| 38 | + |
| 39 | + block |
| 40 | + use iso_fortran_env, only : team_type |
| 41 | + use opencoarrays, only : get_communicator, team_number !! TODO: remove team_number once gfortran supports it |
| 42 | + |
| 43 | + type(team_type) :: league |
| 44 | + integer, parameter :: num_teams=2 |
| 45 | + !! number of child teams to form from the parent initial team |
| 46 | + |
| 47 | + associate(initial_image=>this_image(), initial_num_images=>num_images(), chosen_team=>destination_team(this_image(),num_teams)) |
| 48 | + |
| 49 | + form team(chosen_team,league) |
| 50 | + !! map images to num_teams teams |
| 51 | + |
| 52 | + change team(league) |
| 53 | + !! join my destination team |
| 54 | + |
| 55 | + call mpi_matches_caf(get_communicator()) |
| 56 | + !! verify new # ranks = new # images and new image number = new rank + 1 |
| 57 | + |
| 58 | + associate(my_team=>team_number()) |
| 59 | + call assert(my_team==chosen_team,"assigned team matches chosen team") |
| 60 | + associate(new_num_images=>initial_num_images/num_teams+merge(1,0,my_team<=mod(initial_num_images,num_teams))) |
| 61 | + call assert(num_images()==new_num_images,"block distribution of images") |
| 62 | + end associate |
| 63 | + end associate |
| 64 | + |
| 65 | + end team |
| 66 | + |
| 67 | + call assert( initial_image==this_image(),"correctly remapped to original image number") |
| 68 | + call assert( initial_num_images==num_images(),"correctly remapped to original number of images") |
| 69 | + |
| 70 | + end associate |
| 71 | + |
| 72 | + end block |
| 73 | + |
| 74 | + sync all |
| 75 | + if (this_image()==1) print *,"Test passed." |
| 76 | + |
| 77 | +contains |
| 78 | + |
| 79 | + pure function destination_team(image,numTeams) result(team) |
| 80 | + integer, intent(in) ::image, numTeams |
| 81 | + integer ::team |
| 82 | + team = mod(image+1,numTeams)+1 |
| 83 | + end function |
| 84 | + |
| 85 | + subroutine mpi_matches_caf(comm) |
| 86 | + use iso_c_binding, only : c_int |
| 87 | + use mpi, only : MPI_COMM_SIZE, MPI_COMM_RANK |
| 88 | + integer(c_int), intent(in) :: comm |
| 89 | + !! MPI communicator |
| 90 | + integer(c_int) :: isize,ierror,irank |
| 91 | + |
| 92 | + call MPI_COMM_SIZE(comm, isize, ierror) |
| 93 | + call assert( ierror==0 , "successful call MPI_COMM_SIZE" ) |
| 94 | + call assert( isize==num_images(), "num MPI ranks = num CAF images " ) |
| 95 | + |
| 96 | + call MPI_COMM_RANK(comm, irank, ierror) |
| 97 | + call assert( ierror==0 , "successful call MPI_COMM_RANK" ) |
| 98 | + call assert( irank==this_image()-1 , "correct rank/image-number correspondence" ) |
| 99 | + |
| 100 | + end subroutine |
| 101 | + |
| 102 | + elemental subroutine assert(assertion,description) |
| 103 | + !! TODO: move this to a common place for all tests to use |
| 104 | + logical, intent(in) :: assertion |
| 105 | + character(len=*), intent(in) :: description |
| 106 | + integer, parameter :: max_digits=12 |
| 107 | + character(len=max_digits) :: image_number |
| 108 | + if (.not.assertion) then |
| 109 | + write(image_number,*) this_image() |
| 110 | + error stop "Assertion '" // description // "' failed on image " // trim(image_number) |
| 111 | + end if |
| 112 | + end subroutine |
| 113 | + |
| 114 | +end program |
0 commit comments