|
| 1 | +! Unit test for register procedure and remote allocated test. |
| 2 | +! |
| 3 | +! Test that scalar allocatable component in a derived typed coarray is |
| 4 | +! registered correctly, delayed allocatable and deregisterable. The checks |
| 5 | +! whether the component is allocated are done on the remote images. |
| 6 | +! |
| 7 | +! Copyright (c) 2012-2016, Sourcery, Inc. |
| 8 | +! All rights reserved. |
| 9 | +! |
| 10 | +! Redistribution and use in source and binary forms, with or without |
| 11 | +! modification, are permitted provided that the following conditions are met: |
| 12 | +! * Redistributions of source code must retain the above copyright |
| 13 | +! notice, this list of conditions and the following disclaimer. |
| 14 | +! * Redistributions in binary form must reproduce the above copyright |
| 15 | +! notice, this list of conditions and the following disclaimer in the |
| 16 | +! documentation and/or other materials provided with the distribution. |
| 17 | +! * Neither the name of the Sourcery, Inc., nor the |
| 18 | +! names of its contributors may be used to endorse or promote products |
| 19 | +! derived from this software without specific prior written permission. |
| 20 | +! |
| 21 | +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND |
| 22 | +! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED |
| 23 | +! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE |
| 24 | +! DISCLAIMED. IN NO EVENT SHALL SOURCERY, INC., BE LIABLE FOR ANY |
| 25 | +! DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES |
| 26 | +! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; |
| 27 | +! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND |
| 28 | +! ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
| 29 | +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| 30 | +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| 31 | + |
| 32 | +program check_remote_alloced_comp_1 |
| 33 | + implicit none |
| 34 | + |
| 35 | + type dt |
| 36 | + integer, allocatable :: i |
| 37 | + end type dt |
| 38 | + |
| 39 | + integer :: np = -2, me, remote, test |
| 40 | + type(dt), allocatable :: obj[:] |
| 41 | + |
| 42 | + np = num_images() |
| 43 | + me = this_image() |
| 44 | + |
| 45 | + ! Make sure that at least two images are available. This might not be |
| 46 | + ! necessary, but simplyfies writing the test. |
| 47 | + if (np < 2) error stop "Test failed. Need more than one image." |
| 48 | + |
| 49 | + ! Allocate only the container. obj%i must not be allocated hereafter. |
| 50 | + allocate(obj[*]) |
| 51 | + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." |
| 52 | + if (allocated(obj%i)) error stop "Test failed. 'obj%i' is allocated." |
| 53 | + |
| 54 | + ! The print statements are in for debugging purposes only. |
| 55 | + |
| 56 | + ! All images have allocated the container. Now iterate over the images and |
| 57 | + ! when this image's number is equal to remote, allocate the component, |
| 58 | + ! else check the allocation status of all other remote components. |
| 59 | + do remote = 1, np |
| 60 | + print *, me, "/", np, ": remote=", remote |
| 61 | + if (remote == me) then |
| 62 | + print *, me, "/", np, ": allocating..." |
| 63 | + allocate(obj%i, source = me) |
| 64 | + print *, me, "/", np, ": allocated" |
| 65 | + ! Now both objects have to be allocated and obj%i set to this_image() |
| 66 | + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." |
| 67 | + if (.not. allocated(obj%i)) error stop "Test failed. 'obj%i' not allocated." |
| 68 | + if (obj%i /= me) error stop "Test failed. obj%i /= this_image()." |
| 69 | + sync all |
| 70 | + else |
| 71 | + sync all |
| 72 | + ! Iterate using test over the images to test: |
| 73 | + ! when test less or equal than remote, check that the remote image's |
| 74 | + ! component given by test is allocated, |
| 75 | + ! else check that the remote component is not yet allocated. |
| 76 | + do test = 1, np |
| 77 | + print *, me, "/", np, ": Checking", test, " for allocation status." |
| 78 | + if (test > remote) then |
| 79 | + if (allocated(obj[test]%i)) error stop "Test failed. 'obj%i' on remote image already allocated." |
| 80 | + else |
| 81 | + if (.not. allocated(obj[test]%i)) error stop "Test failed. 'obj%i' on remote image not allocated." |
| 82 | + end if |
| 83 | + end do |
| 84 | + end if |
| 85 | + enddo |
| 86 | +end program |
| 87 | + |
0 commit comments