├── .github └── workflows │ └── build.yml ├── .gitignore ├── CONTRIBUTING.md ├── LICENSE.txt ├── README.md ├── docs ├── README-maintainers.md ├── README-release.md ├── _config.yml └── implementation-status.md ├── example ├── hello.F90 └── support-test │ ├── README.md │ ├── error_stop_with_character_code.F90 │ ├── error_stop_with_integer_code.F90 │ ├── error_stop_with_no_code.F90 │ ├── register_stop_callback.F90 │ ├── stop_with_character_code.F90 │ ├── stop_with_integer_code.F90 │ └── stop_with_no_code.F90 ├── include └── language-support.F90 ├── install.sh ├── manifest └── fpm.toml.template ├── src ├── caffeine │ ├── alias_s.F90 │ ├── allocation_s.F90 │ ├── atomic_s.F90 │ ├── caffeine.c │ ├── co_broadcast_s.F90 │ ├── co_max_s.F90 │ ├── co_min_s.F90 │ ├── co_reduce_s.F90 │ ├── co_sum_s.F90 │ ├── coarray_access_s.F90 │ ├── coarray_queries_s.F90 │ ├── critical_s.F90 │ ├── events_s.F90 │ ├── gasnet_safe.h │ ├── image_queries_s.F90 │ ├── locks_s.F90 │ ├── prif_private_s.F90 │ ├── program_startup_s.F90 │ ├── program_termination_s.F90 │ ├── sync_stmt_s.F90 │ ├── teams_s.F90 │ └── unit_test_parameters_m.F90 ├── dlmalloc │ ├── dl_malloc.c │ ├── dl_malloc.h │ └── dl_malloc_caf.h └── prif.F90 └── test ├── a00_caffeinate_test.F90 ├── main.F90 ├── prif_allocate_test.F90 ├── prif_co_broadcast_test.F90 ├── prif_co_max_test.F90 ├── prif_co_min_test.F90 ├── prif_co_reduce_test.F90 ├── prif_co_sum_test.F90 ├── prif_coarray_inquiry_test.F90 ├── prif_error_stop_test.F90 ├── prif_event_test.F90 ├── prif_image_index_test.F90 ├── prif_image_queries_test.F90 ├── prif_num_images_test.F90 ├── prif_rma_test.F90 ├── prif_stop_test.F90 ├── prif_strided_test.F90 ├── prif_sync_images_test.F90 ├── prif_teams_test.F90 └── prif_this_image_test.F90 /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: [push, pull_request] 4 | 5 | defaults: 6 | run: 7 | shell: bash 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.compiler }}-${{ matrix.version }} ${{ matrix.network }} (${{ matrix.os }}) 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | os: [macos-13, macos-14, macos-15, ubuntu-24.04] 17 | compiler: [ gfortran ] 18 | version: [ 13, 14 ] 19 | network: [ smp ] 20 | exclude: 21 | - os: macos-15 # gcc-13 broken on macos-15 22 | compiler: gfortran 23 | version: 13 24 | network: smp 25 | include: 26 | # --- flang coverage --- 27 | - os: macos-13 28 | compiler: flang 29 | version: 20 30 | network: smp 31 | - os: macos-14 32 | compiler: flang 33 | version: 20 34 | network: smp 35 | - os: macos-15 36 | compiler: flang 37 | version: 20 38 | network: smp 39 | - os: ubuntu-24.04 40 | compiler: flang 41 | version: 20 42 | network: smp 43 | # https://hub.docker.com/r/phhargrove/llvm-flang/tags 44 | container: phhargrove/llvm-flang:20.1.0-1 45 | - os: ubuntu-24.04 46 | compiler: flang 47 | version: 19 48 | network: smp 49 | FFLAGS: -mmlir -allow-assumed-rank 50 | # https://hub.docker.com/r/phhargrove/llvm-flang/tags 51 | container: phhargrove/llvm-flang:19.1.1-1 52 | # - os: ubuntu-24.04 53 | # compiler: flang 54 | # version: new 55 | # network: smp 56 | # container: gmao/llvm-flang:latest 57 | # --- udp coverage for selected configs --- 58 | - os: macos-15 59 | compiler: gfortran 60 | version: 14 61 | network: udp 62 | - os: ubuntu-24.04 63 | compiler: gfortran 64 | version: 14 65 | network: udp 66 | - os: macos-15 67 | compiler: flang 68 | version: 20 69 | network: udp 70 | - os: ubuntu-24.04 71 | compiler: flang 72 | version: 20 73 | network: udp 74 | container: phhargrove/llvm-flang:20.1.0-1 75 | 76 | container: 77 | image: ${{ matrix.container }} 78 | 79 | env: 80 | COMPILER_VERSION: ${{ matrix.version }} 81 | FFLAGS: ${{ matrix.FFLAGS }} 82 | PREFIX: install 83 | GASNET_CONFIGURE_ARGS: --enable-rpath --enable-debug 84 | GASNET_SPAWN_VERBOSE: 1 85 | GASNET_SPAWNFN: L 86 | CAF_IMAGES: 8 87 | 88 | steps: 89 | - name: Set gfortran variables 90 | if: matrix.compiler == 'gfortran' 91 | run: | 92 | set -x 93 | echo "FC=gfortran-${COMPILER_VERSION}" >> "$GITHUB_ENV" 94 | echo "CC=gcc-${COMPILER_VERSION}" >> "$GITHUB_ENV" 95 | echo "CXX=g++-${COMPILER_VERSION}" >> "$GITHUB_ENV" 96 | 97 | - name: Set flang variables 98 | if: matrix.compiler == 'flang' 99 | run: | 100 | set -x 101 | echo "FC=flang-new" >> "$GITHUB_ENV" 102 | echo "CC=clang" >> "$GITHUB_ENV" 103 | echo "CXX=clang++" >> "$GITHUB_ENV" 104 | 105 | - name: Set Caffeine variables 106 | run: | 107 | set -x 108 | # docker instances cannot handle high levels of subjob parallelism 109 | if test -n "${{ matrix.container }}"; then \ 110 | echo "SUBJOB_PREFIX=CAF_IMAGES=2" >> "$GITHUB_ENV" ; \ 111 | fi 112 | # disable shared-memory bypass with network=udp to simulate multi-node runs 113 | if test "${{ matrix.network }}" = "udp"; then \ 114 | echo "GASNET_SUPERNODE_MAXSIZE=1" >> "$GITHUB_ENV" ; \ 115 | fi 116 | 117 | - name: Checkout code 118 | uses: actions/checkout@v1 119 | 120 | - name: Install Ubuntu Native Dependencies 121 | if: ${{ contains(matrix.os, 'ubuntu') && matrix.container == '' }} 122 | run: | 123 | set -x 124 | sudo apt update 125 | sudo apt install -y build-essential gfortran-${COMPILER_VERSION} g++-${COMPILER_VERSION} pkg-config make 126 | 127 | - name: Install Ubuntu Container Dependencies 128 | if: ${{ contains(matrix.os, 'ubuntu') && contains(matrix.container, 'gmao') }} 129 | run: | 130 | set -x 131 | apt update 132 | apt install -y build-essential pkg-config make 133 | 134 | - name: Install macOS Dependencies 135 | if: contains(matrix.os, 'macos') && matrix.compiler == 'flang' 136 | run: | 137 | set -x 138 | brew update 139 | brew install llvm@${COMPILER_VERSION} flang 140 | # workaround issue #228: clang cannot find homebrew flang's C header 141 | for p in /opt/homebrew /usr/local $(brew --prefix) ; do find $p/Cellar/flang -name ISO_Fortran_binding.h 2>/dev/null || true ; done 142 | echo "CFLAGS=-I$(dirname $(find $(brew --prefix)/Cellar/flang -name ISO_Fortran_binding.h | head -1)) ${CFLAGS}" >> "$GITHUB_ENV" 143 | # Prepend homebrew clang to PATH: 144 | echo "PATH=$(brew --prefix)/opt/llvm/bin:${PATH}" >> "$GITHUB_ENV" 145 | 146 | - name: Setup FPM 147 | uses: fortran-lang/setup-fpm@main 148 | if: ${{ !contains(matrix.os, 'macos') || matrix.os == 'macos-13' }} 149 | with: 150 | github-token: ${{ secrets.GITHUB_TOKEN }} 151 | 152 | - name: Build FPM 153 | # no macos-arm64 fpm distro, build from source 154 | if: ${{ contains(matrix.os, 'macos') && matrix.os != 'macos-13' }} 155 | run: | 156 | set -x 157 | export FPM_VERSION=0.12.0 158 | curl --retry 5 -LOsS https://github.com/fortran-lang/fpm/releases/download/v$FPM_VERSION/fpm-$FPM_VERSION.F90 159 | mkdir fpm-temp 160 | gfortran-14 -o fpm-temp/fpm fpm-$FPM_VERSION.F90 161 | echo "PATH=${PWD}/fpm-temp:${PATH}" >> "$GITHUB_ENV" 162 | 163 | - name: Version info 164 | run: | 165 | echo == TOOL VERSIONS == 166 | set -x 167 | uname -a 168 | if test -r /etc/os-release ; then cat /etc/os-release ; fi 169 | ${FC} --version 170 | ${CC} --version 171 | ${CXX} --version 172 | fpm --version 173 | 174 | - name: Build Caffeine (install.sh) 175 | run: | 176 | for var in FC CC CXX FFLAGS CPPFLAGS CFLAGS LDFLAGS LIBS GASNET_CONFIGURE_ARGS ; do \ 177 | eval echo "$var=\$$var"; done 178 | set -x 179 | ./install.sh --prefix=${PREFIX} --network=${{ matrix.network }} --verbose 180 | 181 | - name: Run examples 182 | run: | 183 | echo CAF_IMAGES=${CAF_IMAGES} 184 | set -x 185 | ./build/run-fpm.sh run --verbose --example hello 186 | ./build/run-fpm.sh run --verbose --example stop_with_no_code 187 | ( set +e ; ./build/run-fpm.sh run --verbose --example stop_with_integer_code ; test $? = 99 ) 188 | ( set +e ; ./build/run-fpm.sh run --verbose --example error_stop_with_integer_code ; test $? = 100 ) 189 | 190 | - name: Run unit tests 191 | run: | 192 | echo SUBJOB_PREFIX=${SUBJOB_PREFIX} 193 | while (( CAF_IMAGES > 0 )); do \ 194 | echo CAF_IMAGES=${CAF_IMAGES} ; \ 195 | ( set -x ; ./build/run-fpm.sh test --verbose -- -d ) ; \ 196 | sleep 1 ; \ 197 | CAF_IMAGES=$(( CAF_IMAGES / 2 )) ; \ 198 | done 199 | 200 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # fpm-generated build tree 2 | build 3 | 4 | # install.sh-generated fpm manifest 5 | fpm.toml 6 | 7 | # ford-generated documentation 8 | doc/html 9 | 10 | # executable programs 11 | a.out 12 | *.exe 13 | 14 | # compiler-generated intermediate files 15 | *.mod 16 | *.smod 17 | *.o 18 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing to Caffeine 2 | -------------------------- 3 | 4 | ## Reporting Defects or Suggesting Features 5 | 6 | If you encounter problems or limitations when installing or using Caffeine, please do the following: 7 | 8 | 1. Search the Caffeine [issues](https://github.com/berkeleylab/caffeine/issues), including [closed issues]. 9 | If your search finds a report of the same problem, please post a comment in the issue. 10 | 2. Email the Caffeine [mailing list](mailto:fortran@lbl.gov) for advice. 11 | 3. If steps 1 or 2 do not resolve the problem, please file a [new issue] including 12 | - [ ] The Fortran compiler and compiler version used with Caffeine, 13 | - [ ] The complete output of the install and build commands run with `--verbose` argument, 14 | - [ ] The Caffeine version number or commit hash, 15 | - [ ] Any conditions required to reproduce the problem such as 16 | - [ ] The output of `uname -a` showing the operating system (OS), OS version, and processor architecture, 17 | - [ ] The number of images executed (e.g., the output of `echo $CAF_IMAGES`), 18 | - [ ] The command used to run your program (e.g., `./build/run-fpm.sh run`), and 19 | - [ ] A minimal reproducer: if possible, fewer than 50 lines demonstrating an issue. 20 | 21 | ## Contributing Code or Documentation 22 | 23 | We welcome help with diagnosing, isolating and fixing problems or adding features! 24 | All contributions are governed by the Caffeine [LICENSE.txt](./LICENSE.txt). 25 | To contribute, please follow these steps: 26 | 27 | - [ ] First please follow the [above steps](#reporting-defects-or-suggesting-features) and include a description of your proposed contribution. 28 | - [ ] Fork the Caffeine repository into your GitHub account 29 | - [ ] Create a new local branch for your work. 30 | - [ ] Name your branch according to the issue created. For example `fix-issue-53` or `issue-53-feature`. 31 | - [ ] Follow the coding conventions in [docs/README-maintainers.md](./docs/README-maintainers.md). 32 | - [ ] Make your commits logically atomic, self-consistent, and cohesive. 33 | - [ ] Add one or more unit tests in the `test` subdirectory to verify your fix or feature. 34 | - [ ] Ensure that your branch passes all tests (via `./build/run-fpm.sh test` with appropriate flags). 35 | - [ ] Update the [README.md](./README.md) if your branch affects anything described there. 36 | - [ ] Push your branch to your fork. 37 | - [ ] Open a [Pull Request](https://github.com/berkeleylab/caffeine/pulls) (PR) against an existing branch of the Berkeley Lab [Caffeine repository](https://github.com/berkeleylab/caffeine). 38 | - [ ] Please include the corresponding issue number in the PR title. 39 | - [ ] If your PR is not ready for merging, please click the downward arrow next to the "Create pull request" button and select the "Create draft pull request" option before submitting. 40 | - [ ] Watch for CI results on your PR and address any failures. 41 | - [ ] Please be patient and responsive to comments on your PR. 42 | 43 | ## Current and Past Contributors 44 | 45 | Caffeine is an open-source project and welcomes community participation in the development process. 46 | Notable current and past contributors include: 47 | 48 | * [Dan Bonachea](https://go.lbl.gov/dan-bonachea) 49 | [@bonachea](https://github.com/bonachea) 50 | [![View ORCID record] 0000-0002-0724-9349](https://orcid.org/0000-0002-0724-9349) 51 | 52 | * [Katherine Rasmussen](https://go.lbl.gov/katherine-rasmussen) 53 | [@ktras](https://github.com/ktras) 54 | [![View ORCID record] 0000-0001-7974-1853](https://orcid.org/0000-0001-7974-1853) 55 | 56 | * [Brad Richardson](https://everythingfunctional.com/) 57 | [@everythingfunctional](https://github.com/everythingfunctional) 58 | [![View ORCID record] 0000-0002-3205-2169](https://orcid.org/0000-0002-3205-2169) 59 | 60 | * [Damian Rouson](https://go.lbl.gov/damian-rouson) 61 | [@rouson](https://github.com/rouson) 62 | [![View ORCID record] 0000-0002-2344-868X](https://orcid.org/0000-0002-2344-868X) 63 | 64 | 65 | You can also browse the [full list of repository contributors](https://github.com/BerkeleyLab/caffeine/graphs/contributors). 66 | 67 | --- 68 | 69 | [Long or Frequently Used URLs]: # 70 | [View ORCID record]: https://github.com/BerkeleyLab/caffeine/wiki/img/ORCID-small.png 71 | [closed issues]: https://github.com/berkeleylab/caffeine/issues?q=is%3Aissue+is%3Aclosed 72 | [new issue]: https://github.com/berkeleylab/caffeine/issues/new 73 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | ************************************* 2 | *** Caffeine Terms and Conditions *** 3 | ************************************* 4 | 5 | All files in this directory and all sub-directories (except where otherwise noted) 6 | are subject to the following copyright and licensing terms: 7 | 8 | *** Copyright Notice *** 9 | 10 | Caffeine Copyright (c) 2021-2025, The Regents of the University of California, 11 | through Lawrence Berkeley National Laboratory (subject to receipt of 12 | any required approvals from the U.S. Dept. of Energy), Archaeologic Inc., 13 | and Harris Snyder. All rights reserved. 14 | 15 | If you have questions about your rights to use or distribute this software, 16 | please contact Berkeley Lab's Intellectual Property Office at 17 | IPO@lbl.gov. 18 | 19 | NOTICE. This Software was developed under funding from the U.S. Department 20 | of Energy and the U.S. Government consequently retains certain rights. As 21 | such, the U.S. Government has been granted for itself and others acting on 22 | its behalf a paid-up, nonexclusive, irrevocable, worldwide license in the 23 | Software to reproduce, distribute copies to the public, prepare derivative 24 | works, and perform publicly and display publicly, and to permit others to do so. 25 | 26 | *** License Agreement *** 27 | 28 | Caffeine Copyright (c) 2021-2025, The Regents of the University of California, 29 | through Lawrence Berkeley National Laboratory (subject to receipt of 30 | any required approvals from the U.S. Dept. of Energy), Archaeologic Inc., 31 | and Harris Snyder. All rights reserved. 32 | 33 | Redistribution and use in source and binary forms, with or without 34 | modification, are permitted provided that the following conditions are met: 35 | 36 | (1) Redistributions of source code must retain the above copyright notice, 37 | this list of conditions and the following disclaimer. 38 | 39 | (2) Redistributions in binary form must reproduce the above copyright 40 | notice, this list of conditions and the following disclaimer in the 41 | documentation and/or other materials provided with the distribution. 42 | 43 | (3) Neither the name of the University of California, Lawrence Berkeley 44 | National Laboratory, U.S. Dept. of Energy, Archaeologic Inc., Harris Snyder 45 | nor the names of its contributors may be used to endorse or promote products 46 | derived from this software without specific prior written permission. 47 | 48 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 49 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 50 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 51 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 52 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 53 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 54 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 55 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 56 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 57 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 58 | POSSIBILITY OF SUCH DAMAGE. 59 | 60 | You are under no obligation whatsoever to provide any bug fixes, patches, 61 | or upgrades to the features, functionality or performance of the source 62 | code ("Enhancements") to anyone; however, if you choose to make your 63 | Enhancements available either publicly, or directly to Lawrence Berkeley 64 | National Laboratory, without imposing a separate written license agreement 65 | for such Enhancements, then you hereby grant the following license: a 66 | non-exclusive, royalty-free perpetual license to install, use, modify, 67 | prepare derivative works, incorporate into other computer software, 68 | distribute, and sublicense such enhancements or derivative works thereof, 69 | in binary and source code form. 70 | 71 | *** Subsidiary Packages *** 72 | 73 | The Caffeine package downloads and installs GASNet-EX, which is distributed 74 | subject to the following license. Some Caffeine source files are also 75 | based in part on GASNet-EX source files. For more details on GASNet licensing, 76 | visit https://gasnet.lbl.gov 77 | 78 | * --------------------------------------------------------------------------- 79 | 80 | Global-Address Space Networking for Exascale (GASNet-EX) Copyright (c) 2000-2024, 81 | The Regents of the University of California, through Lawrence Berkeley National 82 | Laboratory (subject to receipt of any required approvals from the U.S. Dept. of 83 | Energy). All rights reserved. 84 | 85 | Redistribution and use in source and binary forms, with or without 86 | modification, are permitted provided that the following conditions are met: 87 | 88 | (1) Redistributions of source code must retain the above copyright notice, this 89 | list of conditions and the following disclaimer. 90 | 91 | (2) Redistributions in binary form must reproduce the above copyright notice, 92 | this list of conditions and the following disclaimer in the documentation 93 | and/or other materials provided with the distribution. 94 | 95 | (3) Neither the name of the University of California, Lawrence Berkeley 96 | National Laboratory, U.S. Dept. of Energy, nor the names of its contributors 97 | may be used to endorse or promote products derived from this software without 98 | specific prior written permission. 99 | 100 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 101 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 102 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 103 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 104 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 105 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 106 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 107 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 108 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 109 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 110 | 111 | You are under no obligation whatsoever to provide any bug fixes, patches, or 112 | upgrades to the features, functionality or performance of the source code 113 | ("Enhancements") to anyone; however, if you choose to make your Enhancements 114 | available either publicly, or directly to Lawrence Berkeley National 115 | Laboratory, without imposing a separate written license agreement for such 116 | Enhancements, then you hereby grant the following license: a non-exclusive, 117 | royalty-free perpetual license to install, use, modify, prepare derivative 118 | works, incorporate into other computer software, distribute, and sublicense 119 | such enhancements or derivative works thereof, in binary and source code form. 120 | 121 | * --------------------------------------------------------------------------- 122 | 123 | The Caffeine package downloads and installs FPM (Fortran Package Manager), 124 | which is distributed subject to the following license. For more details on 125 | FPM licensing, visit https://github.com/fortran-lang/fpm 126 | 127 | * --------------------------------------------------------------------------- 128 | 129 | Copyright (c) 2020 fpm contributors 130 | 131 | Permission is hereby granted, free of charge, to any person obtaining a copy 132 | of this software and associated documentation files (the "Software"), to deal 133 | in the Software without restriction, including without limitation the rights 134 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 135 | copies of the Software, and to permit persons to whom the Software is 136 | furnished to do so, subject to the following conditions: 137 | 138 | The above copyright notice and this permission notice shall be included in all 139 | copies or substantial portions of the Software. 140 | 141 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 142 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 143 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 144 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 145 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 146 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 147 | SOFTWARE. 148 | 149 | * --------------------------------------------------------------------------- 150 | 151 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Caffeine 2 | ======== 3 | 4 | **CoArray Fortran Framework of Efficient Interfaces to Network Environments** 5 | 6 | Caffeine is a parallel runtime library that aims to support Fortran compilers 7 | with a programming-model-agnostic application interface to various 8 | communication libraries. Current work is on supporting the Parallel Runtime 9 | Interface for Fortran (PRIF) with the [GASNet-EX] exascale-ready networking 10 | middleware. Future plans include support for an alternative Message Passing 11 | Interface ([MPI]) back end. 12 | 13 | ![Caffeine system stack diagram](https://github.com/BerkeleyLab/caffeine/wiki/img/caffeine-stack.gif) 14 | 15 | Statement of need 16 | ----------------- 17 | 18 | The Fortran programming language standard added features supporting 19 | single-program, multiple-data (SPMD) parallel programming and loop 20 | parallelism beginning with Fortran 2008. In Fortran, SPMD programming 21 | involves the creation of a fixed number of images (instances) of a 22 | program that execute asynchronously in shared or distributed memory, except 23 | where a program uses specific synchronization mechanisms. Fortran's 24 | "coarray" distributed data structures offer a subscripted, 25 | multidimensional array notation defining a partitioned global address space 26 | (PGAS). One image can use this notation for one-sided access to another 27 | image's slice of a coarray. 28 | 29 | Fortran 2018 greatly expanded this feature set to include such concepts as 30 | teams (groupings) of images, events (counting semaphores), collective 31 | subroutines and failed-image detection (fault tolerance). Fortran 2023 provided 32 | additional, minor multi-image extensions, including notified remote data access. 33 | 34 | Several popular Fortran compilers, including LLVM `flang` and LFortran, currently 35 | lack support for multi-image parallel execution. These features are a mandatory 36 | part of Fortran, and thus are an important part of reaching full compliance with 37 | the 2008, 2018, or 2023 versions of the Fortran standard. 38 | 39 | Caffeine aims to provide a portable, high-performance and open-source parallel 40 | runtime library that such compilers can target in code generation as part of 41 | their solution to support Fortran's multi-image parallel features. 42 | 43 | Prerequisites & Dependencies 44 | ------------- 45 | ### Build prerequisites 46 | The `install.sh` script uses the following packages: 47 | * Fortran and C compilers 48 | * We regularly test with: gfortran v13, v14 and LLVM Flang 19, 20 49 | * On macOS the Homebrew-installed llvm and flang packages may require some 50 | additional settings, see issue #228 for the latest information. 51 | * [Fortran package manager] `fpm` 52 | * [pkg-config] 53 | * [realpath] 54 | * [make] 55 | * [git] 56 | * [curl] 57 | 58 | The script will invoke these if present in a user's `PATH`. 59 | If not present, the script will ask permission to use [Homebrew] to install the relevant package 60 | or, in some cases, ask the user to install the package. 61 | 62 | ### Build dependencies 63 | 64 | Caffeine also depends on the following packages that will be automatically installed as part 65 | of the build process. 66 | 67 | * [GASNet-EX] exascale networking middleware 68 | * [assert](https://github.com/BerkeleyLab/assert) 69 | * [veggies](https://github.com/everythingfunctional/veggies) 70 | * [iso_varying_string](https://github.com/everythingfunctional/iso_varying_string) 71 | 72 | Caffeine leverages the following non-parallel features of Fortran to simplify the writing of a portable, compact runtime-library that supports Fortran's parallel features: 73 | 74 | | Feature | Introduced in | 75 | |-------------------------------------------|---------------| 76 | | The `iso_c_binding` module | Fortran 2003 | 77 | | The `contiguous` attribute | Fortran 2008 | 78 | | Submodule support [1] | Fortran 2008 | 79 | | The `ISO_Fortran_binding.h` C header file | Fortran 2018 | 80 | | Assumed-type dummy arguments: `type(*)` | Fortran 2018 | 81 | | Assumed-rank dummy arguments: `array(..)` | Fortran 2018 | 82 | 83 | 84 | [1] This feature simplifies development but is not essential to the package 85 | 86 | Download, build, and run an example 87 | ----------------------------------- 88 | Here is an outline of the basic commands used to build Caffeine and run an example: 89 | 90 | ``` 91 | git clone https://github.com/BerkeleyLab/caffeine.git 92 | cd caffeine 93 | env FC= CC= CXX= ./install.sh 94 | env CAF_IMAGES=8 ./build/run-fpm.sh run --example hello 95 | ``` 96 | 97 | The provided compilers MUST be "compatible": for the best experience you are 98 | HIGHLY recommended to specify the language frontends provided by a single version 99 | of a given compiler suite installation. The C++ compiler is optional for 100 | single-node deployments (and can be disabled using command-line option `--without-cxx`), 101 | but C++ is required for some network backends. 102 | 103 | The `install.sh` recognizes a number of command-line options and environment variables to 104 | customize behavior for your system. See the output of `./install.sh --help` for full documentation, 105 | including options for how to build for a distributed memory platform. 106 | 107 | 108 | Example Usage 109 | ------------- 110 | The Caffeine parallel runtime is intended as an embedded compilation target 111 | library, to provide multi-image parallel runtime support to a Fortran compiler. 112 | As such, real usage of Caffeine is specific to the host Fortran compiler, and 113 | one should consult compiler-provided documentation regarding the use of Caffeine 114 | to back multi-image features. 115 | 116 | However we provide an [example hello world program](example/hello.F90), 117 | written in Fortran, simulating the PRIF calls that a theoretical 118 | source-to-source Fortran compiler might generate for a simple program written 119 | using Fortran's multi-image features to print a message from each image. 120 | 121 | Run tests 122 | --------- 123 | ``` 124 | ./build/run-fpm.sh test 125 | ``` 126 | 127 | Recognized Environment Variables 128 | -------------------------------- 129 | 130 | The following environment variables control the execution of the `fpm`-driven Caffeine unit test suite: 131 | 132 | * `CAF_IMAGES`: integer that indicates the number of images to run 133 | * `SUBJOB_PREFIX`: command prefix to use for recursive `fpm` invocations in the test suite. 134 | Set `SUBJOB_PREFIX=skip` to disable such invocations (recommended for distributed-memory systems). 135 | 136 | The following environment variables control the behavior of the Caffeine library: 137 | 138 | * `CAF_HEAP_SIZE=128MB`: set the size of the shared-memory heap used for coarray storage, defaults to 128 MiB 139 | * `CAF_COMP_FRAC=0.10`: set the fraction of the shared-memory heap reserved for non-symmetric allocation, defaults to 10% 140 | 141 | Caffeine is built atop the [GASNet-EX] exascale networking middleware, which has its own 142 | set of environment variable knobs to control network-level behavior. 143 | Here are *a few* of the most useful GASNet knobs: 144 | 145 | * `GASNET_VERBOSEENV=1`: enable console output of all the envvar settings affecting GASNet operation 146 | * `GASNET_SPAWN_VERBOSE=1`: enable verbose console output of parallel job-spawning steps 147 | * `GASNET_BACKTRACE=1`: enable automatic backtrace upon fatal errors 148 | * `GASNET_SSH_SERVERS="host1 host2"`: space-deliminted list of hostnames for distributed-memory job launch using the ssh-spawner 149 | 150 | See [GASNet documentation](https://gasnet.lbl.gov/dist-ex/README) for full details on all settings. 151 | 152 | Implementation Status 153 | -------------------- 154 | 155 | ### Caffeine is an implementation of the [Parallel Runtime Interface for Fortran (PRIF)](#citing-prif-please-use-the-following-publication) 156 | 157 | ![PRIF system stack diagram](https://github.com/BerkeleyLab/caffeine/wiki/img/prif-stack.gif) 158 | 159 | For details on the PRIF features that are implemented, please see the [Implementation Status doc](docs/implementation-status.md). 160 | 161 | Publications 162 | ------------ 163 | 164 | ### Citing Caffeine? Please use the following publication: 165 | 166 | Damian Rouson, Dan Bonachea. 167 | "[**Caffeine: CoArray Fortran Framework of Efficient Interfaces to Network Environments**](https://github.com/BerkeleyLab/caffeine/wiki/pubs/Caffeine_for_LLVM-2022.pdf)", 168 | Proceedings of the [Eighth Annual Workshop on the LLVM Compiler Infrastructure in HPC (LLVM-HPC2022)](https://web.archive.org/web/20230605003029/https://llvm-hpc-2022-workshop.github.io/), November 2022. 169 | Paper: 170 | [Talk Slides](https://github.com/BerkeleyLab/caffeine/wiki/pubs/Caffeine_for_LLVM-2022-Slides.pdf) 171 | 172 | ### Citing PRIF? Please use the following publication: 173 | 174 | Dan Bonachea, Katherine Rasmussen, Brad Richardson, Damian Rouson. 175 | "[**Parallel Runtime Interface for Fortran (PRIF): A Multi-Image Solution for LLVM Flang**](https://github.com/BerkeleyLab/caffeine/wiki/pubs/LLVM-HPC24_PRIF.pdf)", 176 | Proceedings of the [Tenth Annual Workshop on the LLVM Compiler Infrastructure in HPC (LLVM-HPC2024)](https://web.archive.org/web/20241006163246/https://llvm-hpc-2024-workshop.github.io/), November 2024. 177 | Paper: 178 | [Talk Slides](https://github.com/BerkeleyLab/caffeine/wiki/pubs/LLVM-HPC24_PRIF_Slides.pdf) 179 | 180 | ### PRIF Specification: 181 | 182 | Dan Bonachea, Katherine Rasmussen, Brad Richardson, Damian Rouson. 183 | "[**Parallel Runtime Interface for Fortran (PRIF) Specification, Revision 0.5**](https://github.com/BerkeleyLab/caffeine/wiki/pubs/PRIF_0.5.pdf)", 184 | Lawrence Berkeley National Laboratory Technical Report (LBNL-2001636), Dec 2024. 185 | 186 | 187 | Funding 188 | ------- 189 | The Computer Languages and Systems Software ([CLaSS]) Group at [Berkeley Lab] has developed Caffeine 190 | on funding from the Exascale Computing Project ([ECP](https://www.exascaleproject.org)) 191 | and the Stewardship for Programming Systems and Tools ([S4PST](https://ornl.github.io/events/s4pst2023/)) project, 192 | part of the Consortium for the Advancement of Scientific Software ([CASS](https://cass.community/)). 193 | 194 | Support and Licensing 195 | --------------------- 196 | See [CONTRIBUTING.md](CONTRIBUTING.md) for guidelines on reporting defects, feature requests and contributing to Caffeine. 197 | 198 | See [LICENSE.txt](LICENSE.txt) for usage terms and conditions. 199 | 200 | [GASNet-EX]: https://gasnet.lbl.gov 201 | [CLaSS]: https://go.lbl.gov/class 202 | [Berkeley Lab]: https://lbl.gov 203 | [MPI]: https://www.mpi-forum.org 204 | [Homebrew]: https://brew.sh 205 | [Fortran package manager]: https://github.com/fortran-lang/fpm 206 | [pkg-config]: https://www.freedesktop.org/wiki/Software/pkg-config/ 207 | [realpath]: https://man7.org/linux/man-pages/man3/realpath.3.html 208 | [make]: https://www.gnu.org/software/make/ 209 | [git]: https://git-scm.com 210 | [curl]: https://curl.se 211 | 212 | -------------------------------------------------------------------------------- /docs/README-maintainers.md: -------------------------------------------------------------------------------- 1 | README-maintainers.md 2 | ======== 3 | 4 | 5 | Conventions for Git and Pull Requests 6 | ------------- 7 | This repository aims to maintain a mostly linear history. In order to achieve this, please 8 | observe the following workflow: 9 | * Checkout a feature branch and open a PR when the changes are ready for review 10 | * After your PR has been approved, make sure to rebase your feature branch with `origin/main`. 11 | * In general you should try to avoid rebasing a non-draft PR with pending approvals until the 12 | last step before merge, because it complicates iterative review. 13 | * Only after your feature branch is up-to-date with `origin/main`, then you may merge the branch 14 | into `main` with a merge commit. 15 | 16 | Additional git policies: 17 | * Never force push to `main` 18 | 19 | 20 | Conventions for code and commits in Caffeine 21 | ------------- 22 | [TODO: Improve wording of below bullets] 23 | * All Fortran filenames must have a `*.F90` suffix 24 | * Procedures with `prif_` prefix are public facing procedures 25 | * Procedures with `caf_` prefix are private procedures, 26 | internal to Caffeine, which are implemented in C 27 | * Procedures with neither of the above two prefixes are private procedures, 28 | internal to Caffeine, which are implemented in Fortran 29 | * C functions and global variables lacking a `caf_` prefix must be `static` 30 | * Identifiers named `image` and `rank` refer to processes. Any identifier named `image` represents 31 | the process as 1-based number (Fortran-style), while `rank` represents the process as 0-based 32 | number (C-style) (i.e. rank = image -1) 33 | * When writing or making changes to BIND(C) interfaces, be vigilant when checking that the types 34 | and attributes of the arguments and return values are equivalent across the Fortran and 35 | C declarations 36 | * Avoid committing whitespace-only changes to source lines distant from meaningful PR changes. In 37 | particular disable source editor features that automatically reformat entire files. 38 | * If you absolutely must make whitespace-only changes to otherwise unmodified lines 39 | (for example, rewrapping the lines in documentation), please isolate those changes 40 | in a separate commit with a commit message explaining the lack of meaningful change. 41 | * Similarly if you need to move blocks of lines unchanged between distant locations or rename files, 42 | please also isolate those changes in a separate commit with a commit message 43 | explaining the lack of meaningful change. 44 | * Tab characters should NOT be used in source code 45 | -------------------------------------------------------------------------------- /docs/README-release.md: -------------------------------------------------------------------------------- 1 | README-release.md 2 | ======== 3 | 4 | Release Procedure for Caffeine 5 | ------------- 6 | 1. Nominate a Release Manager with primary responsibility for ensuring each step in this 7 | procedure is followed 8 | 2. Ensure there are no open issues marked with `release-blocker` label 9 | 3. Validate correctness testing has been performed across all supported systems and supported 10 | versions of external dependencies 11 | 4. Complete release related chores in repository files 12 | 1. Update all instances of the copyright year embedded in: [LICENSE.txt](../LICENSE.txt), 13 | [manifest/fpm.toml.template](../manifest/fpm.toml.template) 14 | 2. Update all instances of the release package version number embedded in: 15 | [manifest/fpm.toml.template](../manifest/fpm.toml.template), [install.sh](../install.sh) 16 | 3. Update the author list embedded in: [manifest/fpm.toml.template](../manifest/fpm.toml.template) 17 | 4. Review top-level [README.md](../README.md) and other user-facing documentation for any 18 | necessary changes 19 | 5. Update [docs/implementation-status.md](../docs/implementation-status.md) with current status 20 | 6. Temporarily hardcode version of gasnet installer in [install.sh](../install.sh) as the 21 | last commit in the release. Set GASNET_VERSION flag to the latest gasnet release 22 | 5. Produce the ChangeLog 23 | 1. Create draft release on GitHub 24 | 2. Review/edit the automated ChangeLog 25 | 3. Add/update list of supported features/platforms 26 | 4. Add/update list of high-level changes since last release 27 | 5. Add/update list of known defects/limitations 28 | 6. Spell-check and proofread 29 | 6. Tag a release candidate. For example `git tag #.#.#-rc1`, then `git push origin #.#.#-rc1` 30 | 7. Compel several people to manually validate the release candidate on systems of interest 31 | and with compilers and compiler versions listed in README 32 | 8. Create annotated tag (only after release candidate has been checked by team members) 33 | For example `git tag -a #.#.# -m "release version #.#.#"`, then `git push origin #.#.#` 34 | 9. Publish the release 35 | 10. Post release chores 36 | 1. Git revert the commit that hardcoded the gasnet version or manually edit 37 | 2. Update patch number of the version number embedded in: 38 | [manifest/fpm.toml.template](../manifest/fpm.toml.template), [install.sh](../install.sh) 39 | Update to an odd number to indicate that the `main` branch is currently a snapshot of something 40 | that is beyond the offical release 41 | 3. Update the release procedure with any new steps or changes 42 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-cayman -------------------------------------------------------------------------------- /docs/implementation-status.md: -------------------------------------------------------------------------------- 1 | # Implementation Status 2 | 3 | Caffeine is an implementation of the Parallel Runtime Interface for Fortran (PRIF). This document 4 | outlines the implementation status in Caffeine of the features defined in the 5 | [latest PRIF specification, revision 0.5](https://dx.doi.org/10.25344/S4CG6G). Caffeine contains interfaces for all 6 | of the PRIF procedures (except when stated otherwise below) and the symbols are linkable and callable, but some procedures will fail at runtime with an unimplemented error. For 7 | more details about the implementation of the various PRIF features, please see the 8 | following sections: 9 | 10 | - [Named Constants](#Named-Constants) 11 | - [`stat` and `errmsg` support](#stat-and-errmsg-support) 12 | - [Program Startup and Shutdown](#Program-Startup-and-Shutdown) 13 | - [Image Queries](#Image-Queries) 14 | - [Storage Management](#Storage-Management) 15 | - [Coarray Queries](#Coarray-Queries) 16 | - [Continguous Coarray Access](#Continguous-Coarray-Access) 17 | - [Strided Coarray Access](#Strided-Coarray-Access) 18 | - [SYNC Statements](#SYNC-Statements) 19 | - [Locks and Unlocks](#Locks-and-Unlocks) 20 | - [Critical](#Critical) 21 | - [Events and Notifications](#Events-and-Notifications) 22 | - [Teams](#teams) 23 | - [Collectives](#Collectives) 24 | - [Atomic Memory Operations](#Atomic-Memory-Operations) 25 | 26 | The priorites for feature implementation and addressing known defects is communicated by 27 | the labels in the Caffeine [issue tracker](https://github.com/BerkeleyLab/caffeine/issues). 28 | 29 | ## Named Constants 30 | 31 | Caffeine contains definitions for all of the PRIF-relevant constants from ISO_FORTRAN_ENV and for 32 | all of the PRIF-specific constants. 33 | 34 | ## `stat` and `errmsg` support 35 | 36 | Many PRIF procedures have optional arguments `stat`, `errmsg`, and `errmsg_alloc`. These arguments 37 | are accepted, but in some cases, the associated runtime behavior is not fully implemented. 38 | 39 | ## Program Startup and Shutdown 40 | 41 | | Procedure | Status | Notes | 42 | |-----------|--------|-------| 43 | | `prif_init` | **YES** | | 44 | | `prif_stop`, `prif_error_stop` | **YES** | | 45 | | `prif_fail_image` | no | | 46 | | `prif_register_stop_callback` | **YES** | | 47 | 48 | 49 | --- 50 | 51 | ## Image Queries 52 | 53 | | Procedure | Status | Notes | 54 | |-----------|--------|-------| 55 | | `prif_num_images` | **YES** | | 56 | | `prif_num_images_with_team` | **YES** | | 57 | | `prif_num_images_with_team_number` | *partial* | no support for sibling teams | 58 | | `prif_this_image_no_coarray` | **YES** | | 59 | | `prif_this_image_with_coarray`, `prif_this_image_with_dim` | **YES** | | 60 | | `prif_failed_images` | **YES** | | 61 | | `prif_stopped_images` | **YES** | | 62 | | `prif_image_status` | **YES** | | 63 | 64 | --- 65 | 66 | ## Storage Management 67 | 68 | | Procedure | Status | Notes | 69 | |-----------|--------|-------| 70 | | `prif_allocate_coarray` | **YES** | | 71 | | `prif_allocate` | **YES** | | 72 | | `prif_deallocate_coarray` | *partial* | no `final_func` arg support | 73 | | `prif_deallocate` | **YES** | | 74 | | `prif_alias_create` | **YES** | | 75 | | `prif_alias_destroy` | **YES** | | 76 | 77 | --- 78 | 79 | ## Coarray Queries 80 | 81 | | Procedure | Status | Notes | 82 | |-----------|--------|-------| 83 | | `prif_set_context_data`, `prif_get_context_data` | **YES** | | 84 | | `prif_size_bytes` | **YES** | | 85 | | `prif_lcobound_no_dim`, `prif_lcobound_with_dim` | **YES** | | 86 | | `prif_ucobound_no_dim`, `prif_ucobound_with_dim` | **YES** | | 87 | | `prif_coshape` | **YES** | | 88 | | `prif_local_data_pointer` | **YES** | | 89 | | `prif_image_index` | **YES** | | 90 | | `prif_image_index_with_team` | **YES** | | 91 | | `prif_image_index_with_team_number` | *partial* | no support for sibling teams | 92 | 93 | --- 94 | 95 | ## Contiguous Coarray Access 96 | 97 | | Procedure | Status | Notes | 98 | |-----------|--------|-------| 99 | | `prif_get` | **YES** | | 100 | | `prif_get_indirect` | **YES** | | 101 | | `prif_put` | **YES** | | 102 | | `prif_put_indirect` | **YES** | | 103 | | `prif_put_with_notify` | **YES** | | 104 | | `prif_put_with_notify_indirect` | **YES** | | 105 | | `prif_put_indirect_with_notify` | **YES** | | 106 | | `prif_put_indirect_with_notify_indirect` | **YES** | | 107 | 108 | --- 109 | 110 | ## Strided Coarray Access 111 | 112 | | Procedure | Status | Notes | 113 | |-----------|--------|-------| 114 | | `prif_get_strided` | **YES** | | 115 | | `prif_get_strided_indirect` | **YES** | | 116 | | `prif_put_strided` | **YES** | | 117 | | `prif_put_strided_indirect` | **YES** | | 118 | | `prif_put_strided_with_notify` | **YES** | | 119 | | `prif_put_strided_with_notify_indirect` | **YES** | | 120 | | `prif_put_strided_indirect_with_notify` | **YES** | | 121 | | `prif_put_strided_indirect_with_notify_indirect` | **YES** | | 122 | 123 | --- 124 | 125 | ## SYNC Statements 126 | 127 | | Procedure | Status | Notes | 128 | |-----------|--------|-------| 129 | | `prif_sync_memory` | **YES** | | 130 | | `prif_sync_all` | **YES** | | 131 | | `prif_sync_images` | **YES** | | 132 | | `prif_sync_team` | **YES** | | 133 | 134 | --- 135 | 136 | ## Locks and Unlocks 137 | ### Support = no 138 | 139 | 147 | 148 | --- 149 | 150 | ## Critical 151 | ### Support = no 152 | 153 | 159 | 160 | --- 161 | 162 | ## Events and Notifications 163 | 164 | | Procedure | Status | Notes | 165 | |-----------|--------|-------| 166 | | `prif_event_post` | **YES** | | 167 | | `prif_event_post_indirect` | **YES** | | 168 | | `prif_event_wait` | **YES** | | 169 | | `prif_event_query` | **YES** | | 170 | | `prif_notify_wait` | **YES** | | 171 | 172 | --- 173 | 174 | ## Teams 175 | 176 | | Procedure | Status | Notes | 177 | |-----------|--------|-------| 178 | | `prif_form_team` | **YES** | | 179 | | `prif_get_team` | **YES** | | 180 | | `prif_team_number` | **YES** | | 181 | | `prif_change_team` | **YES** | | 182 | | `prif_end_team` | **YES** | | 183 | 184 | --- 185 | 186 | ## Collectives 187 | 188 | | Procedure | Status | Notes | 189 | |-----------|--------|-------| 190 | | `prif_co_broadcast` | **YES** | | 191 | | `prif_co_max` | **YES** | | 192 | | `prif_co_max_character` | **YES** | | 193 | | `prif_co_min` | **YES** | | 194 | | `prif_co_min_character` | **YES** | | 195 | | `prif_co_sum` | **YES** | | 196 | | `prif_co_reduce` | **YES** | | 197 | 198 | --- 199 | 200 | ## Atomic Memory Operations 201 | ### Support = no 202 | 203 | 235 | 236 | --- 237 | -------------------------------------------------------------------------------- /example/hello.F90: -------------------------------------------------------------------------------- 1 | program hello_world 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_this_image_no_coarray & 6 | ,prif_num_images & 7 | ,prif_stop & 8 | ,prif_error_stop 9 | implicit none 10 | 11 | integer :: init_exit_code, me, num_imgs 12 | logical(kind=c_bool), parameter :: false = .false._c_bool 13 | 14 | call prif_init(init_exit_code) 15 | if (init_exit_code /= 0) call prif_error_stop(quiet=false, stop_code_char="program startup failed") 16 | 17 | call prif_this_image_no_coarray(this_image=me) 18 | call prif_num_images(num_images=num_imgs) 19 | print *, "Hello from image", me, "of", num_imgs 20 | 21 | call prif_stop(quiet=false) 22 | 23 | end program 24 | -------------------------------------------------------------------------------- /example/support-test/README.md: -------------------------------------------------------------------------------- 1 | Test Support 2 | ------------ 3 | The programs in this directory intentionally terminate to support the `stop` and `error stop` 4 | unit tests, which use Fortran's `execute_command_line` to run the programs in this directory 5 | and to check for the expected non-zero stop codes. Running the tests in this manner enables 6 | the tests to continue executing after the child process launched by `execute_command_line` 7 | terminates. 8 | -------------------------------------------------------------------------------- /example/support-test/error_stop_with_character_code.F90: -------------------------------------------------------------------------------- 1 | program error_stop_with_character_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | implicit none 8 | 9 | integer init_exit_code 10 | logical(kind=c_bool), parameter :: false = .false._c_bool 11 | 12 | call prif_init(init_exit_code) 13 | call prif_error_stop(quiet=false, stop_code_char="USER_PROVIDED_STRING") ! a prif_error_stop unit test passes if this line executes error termination 14 | call prif_stop(quiet=false) ! a prif_error_stop unit test fails if this line runs 15 | end program 16 | -------------------------------------------------------------------------------- /example/support-test/error_stop_with_integer_code.F90: -------------------------------------------------------------------------------- 1 | program error_stop_with_integer_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | use unit_test_parameters_m, only : expected_error_stop_code 8 | implicit none 9 | 10 | integer init_exit_code 11 | logical(kind=c_bool), parameter :: true = .true._c_bool 12 | 13 | call prif_init(init_exit_code) 14 | call prif_error_stop(quiet=true, stop_code_int=expected_error_stop_code) ! a prif_error_stop unit test passes if this line executes error termination 15 | call prif_stop(quiet=true) ! a prif_error_stop unit tests fails if this line runs 16 | end program 17 | -------------------------------------------------------------------------------- /example/support-test/error_stop_with_no_code.F90: -------------------------------------------------------------------------------- 1 | program error_stop_with_no_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | implicit none 8 | 9 | integer init_exit_code 10 | logical(kind=c_bool), parameter :: true = .true._c_bool 11 | 12 | call prif_init(init_exit_code) 13 | call prif_error_stop(quiet=true) ! a prif_error_stop unit test passes if this line correctly executes error termination 14 | call prif_stop(quiet=true) ! a prif_error_stop unit test fails if this line runs 15 | 16 | end program 17 | -------------------------------------------------------------------------------- /example/support-test/register_stop_callback.F90: -------------------------------------------------------------------------------- 1 | program register_stop_callback 2 | use iso_c_binding, only: c_bool, c_int 3 | use prif, only : & 4 | prif_init, & 5 | prif_register_stop_callback, & 6 | prif_stop, & 7 | prif_stop_callback_interface 8 | implicit none 9 | 10 | integer init_exit_code 11 | logical(kind=c_bool), parameter :: false = .false._c_bool 12 | ! use of the pointer is unnecessary according to the standard, 13 | ! but gfortran complains without it 14 | procedure(prif_stop_callback_interface), pointer :: callback_ptr 15 | callback_ptr => callback 16 | 17 | call prif_init(init_exit_code) 18 | call prif_register_stop_callback(callback_ptr) 19 | call prif_stop(false) 20 | contains 21 | subroutine callback(is_error_stop, quiet, stop_code_int, stop_code_char) 22 | logical(c_bool), intent(in) :: is_error_stop, quiet 23 | integer(c_int), intent(in), optional :: stop_code_int 24 | character(len=*), intent(in), optional :: stop_code_char 25 | 26 | print *, "callback invoked" 27 | end subroutine 28 | end program -------------------------------------------------------------------------------- /example/support-test/stop_with_character_code.F90: -------------------------------------------------------------------------------- 1 | program stop_with_character_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | implicit none 8 | 9 | integer init_exit_code 10 | logical(kind=c_bool), parameter :: false = .false._c_bool 11 | 12 | call prif_init(init_exit_code) 13 | call prif_stop(quiet=false, stop_code_char="USER_PROVIDED_STRING") ! a prif_stop unit test passes if this line executes normal termination 14 | call prif_error_stop(quiet=false) ! a prif_stop unit test fails if this line runs 15 | end program 16 | -------------------------------------------------------------------------------- /example/support-test/stop_with_integer_code.F90: -------------------------------------------------------------------------------- 1 | program stop_with_integer_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | use unit_test_parameters_m, only : expected_stop_code 8 | implicit none 9 | 10 | integer init_exit_code 11 | logical(kind=c_bool), parameter :: false = .false._c_bool 12 | 13 | call prif_init(init_exit_code) 14 | call prif_stop(quiet=false, stop_code_int=expected_stop_code) ! a prif_stop unit test passes if this line executes normal termination 15 | call prif_error_stop(quiet=false) ! a prif_stop unit test fails if this line runs 16 | end program 17 | -------------------------------------------------------------------------------- /example/support-test/stop_with_no_code.F90: -------------------------------------------------------------------------------- 1 | program stop_with_no_code 2 | use iso_c_binding, only: c_bool 3 | use prif, only : & 4 | prif_init & 5 | ,prif_stop & 6 | ,prif_error_stop 7 | implicit none 8 | 9 | integer init_exit_code 10 | logical(kind=c_bool), parameter :: false = .false._c_bool 11 | 12 | call prif_init(init_exit_code) 13 | call prif_stop(false) ! a prif_stop test passes if this line executes normal termination 14 | call prif_error_stop(quiet=false) ! a prif_stop test fails if this line runs 15 | end program 16 | -------------------------------------------------------------------------------- /include/language-support.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #ifndef HAVE_SELECTED_LOGICAL_KIND 5 | ! Define whether the compiler supports standard intrinsic function selected_logical_kind(), 6 | ! a feature introduced in Fortran 2023 clause 16.9.182. 7 | #if defined(_CRAYFTN) || defined(NAGFOR) || defined(__flang__) 8 | #define HAVE_SELECTED_LOGICAL_KIND 1 9 | #else 10 | #define HAVE_SELECTED_LOGICAL_KIND 0 11 | #endif 12 | #endif 13 | 14 | #ifndef HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 15 | ! Define whether the compiler supports associating a procedure pointer dummy argument with an 16 | ! actual argument that is a valid target for the pointer dummy in a procedure assignment, a 17 | ! feature introduced in Fortran 2008 and described in Fortran 2023 clause 15.5.2.10 paragraph 5. 18 | #if defined(_CRAYFTN) || defined(__INTEL_COMPILER) || defined(NAGFOR) || defined(__flang__) 19 | #define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 20 | #else 21 | #define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 22 | #endif 23 | #endif 24 | -------------------------------------------------------------------------------- /manifest/fpm.toml.template: -------------------------------------------------------------------------------- 1 | name = "caffeine" 2 | version = "0.5.3" 3 | license = "BSD-3-Clause-LBNL" 4 | author = ["Damian Rouson", "Brad Richardson", "Katherine Rasmussen", "Dan Bonachea"] 5 | maintainer = "fortran@lbl.gov" 6 | copyright = "2021-2025 The Regents of the University of California, through Lawrence Berkeley National Laboratory" 7 | 8 | [dev-dependencies] 9 | assert = {git = "https://github.com/berkeleylab/assert.git", tag = "2.0.1"} 10 | veggies = {git = "https://gitlab.com/everythingfunctional/veggies", tag = "v1.1.3"} 11 | iso_varying_string = {git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v3.0.4"} 12 | 13 | [build] 14 | -------------------------------------------------------------------------------- /src/caffeine/alias_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) alias_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_alias_create 14 | call_assert(coarray_handle_check(source_handle)) 15 | 16 | call_assert(size(alias_lcobounds) == size(alias_ucobounds)) 17 | call_assert(product(alias_ucobounds - alias_lcobounds + 1) >= current_team%info%num_images) 18 | 19 | allocate(alias_handle%info) 20 | ! start with a copy of the source descriptor 21 | alias_handle%info = source_handle%info 22 | 23 | ! apply provided cobounds 24 | alias_handle%info%corank = size(alias_lcobounds) 25 | alias_handle%info%lcobounds(1:size(alias_lcobounds)) = alias_lcobounds 26 | alias_handle%info%ucobounds(1:size(alias_ucobounds)) = alias_ucobounds 27 | 28 | ! reset some fields that are unused in aliases 29 | alias_handle%info%reserved = c_null_ptr 30 | alias_handle%info%previous_handle = c_null_ptr 31 | alias_handle%info%next_handle = c_null_ptr 32 | alias_handle%info%final_func = c_null_funptr 33 | 34 | call_assert(coarray_handle_check(alias_handle)) 35 | end procedure 36 | 37 | module procedure prif_alias_destroy 38 | type(prif_coarray_descriptor), pointer :: info 39 | 40 | call_assert(coarray_handle_check(alias_handle)) 41 | 42 | info => alias_handle%info 43 | call_assert(.not. c_associated(info%reserved)) 44 | call_assert(.not. c_associated(info%previous_handle)) 45 | call_assert(.not. c_associated(info%next_handle)) 46 | call_assert(.not. c_associated(info%final_func)) 47 | 48 | deallocate(info) 49 | end procedure 50 | 51 | end submodule alias_s 52 | -------------------------------------------------------------------------------- /src/caffeine/allocation_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) allocation_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_allocate_coarray 14 | ! TODO: determining the size of the handle and where the coarray begins 15 | ! becomes a bit more complicated if we don't allocate space for 16 | ! 15 cobounds 17 | integer :: me 18 | type(c_ptr) :: whole_block 19 | integer(c_ptrdiff_t) :: block_offset 20 | integer(c_size_t) :: descriptor_size, total_size 21 | type(prif_coarray_descriptor) :: unused 22 | type(prif_coarray_descriptor), pointer :: unused2(:) 23 | 24 | call_assert(size(lcobounds) == size(ucobounds)) 25 | call_assert(product(ucobounds - lcobounds + 1) >= current_team%info%num_images) 26 | 27 | me = current_team%info%this_image 28 | if (caf_have_child_teams()) then 29 | ! Free the child team space to make sure we have space to allocate the coarray 30 | if (me == 1) then 31 | call caf_deallocate(current_team%info%heap_mspace, current_team%info%child_heap_info%allocated_memory) 32 | end if 33 | end if 34 | if (me == 1) then 35 | descriptor_size = c_sizeof(unused) 36 | total_size = descriptor_size + size_in_bytes 37 | whole_block = caf_allocate(current_team%info%heap_mspace, total_size) 38 | block_offset = as_int(whole_block) - current_team%info%heap_start 39 | else 40 | block_offset = 0 41 | end if 42 | call prif_sync_memory ! end the current segment 43 | ! Use a co_sum to aggregate broadcasing the information from image 1 44 | ! together with the team barrier spec-required by coarray allocation 45 | call prif_co_sum(block_offset) 46 | if (me /= 1) whole_block = as_c_ptr(current_team%info%heap_start + block_offset) 47 | 48 | call c_f_pointer(whole_block, coarray_handle%info) 49 | call c_f_pointer(whole_block, unused2, [2]) 50 | 51 | coarray_handle%info%coarray_data = c_loc(unused2(2)) 52 | coarray_handle%info%corank = size(lcobounds) 53 | coarray_handle%info%coarray_size = size_in_bytes 54 | coarray_handle%info%final_func = final_func 55 | coarray_handle%info%lcobounds(1:size(lcobounds)) = lcobounds 56 | coarray_handle%info%ucobounds(1:size(ucobounds)) = ucobounds 57 | coarray_handle%info%previous_handle = c_null_ptr 58 | coarray_handle%info%next_handle = c_null_ptr 59 | call add_to_team_list(coarray_handle) 60 | coarray_handle%info%reserved = c_null_ptr 61 | coarray_handle%info%p_context_data = c_loc(coarray_handle%info%reserved) 62 | 63 | allocated_memory = coarray_handle%info%coarray_data 64 | if (caf_have_child_teams()) then 65 | call caf_establish_child_heap 66 | end if 67 | 68 | call_assert(coarray_handle_check(coarray_handle)) 69 | end procedure 70 | 71 | module procedure prif_allocate 72 | allocated_memory = caf_allocate(non_symmetric_heap_mspace, size_in_bytes) 73 | end procedure 74 | 75 | module procedure prif_deallocate_coarray 76 | ! gfortran is yelling that this isn't valid for bind(C) 77 | ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=113338 78 | ! abstract interface 79 | ! subroutine coarray_cleanup_i(handle, stat, errmsg) bind(C) 80 | ! import c_int, prif_coarray_handle 81 | ! implicit none 82 | ! type(prif_coarray_handle), pointer, intent(in) :: handle 83 | ! integer(c_int), intent(out) :: stat 84 | ! character(len=:), intent(out), allocatable :: errmsg 85 | ! end subroutine 86 | ! end interface 87 | integer :: i, num_handles 88 | !integer(c_int) :: local_stat 89 | !character(len=:), allocatable :: local_errmsg 90 | ! procedure(coarray_cleanup_i), pointer :: coarray_cleanup 91 | character(len=*), parameter :: unallocated_message = "Attempted to deallocate unallocated coarray" 92 | 93 | call prif_sync_all ! Need to ensure we don't deallocate anything till everyone gets here 94 | num_handles = size(coarray_handles) 95 | if (.not. all([(associated(coarray_handles(i)%info), i = 1, num_handles)])) then 96 | if (present(stat)) then 97 | stat = 1 ! TODO: decide what our stat codes should be 98 | if (present(errmsg)) then 99 | errmsg = unallocated_message 100 | else if (present(errmsg_alloc)) then 101 | errmsg_alloc = unallocated_message 102 | end if 103 | return 104 | else 105 | call prif_error_stop(.false._c_bool, stop_code_char=unallocated_message) 106 | end if 107 | end if 108 | call_assert(all(coarray_handle_check(coarray_handles))) 109 | 110 | ! TODO: invoke finalizers from coarray_handles(:)%info%final_func 111 | ! do i = 1, num_handles 112 | ! if (coarray_handles(i)%info%final_func /= c_null_funptr) then 113 | ! call c_f_procpointer(coarray_handles(i)%info%final_func, coarray_cleanup) 114 | ! call coarray_cleanup(coarray_handles(i), local_stat, local_errmsg) 115 | ! call prif_co_sum(local_stat) ! Need to be sure it didn't fail on any images 116 | ! if (local_stat /= 0) then 117 | ! if (present(stat)) then 118 | ! stat = local_stat 119 | ! if (present(errmsg)) then 120 | ! errmsg = local_errmsg 121 | ! else if (present(errmsg_alloc)) then 122 | ! call move_alloc(local_errmsg, errmsg_alloc) 123 | ! end if 124 | ! return ! NOTE: We no longer have guarantees that coarrays are in consistent state 125 | ! else 126 | ! call prif_error_stop(.false._c_bool, stop_code_char=local_errmsg) 127 | ! end if 128 | ! end if 129 | ! end if 130 | ! end do 131 | do i = 1, num_handles 132 | call remove_from_team_list(coarray_handles(i)) 133 | if (current_team%info%this_image == 1) & 134 | call caf_deallocate(current_team%info%heap_mspace, c_loc(coarray_handles(i)%info)) 135 | end do 136 | if (present(stat)) stat = 0 137 | if (caf_have_child_teams()) then 138 | ! reclaim any free space possible for the child teams to use 139 | if (current_team%info%this_image == 1) then 140 | call caf_deallocate(current_team%info%heap_mspace, current_team%info%child_heap_info%allocated_memory) 141 | end if 142 | call caf_establish_child_heap 143 | end if 144 | end procedure 145 | 146 | module procedure prif_deallocate 147 | call caf_deallocate(non_symmetric_heap_mspace, mem) 148 | end procedure 149 | 150 | subroutine add_to_team_list(coarray_handle) 151 | type(prif_coarray_handle), intent(in) :: coarray_handle 152 | 153 | call_assert(.not.c_associated(coarray_handle%info%previous_handle)) 154 | call_assert(.not.c_associated(coarray_handle%info%next_handle)) 155 | 156 | if (associated(current_team%info%coarrays)) then 157 | current_team%info%coarrays%previous_handle = c_loc(coarray_handle%info) 158 | coarray_handle%info%next_handle = c_loc(current_team%info%coarrays) 159 | end if 160 | current_team%info%coarrays => coarray_handle%info 161 | end subroutine 162 | 163 | subroutine remove_from_team_list(coarray_handle) 164 | type(prif_coarray_handle), intent(in) :: coarray_handle 165 | 166 | type(prif_coarray_descriptor), pointer :: tmp_data 167 | 168 | if ( .not.c_associated(coarray_handle%info%previous_handle) & 169 | .and. .not.c_associated(coarray_handle%info%next_handle)) then 170 | call_assert(associated(current_team%info%coarrays, coarray_handle%info)) 171 | nullify(current_team%info%coarrays) 172 | return 173 | end if 174 | if (c_associated(coarray_handle%info%previous_handle)) then 175 | call c_f_pointer(coarray_handle%info%previous_handle, tmp_data) 176 | tmp_data%next_handle = coarray_handle%info%next_handle 177 | else 178 | call_assert(associated(current_team%info%coarrays, coarray_handle%info)) 179 | call c_f_pointer(coarray_handle%info%next_handle, current_team%info%coarrays) 180 | end if 181 | if (c_associated(coarray_handle%info%next_handle)) then 182 | call c_f_pointer(coarray_handle%info%next_handle, tmp_data) 183 | tmp_data%previous_handle = coarray_handle%info%previous_handle 184 | end if 185 | end subroutine 186 | 187 | end submodule allocation_s 188 | -------------------------------------------------------------------------------- /src/caffeine/atomic_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) atomic_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | 8 | contains 9 | 10 | module procedure prif_atomic_add 11 | call unimplemented("prif_atomic_add") 12 | end procedure 13 | 14 | module procedure prif_atomic_add_indirect 15 | call unimplemented("prif_atomic_add_indirect") 16 | end procedure 17 | 18 | module procedure prif_atomic_and 19 | call unimplemented("prif_atomic_and") 20 | end procedure 21 | 22 | module procedure prif_atomic_and_indirect 23 | call unimplemented("prif_atomic_and_indirect") 24 | end procedure 25 | 26 | module procedure prif_atomic_or 27 | call unimplemented("prif_atomic_or") 28 | end procedure 29 | 30 | module procedure prif_atomic_or_indirect 31 | call unimplemented("prif_atomic_or_indirect") 32 | end procedure 33 | 34 | module procedure prif_atomic_xor 35 | call unimplemented("prif_atomic_xor") 36 | end procedure 37 | 38 | module procedure prif_atomic_xor_indirect 39 | call unimplemented("prif_atomic_xor_indirect") 40 | end procedure 41 | 42 | module procedure prif_atomic_cas_int 43 | call unimplemented("prif_atomic_cas_int") 44 | end procedure 45 | 46 | module procedure prif_atomic_cas_int_indirect 47 | call unimplemented("prif_atomic_cas_int_indirect") 48 | end procedure 49 | 50 | module procedure prif_atomic_cas_logical 51 | call unimplemented("prif_atomic_cas_logical") 52 | end procedure 53 | 54 | module procedure prif_atomic_cas_logical_indirect 55 | call unimplemented("prif_atomic_cas_logical_indirect") 56 | end procedure 57 | 58 | module procedure prif_atomic_fetch_add 59 | call unimplemented("prif_atomic_fetch_add") 60 | end procedure 61 | 62 | module procedure prif_atomic_fetch_add_indirect 63 | call unimplemented("prif_atomic_fetch_add_indirect") 64 | end procedure 65 | 66 | module procedure prif_atomic_fetch_and 67 | call unimplemented("prif_atomic_fetch_and") 68 | end procedure 69 | 70 | module procedure prif_atomic_fetch_and_indirect 71 | call unimplemented("prif_atomic_fetch_and_indirect") 72 | end procedure 73 | 74 | module procedure prif_atomic_fetch_or 75 | call unimplemented("prif_atomic_fetch_or") 76 | end procedure 77 | 78 | module procedure prif_atomic_fetch_or_indirect 79 | call unimplemented("prif_atomic_fetch_or_indirect") 80 | end procedure 81 | 82 | module procedure prif_atomic_fetch_xor 83 | call unimplemented("prif_atomic_fetch_xor") 84 | end procedure 85 | 86 | module procedure prif_atomic_fetch_xor_indirect 87 | call unimplemented("prif_atomic_fetch_xor_indirect") 88 | end procedure 89 | 90 | module procedure prif_atomic_define_int 91 | call unimplemented("prif_atomic_define_int") 92 | end procedure 93 | 94 | module procedure prif_atomic_define_int_indirect 95 | call unimplemented("prif_atomic_define_int_indirect") 96 | end procedure 97 | 98 | module procedure prif_atomic_define_logical 99 | call unimplemented("prif_atomic_define_logical") 100 | end procedure 101 | 102 | module procedure prif_atomic_define_logical_indirect 103 | call unimplemented("prif_atomic_define_logical_indirect") 104 | end procedure 105 | 106 | module procedure prif_atomic_ref_int 107 | call unimplemented("prif_atomic_ref_int") 108 | end procedure 109 | 110 | module procedure prif_atomic_ref_int_indirect 111 | call unimplemented("prif_atomic_ref_int_indirect") 112 | end procedure 113 | 114 | module procedure prif_atomic_ref_logical 115 | call unimplemented("prif_atomic_ref_logical") 116 | end procedure 117 | 118 | module procedure prif_atomic_ref_logical_indirect 119 | call unimplemented("prif_atomic_ref_logical_indirect") 120 | end procedure 121 | 122 | end submodule atomic_s 123 | -------------------------------------------------------------------------------- /src/caffeine/co_broadcast_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) co_broadcast_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_co_broadcast 14 | call_assert(source_image >= 1 .and. source_image <= current_team%info%num_images) 15 | call contiguous_co_broadcast(a, source_image, stat, errmsg, errmsg_alloc) 16 | end procedure 17 | 18 | subroutine contiguous_co_broadcast(a, source_image, stat, errmsg, errmsg_alloc) 19 | type(*), intent(inout), target, contiguous :: a(..) 20 | integer(c_int), intent(in) :: source_image 21 | integer(c_int), intent(out), optional :: stat 22 | character(len=*), intent(inout), optional :: errmsg 23 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 24 | 25 | if (present(stat)) stat=0 26 | call caf_co_broadcast(a, source_image, product(shape(a)), current_team%info%gex_team) 27 | ! With a compliant Fortran 2018 compiler, pass in c_sizeof(a) as the `Nelem` argument 28 | ! and eliminate the calculation of num_elements*sizeof(a) in caffeine.c. 29 | end subroutine 30 | 31 | end submodule co_broadcast_s 32 | -------------------------------------------------------------------------------- /src/caffeine/co_max_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) co_max_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_co_max 14 | if (present(result_image)) then 15 | call_assert(result_image >= 1 .and. result_image <= current_team%info%num_images) 16 | endif 17 | call contiguous_co_max(a, result_image, stat, errmsg, errmsg_alloc) 18 | end procedure 19 | 20 | subroutine contiguous_co_max(a, result_image, stat, errmsg, errmsg_alloc) 21 | implicit none 22 | type(*), intent(inout), target, contiguous :: a(..) 23 | integer(c_int), intent(in), optional :: result_image 24 | integer(c_int), intent(out), optional :: stat 25 | character(len=*), intent(inout), optional :: errmsg 26 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 27 | 28 | if (present(stat)) stat=0 29 | 30 | call caf_co_max( & 31 | a, & 32 | optional_value(result_image), & 33 | int(product(shape(a)), c_size_t), & 34 | current_team%info%gex_team) 35 | end subroutine 36 | 37 | subroutine char_max_wrapper(arg1, arg2_and_out, count, cdata) bind(C) 38 | type(c_ptr), intent(in), value :: arg1, arg2_and_out 39 | integer(c_size_t), intent(in), value :: count 40 | type(c_ptr), intent(in), value :: cdata 41 | 42 | integer(c_size_t), pointer :: char_len 43 | integer(c_size_t) :: i 44 | 45 | if (count == 0) return 46 | call c_f_pointer(cdata, char_len) 47 | block 48 | character(len=char_len,kind=c_char), pointer :: lhs(:), rhs_and_result(:) 49 | call c_f_pointer(arg1, lhs, [count]) 50 | call c_f_pointer(arg2_and_out, rhs_and_result, [count]) 51 | do i = 1, count 52 | if (lhs(i) >= rhs_and_result(i)) rhs_and_result(i) = lhs(i) 53 | end do 54 | end block 55 | end subroutine 56 | 57 | module procedure prif_co_max_character 58 | integer(c_size_t), target :: char_len 59 | procedure(prif_operation_wrapper_interface), pointer :: op 60 | 61 | char_len = len(a) 62 | op => char_max_wrapper 63 | #if defined(__GFORTRAN__) && 0 64 | ! gfortran 13.2 (sometimes?) crashes on the call below 65 | ! internal compiler error: in make_decl_rtl, at varasm.cc:1442 66 | call unimplemented("prif_co_max_character") 67 | #else 68 | call prif_co_reduce(a, op, c_loc(char_len), result_image, stat, errmsg, errmsg_alloc) 69 | #endif 70 | end procedure 71 | 72 | end submodule co_max_s 73 | -------------------------------------------------------------------------------- /src/caffeine/co_min_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) co_min_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_co_min 14 | if (present(result_image)) then 15 | call_assert(result_image >= 1 .and. result_image <= current_team%info%num_images) 16 | endif 17 | call contiguous_co_min(a, result_image, stat, errmsg, errmsg_alloc) 18 | end procedure 19 | 20 | subroutine contiguous_co_min(a, result_image, stat, errmsg, errmsg_alloc) 21 | implicit none 22 | type(*), intent(inout), target, contiguous :: a(..) 23 | integer(c_int), intent(in), optional :: result_image 24 | integer(c_int), intent(out), optional :: stat 25 | character(len=*), intent(inout), optional :: errmsg 26 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 27 | 28 | if (present(stat)) stat=0 29 | 30 | call caf_co_min( & 31 | a, & 32 | optional_value(result_image), & 33 | int(product(shape(a)), c_size_t), & 34 | current_team%info%gex_team) 35 | end subroutine 36 | 37 | subroutine char_min_wrapper(arg1, arg2_and_out, count, cdata) bind(C) 38 | type(c_ptr), intent(in), value :: arg1, arg2_and_out 39 | integer(c_size_t), intent(in), value :: count 40 | type(c_ptr), intent(in), value :: cdata 41 | 42 | integer(c_size_t), pointer :: char_len 43 | integer(c_size_t) :: i 44 | 45 | if (count == 0) return 46 | call c_f_pointer(cdata, char_len) 47 | block 48 | character(len=char_len,kind=c_char), pointer :: lhs(:), rhs_and_result(:) 49 | call c_f_pointer(arg1, lhs, [count]) 50 | call c_f_pointer(arg2_and_out, rhs_and_result, [count]) 51 | do i = 1, count 52 | if (lhs(i) <= rhs_and_result(i)) rhs_and_result(i) = lhs(i) 53 | end do 54 | end block 55 | end subroutine 56 | 57 | module procedure prif_co_min_character 58 | integer(c_size_t), target :: char_len 59 | procedure(prif_operation_wrapper_interface), pointer :: op 60 | 61 | char_len = len(a) 62 | op => char_min_wrapper 63 | #if defined(__GFORTRAN__) && 0 64 | ! gfortran 13.2 (sometimes?) crashes on the call below 65 | ! internal compiler error: in make_decl_rtl, at varasm.cc:1442 66 | call unimplemented("prif_co_min_character") 67 | #else 68 | call prif_co_reduce(a, op, c_loc(char_len), result_image, stat, errmsg, errmsg_alloc) 69 | #endif 70 | end procedure 71 | 72 | end submodule co_min_s 73 | -------------------------------------------------------------------------------- /src/caffeine/co_reduce_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) co_reduce_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | contains 11 | 12 | module subroutine prif_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) 13 | type(*), intent(inout), target :: a(..) 14 | procedure(prif_operation_wrapper_interface), pointer, intent(in) :: operation_wrapper 15 | type(c_ptr), intent(in), value :: cdata 16 | integer(c_int), intent(in), optional :: result_image 17 | integer(c_int), intent(out), optional :: stat 18 | character(len=*), intent(inout), optional :: errmsg 19 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 20 | if (present(result_image)) then 21 | call_assert(result_image >= 1 .and. result_image <= current_team%info%num_images) 22 | endif 23 | call_assert_describe(associated(operation_wrapper), "prif_co_reduce: associated(operation_wrapper)") 24 | call contiguous_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) 25 | end subroutine 26 | 27 | subroutine contiguous_co_reduce(a, operation_wrapper, cdata, result_image, stat, errmsg, errmsg_alloc) 28 | type(*), intent(inout), target, contiguous :: a(..) 29 | procedure(prif_operation_wrapper_interface), pointer, intent(in) :: operation_wrapper 30 | type(c_ptr), intent(in), value :: cdata 31 | integer(c_int), intent(in), optional :: result_image 32 | integer(c_int), intent(out), optional :: stat 33 | character(len=*), intent(inout), optional :: errmsg 34 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 35 | type(c_funptr) :: funptr 36 | 37 | if (present(stat)) stat=0 38 | 39 | funptr = c_funloc(operation_wrapper) 40 | call_assert(c_associated(funptr)) 41 | 42 | call caf_co_reduce( & 43 | a, & 44 | optional_value(result_image), & 45 | int(product(shape(a)), c_size_t), & 46 | funptr, & 47 | cdata, & 48 | current_team%info%gex_team) 49 | end subroutine 50 | 51 | end submodule co_reduce_s 52 | -------------------------------------------------------------------------------- /src/caffeine/co_sum_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) co_sum_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_co_sum 14 | if (present(result_image)) then 15 | call_assert(result_image >= 1 .and. result_image <= current_team%info%num_images) 16 | endif 17 | call contiguous_co_sum(a, result_image, stat, errmsg, errmsg_alloc) 18 | end procedure 19 | 20 | subroutine contiguous_co_sum(a, result_image, stat, errmsg, errmsg_alloc) 21 | type(*), intent(inout), target, contiguous :: a(..) 22 | integer(c_int), intent(in), optional :: result_image 23 | integer(c_int), intent(out), optional :: stat 24 | character(len=*), intent(inout), optional :: errmsg 25 | character(len=:), intent(inout), allocatable, optional :: errmsg_alloc 26 | 27 | if (present(stat)) stat=0 28 | 29 | call caf_co_sum( & 30 | a, optional_value(result_image), int(product(shape(a)), c_size_t), current_team%info%gex_team) 31 | end subroutine 32 | 33 | end submodule co_sum_s 34 | -------------------------------------------------------------------------------- /src/caffeine/coarray_queries_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) coarray_queries_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_lcobound_with_dim 14 | call_assert(coarray_handle_check(coarray_handle)) 15 | call_assert(dim >= 1 .and. dim <= coarray_handle%info%corank) 16 | 17 | lcobound = coarray_handle%info%lcobounds(dim) 18 | end procedure 19 | 20 | module procedure prif_lcobound_no_dim 21 | call_assert(coarray_handle_check(coarray_handle)) 22 | 23 | lcobounds = coarray_handle%info%lcobounds(1:coarray_handle%info%corank) 24 | end procedure 25 | 26 | module procedure prif_ucobound_with_dim 27 | call_assert(coarray_handle_check(coarray_handle)) 28 | call_assert(dim >= 1 .and. dim <= coarray_handle%info%corank) 29 | 30 | ucobound = coarray_handle%info%ucobounds(dim) 31 | end procedure 32 | 33 | module procedure prif_ucobound_no_dim 34 | call_assert(coarray_handle_check(coarray_handle)) 35 | 36 | ucobounds = coarray_handle%info%ucobounds(1:coarray_handle%info%corank) 37 | end procedure 38 | 39 | module procedure prif_coshape 40 | 41 | call_assert(coarray_handle_check(coarray_handle)) 42 | 43 | associate(info => coarray_handle%info) 44 | sizes = info%ucobounds(1:info%corank) - info%lcobounds(1:info%corank) + 1 45 | end associate 46 | end procedure 47 | 48 | subroutine image_index_helper(coarray_handle, sub, num_images, image_index) 49 | implicit none 50 | type(prif_coarray_handle), intent(in) :: coarray_handle 51 | integer(c_int64_t), intent(in) :: sub(:) 52 | integer(c_int), intent(in) :: num_images 53 | integer(c_int), intent(out) :: image_index 54 | 55 | integer :: dim 56 | integer(c_int) :: prior_size 57 | 58 | call_assert(coarray_handle_check(coarray_handle)) 59 | 60 | associate (info => coarray_handle%info) 61 | call_assert(size(sub) == info%corank) 62 | if (sub(1) .lt. info%lcobounds(1) .or. sub(1) .gt. info%ucobounds(1)) then 63 | image_index = 0 64 | return 65 | end if 66 | image_index = 1 + INT(sub(1) - info%lcobounds(1), c_int) 67 | prior_size = 1 68 | ! Future work: values of prior_size are invariant across calls w/ the same coarray_handle 69 | ! We could store them in the coarray metadata at allocation rather than redundantly 70 | ! computing them here, which would accelerate calls with corank > 1 by removing 71 | ! corank multiply/add operations and the loop-carried dependence 72 | do dim = 2, size(sub) 73 | prior_size = prior_size * INT(info%ucobounds(dim-1) - info%lcobounds(dim-1) + 1, c_int) 74 | if (sub(dim) .lt. info%lcobounds(dim) .or. sub(dim) .gt. info%ucobounds(dim)) then 75 | image_index = 0 76 | return 77 | end if 78 | image_index = image_index + INT(sub(dim) - info%lcobounds(dim), c_int) * prior_size 79 | end do 80 | end associate 81 | 82 | if (image_index .gt. num_images) then 83 | image_index = 0 84 | end if 85 | end subroutine 86 | 87 | module procedure prif_image_index 88 | call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index) 89 | end procedure 90 | 91 | module procedure prif_image_index_with_team 92 | call image_index_helper(coarray_handle, sub, team%info%num_images, image_index) 93 | end procedure 94 | 95 | module procedure prif_image_index_with_team_number 96 | if (team_number == -1) then 97 | call image_index_helper(coarray_handle, sub, initial_team%num_images, image_index) 98 | else if (team_number == current_team%info%team_number) then 99 | call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index) 100 | else 101 | call unimplemented("prif_image_index_with_team_number: no support for sibling teams") 102 | end if 103 | end procedure 104 | 105 | module procedure prif_local_data_pointer 106 | call_assert(coarray_handle_check(coarray_handle)) 107 | 108 | local_data = coarray_handle%info%coarray_data 109 | end procedure 110 | 111 | module procedure prif_set_context_data 112 | type(c_ptr), pointer :: array_context_data 113 | call_assert(coarray_handle_check(coarray_handle)) 114 | 115 | call c_f_pointer(coarray_handle%info%p_context_data, array_context_data) 116 | array_context_data = context_data 117 | end procedure 118 | 119 | module procedure prif_get_context_data 120 | type(c_ptr), pointer :: array_context_data 121 | call_assert(coarray_handle_check(coarray_handle)) 122 | 123 | call c_f_pointer(coarray_handle%info%p_context_data, array_context_data) 124 | context_data = array_context_data 125 | end procedure 126 | 127 | module procedure prif_size_bytes 128 | call_assert(coarray_handle_check(coarray_handle)) 129 | 130 | data_size = coarray_handle%info%coarray_size 131 | end procedure 132 | 133 | end submodule coarray_queries_s 134 | -------------------------------------------------------------------------------- /src/caffeine/critical_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) critical_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | 8 | contains 9 | 10 | module procedure prif_critical 11 | call unimplemented("prif_critical") 12 | end procedure 13 | 14 | module procedure prif_end_critical 15 | call unimplemented("prif_end_critical") 16 | end procedure 17 | 18 | end submodule critical_s 19 | -------------------------------------------------------------------------------- /src/caffeine/events_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) events_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_event_post 14 | integer(c_intptr_t) :: remote_base 15 | 16 | call_assert(coarray_handle_check(coarray_handle)) 17 | call_assert(offset >= 0) 18 | 19 | call base_pointer(coarray_handle, image_num, remote_base) 20 | call prif_event_post_indirect( & 21 | image_num = image_num, & 22 | event_var_ptr = remote_base + offset, & 23 | stat = stat, errmsg = errmsg, errmsg_alloc = errmsg_alloc) 24 | end procedure 25 | 26 | module procedure prif_event_post_indirect 27 | call_assert_describe(image_num > 0 .and. image_num <= initial_team%num_images, "image_num not within valid range") 28 | 29 | call caf_event_post(image_num, event_var_ptr, & 30 | segment_boundary=1, release_fence=1) 31 | 32 | if (present(stat)) stat = 0 33 | end procedure 34 | 35 | module procedure prif_event_wait 36 | integer(c_int64_t) :: threshold 37 | 38 | if (present(until_count)) then 39 | threshold = MAX(until_count, 1) 40 | else 41 | threshold = 1 42 | endif 43 | call caf_event_wait(event_var_ptr, threshold, & 44 | segment_boundary=1, acquire_fence=1) 45 | 46 | if (present(stat)) stat = 0 47 | end procedure 48 | 49 | module procedure prif_event_query 50 | call caf_event_query(event_var_ptr, count) 51 | 52 | if (present(stat)) stat = 0 53 | end procedure 54 | 55 | module procedure prif_notify_wait 56 | integer(c_int64_t) :: threshold 57 | 58 | if (present(until_count)) then 59 | threshold = MAX(until_count, 1) 60 | else 61 | threshold = 1 62 | endif 63 | call caf_event_wait(notify_var_ptr, threshold, & 64 | segment_boundary=0, acquire_fence=1) 65 | 66 | if (present(stat)) stat = 0 67 | end procedure 68 | 69 | end submodule events_s 70 | -------------------------------------------------------------------------------- /src/caffeine/gasnet_safe.h: -------------------------------------------------------------------------------- 1 | // Copyright (c), The Regents of the University of California 2 | // Terms of use are as specified in LICENSE.txt 3 | 4 | #ifndef _GASNET_SAFE_ 5 | #define _GASNET_SAFE_ 6 | #include 7 | 8 | /* Macro to check return codes and terminate with useful message. */ 9 | #define GASNET_SAFE(fncall) do { \ 10 | int _retval; \ 11 | if ((_retval = fncall) != GASNET_OK) { \ 12 | fprintf(stderr, "ERROR calling: %s\n" \ 13 | " at: %s:%i\n" \ 14 | " error: %s (%s)\n", \ 15 | #fncall, __FILE__, __LINE__, \ 16 | gasnet_ErrorName(_retval), gasnet_ErrorDesc(_retval)); \ 17 | fflush(stderr); \ 18 | gasnet_exit(_retval); \ 19 | } \ 20 | } while(0) 21 | #endif 22 | -------------------------------------------------------------------------------- /src/caffeine/image_queries_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) image_queries_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | contains 12 | 13 | module procedure prif_num_images 14 | num_images = current_team%info%num_images 15 | end procedure 16 | 17 | module procedure prif_num_images_with_team 18 | num_images = team%info%num_images 19 | end procedure 20 | 21 | module procedure prif_num_images_with_team_number 22 | if (team_number == -1) then 23 | num_images = initial_team%num_images 24 | else if (team_number == current_team%info%team_number) then 25 | num_images = current_team%info%num_images 26 | else 27 | call unimplemented("prif_num_images_with_team_number: no support for sibling teams") 28 | end if 29 | end procedure 30 | 31 | module procedure prif_this_image_no_coarray 32 | if (present(team)) then 33 | this_image = team%info%this_image 34 | else 35 | this_image = current_team%info%this_image 36 | endif 37 | end procedure 38 | 39 | module procedure prif_this_image_with_coarray 40 | integer(c_int) :: offset, doff, dsz 41 | integer :: dim 42 | 43 | call_assert(coarray_handle_check(coarray_handle)) 44 | 45 | if (present(team)) then 46 | offset = team%info%this_image - 1 47 | else 48 | offset = current_team%info%this_image - 1 49 | endif 50 | 51 | associate (info => coarray_handle%info) 52 | call_assert(size(cosubscripts) == info%corank) 53 | do dim = 1, info%corank-1 54 | dsz = INT(info%ucobounds(dim) - info%lcobounds(dim) + 1, c_int) 55 | doff = mod(offset, dsz) 56 | cosubscripts(dim) = doff + info%lcobounds(dim) 57 | call_assert(cosubscripts(dim) <= info%ucobounds(dim)) 58 | offset = offset / dsz 59 | end do 60 | cosubscripts(info%corank) = offset + info%lcobounds(info%corank) 61 | call_assert(cosubscripts(info%corank) <= info%ucobounds(info%corank)) 62 | end associate 63 | 64 | # if ASSERTIONS 65 | block ! sanity check 66 | integer(c_int) :: image_index 67 | if (present(team)) then 68 | call prif_image_index_with_team(coarray_handle, cosubscripts, team, image_index) 69 | call_assert(image_index == team%info%this_image) 70 | else 71 | call prif_image_index(coarray_handle, cosubscripts, image_index) 72 | call_assert(image_index == current_team%info%this_image) 73 | end if 74 | end block 75 | # endif 76 | end procedure 77 | 78 | module procedure prif_this_image_with_dim 79 | call_assert(coarray_handle_check(coarray_handle)) 80 | 81 | block 82 | integer(c_int64_t) :: cosubscripts(coarray_handle%info%corank) 83 | 84 | call_assert(dim >= 1 .and. dim <= coarray_handle%info%corank) 85 | 86 | call prif_this_image_with_coarray(coarray_handle, team, cosubscripts) 87 | 88 | cosubscript = cosubscripts(dim) 89 | end block 90 | end procedure 91 | 92 | module procedure prif_failed_images 93 | ! no current support for detecting image failure 94 | allocate(failed_images(0)) 95 | end procedure 96 | 97 | module procedure prif_stopped_images 98 | ! no current support for detecting image stops 99 | allocate(stopped_images(0)) 100 | end procedure 101 | 102 | module procedure prif_image_status 103 | ! no current support for detecting image failure/stops 104 | image_status = 0 105 | end procedure 106 | 107 | end submodule image_queries_s 108 | -------------------------------------------------------------------------------- /src/caffeine/locks_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) locks_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | 8 | contains 9 | 10 | module procedure prif_lock 11 | call unimplemented("prif_lock") 12 | end procedure 13 | 14 | module procedure prif_lock_indirect 15 | call unimplemented("prif_lock_indirect") 16 | end procedure 17 | 18 | module procedure prif_unlock 19 | call unimplemented("prif_unlock") 20 | end procedure 21 | 22 | module procedure prif_unlock_indirect 23 | call unimplemented("prif_unlock_indirect") 24 | end procedure 25 | 26 | end submodule locks_s 27 | -------------------------------------------------------------------------------- /src/caffeine/program_startup_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) program_startup_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | contains 8 | 9 | module procedure prif_init 10 | logical, save :: prif_init_called_previously = .false. 11 | 12 | if (prif_init_called_previously) then 13 | stat = PRIF_STAT_ALREADY_INIT 14 | else 15 | call caf_caffeinate( & 16 | initial_team%heap_mspace, & 17 | initial_team%heap_start, & 18 | initial_team%heap_size, & 19 | non_symmetric_heap_mspace, & 20 | initial_team%gex_team) 21 | call assert_init() 22 | current_team%info => initial_team 23 | initial_team%parent_team => initial_team 24 | initial_team%team_number = -1 25 | initial_team%this_image = caf_this_image(initial_team%gex_team) 26 | initial_team%num_images = caf_num_images(initial_team%gex_team) 27 | 28 | call sync_init() 29 | 30 | prif_init_called_previously = .true. 31 | stat = 0 32 | end if 33 | end procedure 34 | 35 | #if ASSERT_PARALLEL_CALLBACKS 36 | subroutine assert_init() 37 | implicit none 38 | assert_this_image => assert_callback_this_image 39 | assert_error_stop => assert_callback_error_stop 40 | end subroutine 41 | pure function assert_callback_this_image() result(this_image_id) 42 | implicit none 43 | integer :: this_image_id 44 | 45 | this_image_id = initial_team%this_image 46 | end function 47 | 48 | pure subroutine assert_callback_error_stop(stop_code_char) 49 | implicit none 50 | character(len=*), intent(in) :: stop_code_char 51 | character(len=:), allocatable, target :: tmp 52 | tmp = stop_code_char 53 | 54 | call caf_fatal_error(tmp) 55 | end subroutine 56 | #else 57 | subroutine assert_init() 58 | end subroutine 59 | #endif 60 | 61 | end submodule program_startup_s 62 | -------------------------------------------------------------------------------- /src/caffeine/program_termination_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) program_termination_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | 8 | type :: callback_entry 9 | procedure(prif_stop_callback_interface), pointer, nopass :: callback 10 | type(callback_entry), pointer :: next => null() 11 | end type 12 | 13 | type(callback_entry), pointer :: callback_list => null() 14 | 15 | contains 16 | 17 | module procedure prif_register_stop_callback 18 | type(callback_entry), pointer :: new_entry 19 | allocate(new_entry) 20 | new_entry%callback => callback 21 | if (associated(callback_list)) then 22 | new_entry%next => callback_list 23 | end if 24 | callback_list => new_entry 25 | end procedure 26 | 27 | module procedure prif_stop 28 | call prif_sync_all 29 | call run_callbacks(.false._c_bool, quiet, stop_code_int, stop_code_char) 30 | 31 | if (present(stop_code_char)) then 32 | call prif_stop_character(quiet, stop_code_char) 33 | else 34 | call prif_stop_integer(quiet, stop_code_int) 35 | end if 36 | 37 | contains 38 | 39 | subroutine prif_stop_integer(quiet, stop_code) 40 | !! synchronize, stop the executing image, and provide the stop_code, or 0 if not present, as the process exit status 41 | logical(c_bool), intent(in) :: quiet 42 | integer(c_int), intent(in), optional :: stop_code 43 | integer(c_int) :: exit_code 44 | 45 | if (present(stop_code)) then 46 | if (.not. quiet) then 47 | write(output_unit, *) "STOP ", stop_code 48 | flush output_unit 49 | end if 50 | exit_code = stop_code 51 | else 52 | if (.not. quiet) then 53 | write(output_unit, *) "STOP" 54 | flush output_unit 55 | end if 56 | exit_code = 0_c_int 57 | end if 58 | 59 | call caf_decaffeinate(exit_code) 60 | 61 | end subroutine prif_stop_integer 62 | 63 | subroutine prif_stop_character(quiet, stop_code) 64 | !! synchronize, stop the executing image, and provide the stop_code as the process exit status 65 | logical(c_bool), intent(in) :: quiet 66 | character(len=*), intent(in) :: stop_code 67 | 68 | if (.not. quiet) then 69 | write(output_unit, *) "STOP '" // stop_code // "'" 70 | flush output_unit 71 | end if 72 | 73 | call caf_decaffeinate(exit_code=0_c_int) ! does not return 74 | 75 | end subroutine prif_stop_character 76 | 77 | end procedure prif_stop 78 | 79 | module procedure prif_error_stop 80 | call run_callbacks(.true._c_bool, quiet, stop_code_int, stop_code_char) 81 | if (present(stop_code_char)) then 82 | call prif_error_stop_character(quiet, stop_code_char) 83 | else 84 | call prif_error_stop_integer(quiet, stop_code_int) 85 | end if 86 | end procedure prif_error_stop 87 | 88 | subroutine prif_error_stop_character(quiet, stop_code) 89 | !! stop all images and provide the stop_code as the process exit status 90 | logical(c_bool), intent(in) :: quiet 91 | character(len=*), intent(in) :: stop_code 92 | 93 | if (.not. quiet) then 94 | write(error_unit, *) "ERROR STOP '" // stop_code // "'" 95 | flush error_unit 96 | end if 97 | 98 | call caf_decaffeinate(1_c_int) ! does not return 99 | end subroutine 100 | 101 | subroutine prif_error_stop_integer(quiet, stop_code) 102 | !! stop all images and provide the stop_code, or 1 if not present, as the process exit status 103 | logical(c_bool), intent(in) :: quiet 104 | integer(c_int), intent(in), optional :: stop_code 105 | integer(c_int) :: exit_code 106 | 107 | if (present(stop_code)) then 108 | if (.not.quiet) then 109 | write(error_unit,'(A, I0)') "ERROR STOP ", stop_code 110 | flush error_unit 111 | end if 112 | exit_code = stop_code 113 | else 114 | if (.not.quiet) then 115 | write(error_unit,'(a)') "ERROR STOP" 116 | flush error_unit 117 | end if 118 | exit_code = 1_c_int 119 | end if 120 | 121 | call caf_decaffeinate(exit_code) ! does not return 122 | end subroutine 123 | 124 | module procedure prif_fail_image 125 | call unimplemented("prif_fail_image") 126 | end procedure 127 | 128 | subroutine run_callbacks(is_error_stop, quiet, stop_code_int, stop_code_char) 129 | logical(c_bool), intent(in) :: is_error_stop, quiet 130 | integer(c_int), intent(in), optional :: stop_code_int 131 | character(len=*), intent(in), optional :: stop_code_char 132 | 133 | type(callback_entry), pointer :: next_entry 134 | 135 | next_entry => callback_list 136 | do while (associated(next_entry)) 137 | call next_entry%callback(is_error_stop, quiet, stop_code_int, stop_code_char) 138 | next_entry => next_entry%next 139 | end do 140 | end subroutine 141 | 142 | end submodule program_termination_s 143 | -------------------------------------------------------------------------------- /src/caffeine/sync_stmt_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | 4 | #include "assert_macros.h" 5 | 6 | submodule(prif:prif_private_s) sync_stmt_s 7 | ! DO NOT ADD USE STATEMENTS HERE 8 | ! All use statements belong in prif_private_s.F90 9 | implicit none 10 | 11 | ! Data structures used to implement prif_sync_images 12 | type(prif_coarray_handle) :: si_coarray_handle 13 | type(prif_event_type), pointer :: si_evt(:) 14 | integer(c_size_t) :: sizeof_event 15 | 16 | contains 17 | 18 | module procedure prif_sync_all 19 | call caf_sync_team(current_team%info%gex_team) 20 | if (present(stat)) stat = 0 21 | end procedure 22 | 23 | module procedure prif_sync_team 24 | call caf_sync_team(team%info%gex_team) 25 | if (present(stat)) stat = 0 26 | end procedure 27 | 28 | module procedure prif_sync_memory 29 | call caf_sync_memory 30 | if (present(stat)) stat = 0 31 | end procedure 32 | 33 | module procedure sync_init 34 | ! Create the array coarray used to implement prif_sync_images 35 | ! This following is effectively: 36 | ! type(EVENT_TYPE), allocatable :: si_evt(:)[*] 37 | ! ALLOCATE( si_evt(NUM_IMAGES()) ) 38 | type(prif_event_type) :: dummy_event 39 | type(c_ptr) :: allocated_memory 40 | 41 | associate(num_imgs => initial_team%num_images) 42 | 43 | sizeof_event = int(storage_size(dummy_event)/8, c_size_t) 44 | 45 | call prif_allocate_coarray( & 46 | lcobounds = [1_c_int64_t], & 47 | ucobounds = [int(num_imgs,c_int64_t)], & 48 | size_in_bytes = sizeof_event * num_imgs, & 49 | final_func = c_null_funptr, & 50 | coarray_handle = si_coarray_handle, & 51 | allocated_memory = allocated_memory) 52 | call c_f_pointer(allocated_memory, si_evt, [num_imgs]) 53 | si_evt = dummy_event ! default initialize 54 | 55 | end associate 56 | 57 | end procedure 58 | 59 | module procedure prif_sync_images 60 | integer(c_int) :: i, img, l, u 61 | integer(c_intptr_t) :: evt_ptr 62 | 63 | call_assert(coarray_handle_check(si_coarray_handle)) 64 | 65 | call caf_sync_memory ! end segment and amortize release fence 66 | 67 | associate(num_imgs => current_team%info%num_images) 68 | if (present(image_set)) then 69 | l = lbound(image_set,1) 70 | u = ubound(image_set,1) 71 | # if ASSERTIONS 72 | block ! input validation 73 | logical p(num_imgs) 74 | p = .false. 75 | do i = l,u 76 | call_assert(image_set(i) >= 1 .and. image_set(i) <= num_imgs) 77 | call_assert_describe(.not. p(image_set(i)), "image indices in SYNC IMAGES are not distinct!") 78 | p(image_set(i)) = .true. 79 | end do 80 | end block 81 | # endif 82 | else ! SYNC IMAGES (*) 83 | l = 1 84 | u = num_imgs 85 | endif 86 | end associate 87 | 88 | ! post an event to each peer in my slot 89 | do i=l,u 90 | if (present(image_set)) then 91 | img = image_set(i) 92 | else 93 | img = i 94 | endif 95 | img = caf_image_to_initial( current_team%info%gex_team, img ) 96 | call base_pointer(si_coarray_handle, img, evt_ptr) 97 | evt_ptr = evt_ptr + sizeof_event * (initial_team%this_image - 1) 98 | call caf_event_post(img, evt_ptr, & 99 | segment_boundary=0, release_fence=0) 100 | end do 101 | 102 | ! reap an event from each peer in its slot 103 | ! final iteration issues acquire fence 104 | do i=l,u 105 | if (present(image_set)) then 106 | img = image_set(i) 107 | else 108 | img = i 109 | endif 110 | img = caf_image_to_initial( current_team%info%gex_team, img ) 111 | call caf_event_wait(c_loc(si_evt(img)), 1_c_int64_t, & 112 | segment_boundary=0, & 113 | acquire_fence=merge(1,0,i==u)) 114 | end do 115 | 116 | end procedure 117 | 118 | end submodule 119 | -------------------------------------------------------------------------------- /src/caffeine/teams_s.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University of California 2 | ! Terms of use are as specified in LICENSE.txt 3 | submodule(prif:prif_private_s) teams_s 4 | ! DO NOT ADD USE STATEMENTS HERE 5 | ! All use statements belong in prif_private_s.F90 6 | implicit none 7 | contains 8 | 9 | module procedure prif_change_team 10 | team%info%heap_start = current_team%info%child_heap_info%offset + current_team%info%heap_start 11 | team%info%heap_size = current_team%info%child_heap_info%size 12 | if (caf_this_image(team%info%gex_team) == 1) then ! need to setup the heap for the team 13 | call caf_establish_mspace( & 14 | team%info%heap_mspace, & 15 | as_c_ptr(team%info%heap_start), & 16 | current_team%info%child_heap_info%size) 17 | end if 18 | current_team = team 19 | if (caf_have_child_teams()) then ! need to establish heap for child teams 20 | call caf_establish_child_heap 21 | end if 22 | call prif_sync_all ! child team sync required by F23 11.1.5.2 23 | end procedure 24 | 25 | module procedure prif_end_team 26 | type(prif_coarray_handle), allocatable :: teams_coarrays(:) 27 | integer :: num_coarrays_in_team, i 28 | type(prif_coarray_descriptor), pointer :: tmp_data 29 | 30 | ! deallocate the teams coarrays 31 | ! Currently we work to batch together all the deallocations into a single call 32 | ! to prif_deallocate_coarray(), in the hope it can amortize some costs 33 | num_coarrays_in_team = 0 34 | tmp_data => current_team%info%coarrays 35 | do while (associated(tmp_data)) 36 | num_coarrays_in_team = num_coarrays_in_team + 1 37 | call c_f_pointer(tmp_data%next_handle, tmp_data) 38 | end do 39 | if (num_coarrays_in_team > 0) then 40 | allocate(teams_coarrays(num_coarrays_in_team)) 41 | tmp_data => current_team%info%coarrays 42 | do i = 1, num_coarrays_in_team 43 | teams_coarrays(i)%info => tmp_data 44 | call c_f_pointer(tmp_data%next_handle, tmp_data) 45 | end do 46 | call prif_deallocate_coarray(teams_coarrays, stat, errmsg, errmsg_alloc) 47 | nullify(current_team%info%coarrays) 48 | else 49 | ! child team sync required by F23 11.1.5.2, 50 | ! because we skipped the prif_deallocate_coarray call above that includes same 51 | call prif_sync_all 52 | end if 53 | 54 | ! set the current team back to the parent team 55 | current_team%info => current_team%info%parent_team 56 | end procedure 57 | 58 | module procedure prif_form_team 59 | call prif_sync_memory 60 | 61 | ! indicates this is the first time we're creating a child team 62 | if (.not.caf_have_child_teams()) then 63 | allocate(current_team%info%child_heap_info) 64 | call caf_establish_child_heap 65 | end if 66 | 67 | block 68 | integer(c_int) :: new_index_ 69 | if (present(new_index)) then 70 | new_index_ = new_index 71 | else 72 | new_index_ = 1 73 | end if 74 | 75 | ! DOB: The two allocates in this procedure do not have a corresponding deallocate, 76 | ! because Fortran lacks a destroy team operation. We consider this to represent 77 | ! a defect in the Fortran design of teams. 78 | ! As such, team-specific state such as these data structures and the corresponding 79 | ! team-related data structures in GASNet can never be reclaimed. 80 | allocate(team%info) 81 | team%info%parent_team => current_team%info 82 | call caf_form_team(current_team%info%gex_team, team%info%gex_team, team_number, new_index_) 83 | team%info%team_number = team_number 84 | team%info%this_image = caf_this_image(team%info%gex_team) 85 | team%info%num_images = caf_num_images(team%info%gex_team) 86 | end block 87 | end procedure 88 | 89 | module procedure prif_get_team 90 | if (.not. present(level)) then 91 | team = current_team 92 | else if (level == PRIF_CURRENT_TEAM) then 93 | team = current_team 94 | else if (level == PRIF_PARENT_TEAM) then 95 | team = prif_team_type(current_team%info%parent_team) 96 | else if (level == PRIF_INITIAL_TEAM) then 97 | team = prif_team_type(initial_team) 98 | else 99 | call prif_error_stop(.false._c_bool, stop_code_char="prif_get_team: invalid level") 100 | endif 101 | end procedure 102 | 103 | module procedure prif_team_number 104 | if (present(team)) then 105 | team_number = team%info%team_number 106 | else 107 | team_number = current_team%info%team_number 108 | endif 109 | end procedure 110 | 111 | end submodule 112 | -------------------------------------------------------------------------------- /src/caffeine/unit_test_parameters_m.F90: -------------------------------------------------------------------------------- 1 | ! Copyright (c), The Regents of the University 2 | ! Terms of use are as specified in LICENSE.txt 3 | module unit_test_parameters_m 4 | use prif, only: prif_sync_all, prif_this_image_no_coarray 5 | !! Define values and utilities for consistent use throughout the test suite 6 | implicit none 7 | 8 | public 9 | 10 | enum, bind(C) 11 | enumerator :: expected_stop_code=99, expected_error_stop_code 12 | ! used in stop/error-stop unit tests and example/test-support supporting programs 13 | end enum 14 | 15 | character(len=:), allocatable :: subjob_prefix 16 | 17 | contains 18 | 19 | ! subjob support used by stop/error-stop unit tests 20 | ! setup for subjob launch, initializes subjob_prefix and 21 | ! returns whether this is the first image 22 | function subjob_setup() result(result_) 23 | character(len=*), parameter :: envvar = "SUBJOB_PREFIX" 24 | logical :: result_ 25 | integer :: me, len 26 | character :: dummy 27 | 28 | if (.not. allocated(subjob_prefix)) then 29 | call get_environment_variable(envvar, dummy, len) 30 | if (len > 0) then 31 | allocate(character(len=len+1)::subjob_prefix) 32 | call get_environment_variable(envvar, subjob_prefix, len) 33 | else 34 | subjob_prefix = "" 35 | endif 36 | !print *,"SUBJOB_PREFIX='"//subjob_prefix//"' len=",len 37 | end if 38 | 39 | call prif_sync_all() 40 | call prif_this_image_no_coarray(this_image=me) 41 | result_ = (me == 1) .and. (subjob_prefix /= "skip") 42 | end function 43 | 44 | 45 | end module unit_test_parameters_m 46 | -------------------------------------------------------------------------------- /src/dlmalloc/dl_malloc_caf.h: -------------------------------------------------------------------------------- 1 | #ifndef _485f7f27_ce8a_4829_a04c_aaa8182adab9 2 | #define _485f7f27_ce8a_4829_a04c_aaa8182adab9 3 | 4 | // Added for caffeine: 5 | #define ONLY_MSPACES 1 6 | #if CAFI_ASSERT_ENABLED 7 | #define DEBUG 1 8 | #else 9 | #undef DEBUG 10 | #endif 11 | 12 | /* 13 | * Added for caffeine. This block of defines name shifts dlmalloc functions to have 14 | * a cafi_ prefix. Since dlmalloc is a commonly used library, name clashes can 15 | * occur when two libraries that use dlmalloc are linked to the same application 16 | * causing linker errors as they both define the dlmalloc symbols. 17 | */ 18 | #define create_mspace cafi_create_mspace 19 | #define create_mspace_with_base cafi_create_mspace_with_base 20 | #define destroy_mspace cafi_destroy_mspace 21 | #define mspace_bulk_free cafi_mspace_bulk_free 22 | #define mspace_calloc cafi_mspace_calloc 23 | #define mspace_footprint cafi_mspace_footprint 24 | #define mspace_footprint_limit cafi_mspace_footprint_limit 25 | #define mspace_free cafi_mspace_free 26 | #define mspace_independent_calloc cafi_mspace_independent_calloc 27 | #define mspace_independent_comalloc cafi_mspace_independent_comalloc 28 | #define mspace_mallinfo cafi_mspace_mallinfo 29 | #define mspace_malloc cafi_mspace_malloc 30 | #define mspace_malloc_stats cafi_mspace_malloc_stats 31 | #define mspace_mallopt cafi_mspace_mallopt 32 | #define mspace_max_footprint cafi_mspace_max_footprint 33 | #define mspace_memalign cafi_mspace_memalign 34 | #define mspace_realloc cafi_mspace_realloc 35 | #define mspace_realloc_in_place cafi_mspace_realloc_in_place 36 | #define mspace_set_footprint_limit cafi_mspace_set_footprint_limit 37 | #define mspace_track_large_chunks cafi_mspace_track_large_chunks 38 | #define mspace_trim cafi_mspace_trim 39 | #define mspace_usable_size cafi_mspace_usable_size 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /test/a00_caffeinate_test.F90: -------------------------------------------------------------------------------- 1 | module a00_caffeinate_test 2 | use prif, only : prif_init, PRIF_STAT_ALREADY_INIT 3 | use veggies, only: test_item_t, describe, result_t, it, assert_that 4 | 5 | implicit none 6 | private 7 | public :: test_caffeinate, check_caffeination 8 | 9 | contains 10 | 11 | function test_caffeinate() result(tests) 12 | type(test_item_t) :: tests 13 | 14 | tests = describe( & 15 | "A caffeinated beverage", & 16 | [ it("is served: the prif_init() function completes successfully.", check_caffeination) & 17 | , it("a subsequent prif_init call returns PRIF_STAT_ALREADY_INIT", & 18 | check_subsequent_prif_init_call) & 19 | ]) 20 | end function 21 | 22 | function check_caffeination() result(result_) 23 | ! this test needs to run very early at startup, so we memoize the result 24 | type(result_t) :: result_ 25 | type(result_t), save :: myresult 26 | logical, save :: once = .false. 27 | 28 | if (once) then 29 | result_ = myresult 30 | return 31 | endif 32 | once = .true. 33 | 34 | block 35 | integer, parameter :: successful_initiation = 0 36 | integer :: init_exit_code 37 | 38 | call prif_init(init_exit_code) 39 | myresult = assert_that(init_exit_code == successful_initiation) 40 | result_ = myresult 41 | end block 42 | end function 43 | 44 | function check_subsequent_prif_init_call() result(result_) 45 | type(result_t) :: result_ 46 | 47 | integer :: stat 48 | 49 | call prif_init(stat) 50 | call prif_init(stat) 51 | result_ = assert_that(stat == PRIF_STAT_ALREADY_INIT) 52 | end function 53 | 54 | end module a00_caffeinate_test 55 | -------------------------------------------------------------------------------- /test/main.F90: -------------------------------------------------------------------------------- 1 | ! This file was originally generated by cart, but then manually edited. 2 | ! DO NOT REGENERATE THIS FILE! 3 | program main 4 | use iso_c_binding, only : c_bool 5 | use iso_fortran_env, only : OUTPUT_UNIT, ERROR_UNIT 6 | use prif, only : & 7 | prif_stop & 8 | ,prif_error_stop 9 | implicit none 10 | 11 | logical(kind=c_bool), parameter :: false = .false._c_bool 12 | 13 | if (.not.run()) call prif_error_stop(quiet=false, stop_code_char = "Unit tests failed to run") 14 | 15 | call prif_stop(quiet=false) 16 | 17 | contains 18 | function run() result(passed) 19 | use a00_caffeinate_test, only: & 20 | check_caffeination, & 21 | a00_caffeinate_caffeinate => & 22 | test_caffeinate 23 | use caf_allocate_test, only: & 24 | caf_allocate_prif_allocate => & 25 | test_prif_allocate 26 | use caf_co_broadcast_test, only: & 27 | caf_co_broadcast_prif_co_broadcast => & 28 | test_prif_co_broadcast 29 | use caf_co_max_test, only: & 30 | caf_co_max_prif_co_max => & 31 | test_prif_co_max 32 | use caf_co_min_test, only: & 33 | caf_co_min_prif_co_min => & 34 | test_prif_co_min 35 | use caf_co_reduce_test, only: & 36 | caf_co_reduce_prif_co_reduce => & 37 | test_prif_co_reduce 38 | use caf_co_sum_test, only: & 39 | caf_co_sum_prif_co_sum => & 40 | test_prif_co_sum 41 | use caf_coarray_inquiry_test, only: & 42 | caf_coarray_inquiry_coarray_inquiry => & 43 | test_coarray_inquiry 44 | use caf_image_index_test, only: & 45 | caf_image_index_prif_image_index => & 46 | test_prif_image_index 47 | use caf_num_images_test, only: & 48 | caf_num_images_prif_num_images => & 49 | test_prif_num_images 50 | use caf_image_queries_test, only: test_prif_image_queries 51 | use caf_sync_images_test, only: test_prif_sync_images 52 | use caf_rma_test, only: & 53 | caf_rma_prif_rma => & 54 | test_prif_rma 55 | use caf_strided_test, only: & 56 | test_prif_rma_strided 57 | use caf_event_test, only: & 58 | test_prif_event 59 | use caf_teams_test, only: & 60 | caf_teams_caf_teams => & 61 | test_caf_teams 62 | use caf_this_image_test, only: & 63 | caf_this_image_prif_this_image_no_coarray => & 64 | test_prif_this_image_no_coarray 65 | use caf_stop_test, only: test_prif_stop 66 | use caf_error_stop_test, only: test_prif_error_stop 67 | use veggies, only: test_item_t, test_that, run_tests, result_t 68 | 69 | 70 | 71 | logical :: passed 72 | 73 | type(test_item_t) :: tests 74 | type(test_item_t), allocatable :: individual_tests(:) 75 | type(result_t) :: dummy 76 | 77 | ! ensure an early call to prif_init 78 | dummy = check_caffeination() 79 | 80 | allocate(individual_tests(0)) 81 | 82 | #if __flang__ && 0 /* currently no disabled tests */ 83 | block 84 | integer :: major, minor 85 | # if defined(__flang_major__) && defined(__flang_minor__) 86 | major = __flang_major__ 87 | minor = __flang_minor__ 88 | # else 89 | major = -1 90 | minor = -1 91 | # endif 92 | print *, "-----------------------------------------------------------------" 93 | print *, "WARNING: flang-new compiler detected, version:",major,".",minor 94 | print *, "WARNING: Skipping tests that are known to fail with this compiler" 95 | print *, "-----------------------------------------------------------------" 96 | call flush(OUTPUT_UNIT) 97 | end block 98 | #endif 99 | individual_tests = [a00_caffeinate_caffeinate()] 100 | individual_tests = [individual_tests, caf_allocate_prif_allocate()] 101 | individual_tests = [individual_tests, caf_coarray_inquiry_coarray_inquiry()] 102 | individual_tests = [individual_tests, caf_co_broadcast_prif_co_broadcast()] 103 | individual_tests = [individual_tests, caf_co_max_prif_co_max()] 104 | individual_tests = [individual_tests, caf_co_min_prif_co_min()] 105 | individual_tests = [individual_tests, caf_co_reduce_prif_co_reduce()] 106 | individual_tests = [individual_tests, caf_co_sum_prif_co_sum()] 107 | individual_tests = [individual_tests, caf_image_index_prif_image_index()] 108 | individual_tests = [individual_tests, caf_num_images_prif_num_images()] 109 | individual_tests = [individual_tests, test_prif_image_queries()] 110 | individual_tests = [individual_tests, caf_rma_prif_rma()] 111 | individual_tests = [individual_tests, test_prif_rma_strided()] 112 | individual_tests = [individual_tests, caf_teams_caf_teams()] 113 | individual_tests = [individual_tests, caf_this_image_prif_this_image_no_coarray()] 114 | individual_tests = [individual_tests, test_prif_event()] 115 | individual_tests = [individual_tests, test_prif_sync_images()] 116 | individual_tests = [individual_tests, test_prif_stop()] 117 | individual_tests = [individual_tests, test_prif_error_stop()] 118 | 119 | tests = test_that(individual_tests) 120 | 121 | call flush(OUTPUT_UNIT) 122 | call flush(ERROR_UNIT) 123 | 124 | passed = run_tests(tests) 125 | 126 | end function 127 | end program 128 | -------------------------------------------------------------------------------- /test/prif_allocate_test.F90: -------------------------------------------------------------------------------- 1 | module caf_allocate_test 2 | use prif, only : & 3 | prif_allocate_coarray, prif_deallocate_coarray, & 4 | prif_allocate, prif_deallocate, & 5 | prif_coarray_handle, prif_num_images, prif_size_bytes, & 6 | prif_set_context_data, prif_get_context_data, prif_local_data_pointer, & 7 | prif_alias_create, prif_alias_destroy 8 | use veggies, only: result_t, test_item_t, assert_that, assert_equals, describe, it, succeed 9 | use iso_c_binding, only: & 10 | c_ptr, c_int, c_int64_t, c_size_t, c_funptr, c_null_funptr, & 11 | c_f_pointer, c_null_ptr, c_loc, c_sizeof, c_associated 12 | 13 | implicit none 14 | private 15 | public :: test_prif_allocate 16 | 17 | contains 18 | function test_prif_allocate() result(tests) 19 | type(test_item_t) :: tests 20 | 21 | tests = & 22 | describe( & 23 | "PRIF allocation can", & 24 | [ it("allocate, use and deallocate an integer scalar coarray with a corank of 1", & 25 | check_allocate_integer_scalar_coarray_with_corank1) & 26 | , it("allocate, use and deallocate an integer array coarray with a corank of 2", & 27 | check_allocate_integer_array_coarray_with_corank2) & 28 | , it("allocate, use and deallocate memory non-symmetrically", & 29 | check_allocate_non_symmetric) & 30 | ]) 31 | end function 32 | 33 | function check_allocate_integer_scalar_coarray_with_corank1() result(result_) 34 | type(result_t) :: result_ 35 | 36 | ! Allocate memory for an integer scalar single corank coarray, such as the following decl 37 | ! integer :: coarr[*] 38 | 39 | integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds 40 | integer :: dummy_element, num_imgs 41 | type(prif_coarray_handle) :: coarray_handle 42 | type(c_ptr) :: allocated_memory 43 | integer, pointer :: local_slice 44 | integer(c_size_t) :: data_size, query_size 45 | 46 | call prif_num_images(num_images=num_imgs) 47 | lcobounds(1) = 1 48 | ucobounds(1) = num_imgs 49 | 50 | allocated_memory = c_null_ptr 51 | local_slice => null() 52 | result_ = assert_that(.not.associated(local_slice)) 53 | 54 | data_size = storage_size(dummy_element)/8 55 | call prif_allocate_coarray( & 56 | lcobounds, ucobounds, data_size, c_null_funptr, & 57 | coarray_handle, allocated_memory) 58 | 59 | call c_f_pointer(allocated_memory, local_slice) 60 | result_ = result_ .and. assert_that(associated(local_slice)) 61 | 62 | local_slice = 42 63 | result_ = result_ .and. assert_equals(42, local_slice) 64 | 65 | call prif_size_bytes(coarray_handle, data_size=query_size) 66 | result_ = result_ .and. assert_that(query_size == data_size, "prif_size_bytes is valid") 67 | 68 | block ! Check prif_{set,get}_context_data 69 | integer, target :: dummy(10), i 70 | type(c_ptr) :: expect, actual 71 | do i = 1,10 72 | expect = c_loc(dummy(i)) 73 | actual = c_null_ptr 74 | call prif_set_context_data(coarray_handle, expect) 75 | call prif_get_context_data(coarray_handle, actual) 76 | result_ = result_ .and. & 77 | assert_that(c_associated(expect, actual), "prif_{set,get}_context_data are working") 78 | end do 79 | end block 80 | 81 | call prif_deallocate_coarray([coarray_handle]) 82 | 83 | end function 84 | 85 | function check_allocate_non_symmetric() result(result_) 86 | type(result_t) :: result_ 87 | 88 | type(c_ptr) :: allocated_memory 89 | integer(c_int), pointer :: local_slice 90 | 91 | call prif_allocate(sizeof(local_slice), allocated_memory) 92 | call c_f_pointer(allocated_memory, local_slice) 93 | 94 | local_slice = 42 95 | result_ = assert_equals(42, local_slice) 96 | 97 | call prif_deallocate(c_loc(local_slice)) 98 | end function 99 | 100 | function assert_aliased(h1, h2) result(result_) 101 | type(result_t) :: result_ 102 | type(prif_coarray_handle) :: h1, h2 103 | type(c_ptr) :: p1, p2 104 | integer(c_size_t) :: s1, s2 105 | type(c_ptr) :: c1, c2, cx 106 | integer, save, target :: dummy(10) 107 | integer, save :: di = 1 108 | 109 | result_ = succeed("") 110 | 111 | call prif_local_data_pointer(h1, p1) 112 | call prif_local_data_pointer(h2, p2) 113 | result_ = result_ .and. & 114 | assert_that(c_associated(p1, p2)) 115 | 116 | call prif_size_bytes(h1, s1) 117 | call prif_size_bytes(h2, s2) 118 | result_ = result_ .and. & 119 | assert_equals(int(s1), int(s2)) 120 | 121 | cx = c_loc(dummy(di)) 122 | di = mod(di,size(dummy)) + 1 123 | 124 | call prif_set_context_data(h1, cx) 125 | call prif_get_context_data(h1, c1) 126 | result_ = result_ .and. & 127 | assert_that(c_associated(c1, cx)) 128 | 129 | call prif_get_context_data(h2, c2) 130 | result_ = result_ .and. & 131 | assert_that(c_associated(c2, cx)) 132 | 133 | call prif_set_context_data(h2, c_null_ptr) 134 | call prif_get_context_data(h1, c1) 135 | result_ = result_ .and. & 136 | assert_that(.not. c_associated(c1)) 137 | 138 | end function 139 | 140 | function check_allocate_integer_array_coarray_with_corank2() result(result_) 141 | type(result_t) :: result_ 142 | 143 | ! Allocate memory for an integer scalar single corank coarray, such as the following decl 144 | ! integer :: coarr(10)[4,*] 145 | 146 | integer(kind=c_int64_t), dimension(2) :: lcobounds, ucobounds 147 | integer :: dummy_element, num_imgs, i 148 | type(prif_coarray_handle) :: coarray_handle 149 | type(c_ptr) :: allocated_memory 150 | integer, pointer :: local_slice(:) 151 | integer(c_size_t) :: data_size, query_size 152 | 153 | call prif_num_images(num_images=num_imgs) 154 | lcobounds(1) = 1 155 | ucobounds(1) = 4 156 | lcobounds(2) = 1 157 | ucobounds(2) = num_imgs 158 | 159 | allocated_memory = c_null_ptr 160 | local_slice => null() 161 | result_ = assert_that(.not.associated(local_slice)) 162 | 163 | data_size = 10*storage_size(dummy_element)/8 164 | call prif_allocate_coarray( & 165 | lcobounds, ucobounds, data_size, c_null_funptr, & 166 | coarray_handle, allocated_memory) 167 | 168 | call prif_size_bytes(coarray_handle, data_size=query_size) 169 | result_ = result_ .and. assert_that(query_size == data_size, "prif_size_bytes is valid") 170 | 171 | call c_f_pointer(allocated_memory, local_slice, [10]) 172 | result_ = result_ .and. assert_that(associated(local_slice)) 173 | 174 | local_slice = [(i*i, i = 1, 10)] 175 | do i = 1,10 176 | result_ = result_ .and. assert_equals(i*i, local_slice(i)) 177 | end do 178 | 179 | block ! Check prif_{set,get}_context_data 180 | integer, target :: dummy(10), i 181 | type(c_ptr) :: expect, actual 182 | do i = 1,10 183 | expect = c_loc(dummy(i)) 184 | actual = c_null_ptr 185 | call prif_set_context_data(coarray_handle, expect) 186 | call prif_get_context_data(coarray_handle, actual) 187 | result_ = result_ .and. & 188 | assert_that(c_associated(expect, actual), "prif_{set,get}_context_data are working") 189 | end do 190 | end block 191 | 192 | block ! check aliasing creation 193 | integer i, j 194 | integer, parameter :: lim = 10 195 | type(prif_coarray_handle) :: a(lim) 196 | integer(c_int64_t) :: lco(1), uco(1) 197 | a(1) = coarray_handle 198 | do i=2, lim 199 | lco(1) = i 200 | uco(1) = i + num_imgs 201 | call prif_alias_create(a(i-1), lco, uco, a(i)) 202 | result_ = result_ .and. & 203 | assert_aliased(a(i-1), a(i)) 204 | do j = i+1,lim 205 | lco(1) = j 206 | uco(1) = j + num_imgs 207 | call prif_alias_create(a(i), lco, uco, a(j)) 208 | result_ = result_ .and. & 209 | assert_aliased(a(i), a(j)) 210 | result_ = result_ .and. & 211 | assert_aliased(a(j), coarray_handle) 212 | end do 213 | do j = i+1,lim 214 | call prif_alias_destroy(a(j)) 215 | end do 216 | end do 217 | do i=2, lim 218 | call prif_alias_destroy(a(i)) 219 | end do 220 | end block 221 | 222 | call prif_deallocate_coarray([coarray_handle]) 223 | 224 | end function 225 | end module caf_allocate_test 226 | -------------------------------------------------------------------------------- /test/prif_co_broadcast_test.F90: -------------------------------------------------------------------------------- 1 | module caf_co_broadcast_test 2 | use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray 3 | use veggies, only : result_t, test_item_t, describe, it, assert_equals, assert_that 4 | 5 | implicit none 6 | private 7 | public :: test_prif_co_broadcast 8 | 9 | type object_t 10 | integer i 11 | logical fallacy 12 | character(len=len("fooey")) actor 13 | complex issues 14 | end type 15 | 16 | interface operator(==) 17 | module procedure equals 18 | end interface 19 | 20 | contains 21 | 22 | function test_prif_co_broadcast() result(tests) 23 | type(test_item_t) tests 24 | 25 | tests = describe( & 26 | "The prif_co_broadcast subroutine", & 27 | [ it("broadcasts a default integer scalar with no optional arguments present", broadcast_default_integer_scalar) & 28 | ,it("broadcasts a derived type scalar with no allocatable components", broadcast_derived_type) & 29 | ]) 30 | end function 31 | 32 | logical pure function equals(lhs, rhs) 33 | type(object_t), intent(in) :: lhs, rhs 34 | equals = all([ & 35 | lhs%i == rhs%i & 36 | ,lhs%fallacy .eqv. rhs%fallacy & 37 | ,lhs%actor == rhs%actor & 38 | ,lhs%issues == rhs%issues & 39 | ]) 40 | end function 41 | 42 | function broadcast_default_integer_scalar() result(result_) 43 | type(result_t) result_ 44 | integer iPhone, me 45 | integer, parameter :: source_value = 7779311, junk = -99 46 | 47 | call prif_this_image_no_coarray(this_image=me) 48 | iPhone = merge(source_value, junk, me==1) 49 | call prif_co_broadcast(iPhone, source_image=1) 50 | result_ = assert_equals(source_value, iPhone) 51 | end function 52 | 53 | function broadcast_derived_type() result(result_) 54 | type(result_t) result_ 55 | type(object_t) object 56 | integer :: me, ni 57 | 58 | call prif_this_image_no_coarray(this_image=me) 59 | call prif_num_images(num_images=ni) 60 | object = object_t(me, .false., "gooey", me*(1.,0.)) 61 | call prif_co_broadcast(object, source_image=ni) 62 | associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) 63 | result_ = assert_that(expected_object == object, "co_broadcast derived type") 64 | end associate 65 | 66 | end function 67 | 68 | end module caf_co_broadcast_test 69 | -------------------------------------------------------------------------------- /test/prif_co_max_test.F90: -------------------------------------------------------------------------------- 1 | module caf_co_max_test 2 | use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double 3 | use prif, only : prif_co_max, prif_co_max_character, prif_this_image_no_coarray, prif_num_images 4 | use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed 5 | 6 | implicit none 7 | private 8 | public :: test_prif_co_max 9 | 10 | contains 11 | function test_prif_co_max() result(tests) 12 | type(test_item_t) tests 13 | 14 | tests = describe( & 15 | "The prif_co_max subroutine computes the maximum value across images for corresponding elements for", & 16 | [ it("a 1D default integer array", check_default_integer) & 17 | , it("a 1D 8-bit integer array", check_8_bit_integer) & 18 | , it("a 1D 16-bit integer array", check_16_bit_integer) & 19 | , it("32-bit integer scalars", check_32_bit_integer) & 20 | , it("a 1D 64-bit integer array", check_64_bit_integer) & 21 | , it("a 2D 32-bit real array", check_32_bit_real) & 22 | , it("a 1D 64-bit real array", check_64_bit_real) & 23 | , it("a character scalar", check_character) & 24 | ]) 25 | end function 26 | 27 | function check_default_integer() result(result_) 28 | type(result_t) :: result_ 29 | 30 | integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 31 | integer :: me, ni, i 32 | integer, dimension(size(values,1)) :: my_val, expected 33 | 34 | call prif_this_image_no_coarray(this_image=me) 35 | call prif_num_images(ni) 36 | 37 | my_val = values(:, mod(me-1, size(values,2))+1) 38 | call prif_co_max(my_val) 39 | 40 | expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 41 | result_ = assert_equals(int(expected), int(my_val)) 42 | end function 43 | 44 | function check_8_bit_integer() result(result_) 45 | type(result_t) :: result_ 46 | 47 | integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) 48 | integer :: me, ni, i 49 | integer(c_int8_t), dimension(size(values,1)) :: my_val, expected 50 | 51 | call prif_this_image_no_coarray(this_image=me) 52 | call prif_num_images(ni) 53 | 54 | my_val = values(:, mod(me-1, size(values,2))+1) 55 | call prif_co_max(my_val) 56 | 57 | expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 58 | result_ = assert_equals(int(expected), int(my_val)) 59 | end function 60 | 61 | function check_16_bit_integer() result(result_) 62 | type(result_t) :: result_ 63 | 64 | integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) 65 | integer :: me, ni, i 66 | integer(c_int16_t), dimension(size(values,1)) :: my_val, expected 67 | 68 | call prif_this_image_no_coarray(this_image=me) 69 | call prif_num_images(ni) 70 | 71 | my_val = values(:, mod(me-1, size(values,2))+1) 72 | call prif_co_max(my_val) 73 | 74 | expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 75 | result_ = assert_equals(int(expected), int(my_val)) 76 | end function 77 | 78 | function check_32_bit_integer() result(result_) 79 | type(result_t) :: result_ 80 | 81 | integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] 82 | integer :: me, ni, i 83 | integer(c_int32_t) :: my_val, expected 84 | 85 | call prif_this_image_no_coarray(this_image=me) 86 | call prif_num_images(ni) 87 | 88 | my_val = values(mod(me-1, size(values))+1) 89 | call prif_co_max(my_val) 90 | 91 | expected = maxval([(values(mod(i-1,size(values))+1), i = 1, ni)]) 92 | result_ = assert_equals(expected, my_val) 93 | end function 94 | 95 | function check_64_bit_integer() result(result_) 96 | type(result_t) :: result_ 97 | 98 | integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 99 | integer :: me, ni, i 100 | integer(c_int64_t), dimension(size(values,1)) :: my_val, expected 101 | 102 | call prif_this_image_no_coarray(this_image=me) 103 | call prif_num_images(ni) 104 | 105 | my_val = values(:, mod(me-1, size(values,2))+1) 106 | call prif_co_max(my_val) 107 | 108 | expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 109 | result_ = assert_equals(int(expected), int(my_val)) 110 | end function 111 | 112 | function check_32_bit_real() result(result_) 113 | type(result_t) :: result_ 114 | 115 | real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) 116 | integer :: me, ni, i 117 | real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected 118 | 119 | call prif_this_image_no_coarray(this_image=me) 120 | call prif_num_images(ni) 121 | 122 | my_val = values(:, :, mod(me-1, size(values,3))+1) 123 | call prif_co_max(my_val) 124 | 125 | expected = maxval(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) 126 | result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) 127 | end function 128 | 129 | function check_64_bit_real() result(result_) 130 | type(result_t) :: result_ 131 | 132 | real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) 133 | integer :: me, ni, i 134 | real(c_double), dimension(size(values,1)) :: my_val, expected 135 | 136 | call prif_this_image_no_coarray(this_image=me) 137 | call prif_num_images(ni) 138 | 139 | my_val = values(:, mod(me-1, size(values,2))+1) 140 | call prif_co_max(my_val) 141 | 142 | expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 143 | result_ = assert_equals(expected, my_val) 144 | end function 145 | 146 | function check_character() result(result_) 147 | type(result_t) result_ 148 | character(len=*), parameter :: values(*) = & 149 | [ "To be ","or not " & 150 | , "to ","be. " & 151 | , "that ","is " & 152 | , "the ","question"] 153 | integer :: me, ni, i 154 | character(len=len(values)) :: my_val, expected 155 | 156 | call prif_this_image_no_coarray(this_image=me) 157 | call prif_num_images(ni) 158 | 159 | my_val = values(mod(me-1, size(values))+1) 160 | call prif_co_max_character(my_val) 161 | 162 | ! issue #205: workaround flang optimizer bug with a temp 163 | associate(tmp => [(values(mod(i-1,size(values))+1), i = 1, ni)]) 164 | expected = maxval(tmp) 165 | end associate 166 | result_ = assert_equals(expected, my_val) 167 | end function 168 | 169 | end module caf_co_max_test 170 | -------------------------------------------------------------------------------- /test/prif_co_min_test.F90: -------------------------------------------------------------------------------- 1 | module caf_co_min_test 2 | use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double 3 | use prif, only : prif_co_min, prif_co_min_character, prif_this_image_no_coarray, prif_num_images 4 | use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed 5 | 6 | implicit none 7 | private 8 | public :: test_prif_co_min 9 | 10 | contains 11 | function test_prif_co_min() result(tests) 12 | type(test_item_t) tests 13 | 14 | tests = describe( & 15 | "The prif_co_min subroutine computes the minimum value across images for corresponding elements for", & 16 | [ it("a 1D default integer array", check_default_integer) & 17 | , it("a 1D 8-bit integer array", check_8_bit_integer) & 18 | , it("a 1D 16-bit integer array", check_16_bit_integer) & 19 | , it("32-bit integer scalars", check_32_bit_integer) & 20 | , it("a 1D 64-bit integer array", check_64_bit_integer) & 21 | , it("a 2D 32-bit real array", check_32_bit_real) & 22 | , it("a 1D 64-bit real array", check_64_bit_real) & 23 | , it("a character scalar", check_character) & 24 | ]) 25 | end function 26 | 27 | function check_default_integer() result(result_) 28 | type(result_t) :: result_ 29 | 30 | integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 31 | integer :: me, ni, i 32 | integer, dimension(size(values,1)) :: my_val, expected 33 | 34 | call prif_this_image_no_coarray(this_image=me) 35 | call prif_num_images(ni) 36 | 37 | my_val = values(:, mod(me-1, size(values,2))+1) 38 | call prif_co_min(my_val) 39 | 40 | expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 41 | result_ = assert_equals(int(expected), int(my_val)) 42 | end function 43 | 44 | function check_8_bit_integer() result(result_) 45 | type(result_t) :: result_ 46 | 47 | integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) 48 | integer :: me, ni, i 49 | integer(c_int8_t), dimension(size(values,1)) :: my_val, expected 50 | 51 | call prif_this_image_no_coarray(this_image=me) 52 | call prif_num_images(ni) 53 | 54 | my_val = values(:, mod(me-1, size(values,2))+1) 55 | call prif_co_min(my_val) 56 | 57 | expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 58 | result_ = assert_equals(int(expected), int(my_val)) 59 | end function 60 | 61 | function check_16_bit_integer() result(result_) 62 | type(result_t) :: result_ 63 | 64 | integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) 65 | integer :: me, ni, i 66 | integer(c_int16_t), dimension(size(values,1)) :: my_val, expected 67 | 68 | call prif_this_image_no_coarray(this_image=me) 69 | call prif_num_images(ni) 70 | 71 | my_val = values(:, mod(me-1, size(values,2))+1) 72 | call prif_co_min(my_val) 73 | 74 | expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 75 | result_ = assert_equals(int(expected), int(my_val)) 76 | end function 77 | 78 | function check_32_bit_integer() result(result_) 79 | type(result_t) :: result_ 80 | 81 | integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] 82 | integer :: me, ni, i 83 | integer(c_int32_t) :: my_val, expected 84 | 85 | call prif_this_image_no_coarray(this_image=me) 86 | call prif_num_images(ni) 87 | 88 | my_val = values(mod(me-1, size(values))+1) 89 | call prif_co_min(my_val) 90 | 91 | expected = minval([(values(mod(i-1,size(values))+1), i = 1, ni)]) 92 | result_ = assert_equals(expected, my_val) 93 | end function 94 | 95 | function check_64_bit_integer() result(result_) 96 | type(result_t) :: result_ 97 | 98 | integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 99 | integer :: me, ni, i 100 | integer(c_int64_t), dimension(size(values,1)) :: my_val, expected 101 | 102 | call prif_this_image_no_coarray(this_image=me) 103 | call prif_num_images(ni) 104 | 105 | my_val = values(:, mod(me-1, size(values,2))+1) 106 | call prif_co_min(my_val) 107 | 108 | expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 109 | result_ = assert_equals(int(expected), int(my_val)) 110 | end function 111 | 112 | function check_32_bit_real() result(result_) 113 | type(result_t) :: result_ 114 | 115 | real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) 116 | integer :: me, ni, i 117 | real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected 118 | 119 | call prif_this_image_no_coarray(this_image=me) 120 | call prif_num_images(ni) 121 | 122 | my_val = values(:, :, mod(me-1, size(values,3))+1) 123 | call prif_co_min(my_val) 124 | 125 | expected = minval(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) 126 | result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) 127 | end function 128 | 129 | function check_64_bit_real() result(result_) 130 | type(result_t) :: result_ 131 | 132 | real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) 133 | integer :: me, ni, i 134 | real(c_double), dimension(size(values,1)) :: my_val, expected 135 | 136 | call prif_this_image_no_coarray(this_image=me) 137 | call prif_num_images(ni) 138 | 139 | my_val = values(:, mod(me-1, size(values,2))+1) 140 | call prif_co_min(my_val) 141 | 142 | expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 143 | result_ = assert_equals(expected, my_val) 144 | end function 145 | 146 | function check_character() result(result_) 147 | type(result_t) result_ 148 | character(len=*), parameter :: values(*) = & 149 | [ "To be ","or not " & 150 | , "to ","be. " & 151 | , "that ","is " & 152 | , "the ","question"] 153 | integer :: me, ni, i 154 | character(len=len(values)) :: my_val, expected 155 | 156 | call prif_this_image_no_coarray(this_image=me) 157 | call prif_num_images(ni) 158 | 159 | my_val = values(mod(me-1, size(values))+1) 160 | call prif_co_min_character(my_val) 161 | 162 | ! issue #205: workaround flang optimizer bug with a temp 163 | associate(tmp => [(values(mod(i-1,size(values))+1), i = 1, ni)]) 164 | expected = minval(tmp) 165 | end associate 166 | result_ = assert_equals(expected, my_val) 167 | end function 168 | 169 | end module caf_co_min_test 170 | -------------------------------------------------------------------------------- /test/prif_co_reduce_test.F90: -------------------------------------------------------------------------------- 1 | module caf_co_reduce_test 2 | use iso_c_binding, only: c_ptr, c_funptr, c_size_t, c_f_pointer, c_f_procpointer, c_funloc, c_loc, c_null_ptr 3 | use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_operation_wrapper_interface 4 | use veggies, only : result_t, test_item_t, assert_equals, assert_not, assert_that, describe, it, succeed 5 | 6 | implicit none 7 | private 8 | public :: test_prif_co_reduce 9 | 10 | type :: pair 11 | integer :: fst 12 | real :: snd 13 | end type 14 | 15 | #if HAVE_PARAM_DERIVED 16 | type :: array(length) 17 | integer, len :: length = 2 18 | integer :: elements(length) 19 | end type 20 | 21 | type :: reduction_context_data 22 | type(c_funptr) :: user_op 23 | integer :: length 24 | end type 25 | #endif 26 | 27 | contains 28 | 29 | function test_prif_co_reduce() result(tests) 30 | type(test_item_t) tests 31 | 32 | tests = describe( & 33 | "The prif_co_reduce subroutine", & 34 | [ it("can be used to implement logical and reduction", check_logical) & 35 | , it("can be used for reduction on simple derived types", check_derived_type_reduction) & 36 | #if HAVE_PARAM_DERIVED 37 | , it("can be used for reduction on derived types with length type parameters", check_type_parameter_reduction) & 38 | #endif 39 | ]) 40 | end function 41 | 42 | function check_logical() result(result_) 43 | type(result_t) :: result_ 44 | logical :: val 45 | integer :: me 46 | procedure(prif_operation_wrapper_interface), pointer :: op 47 | op => and_wrapper 48 | 49 | val = .true. 50 | call prif_co_reduce(val, op, c_null_ptr) 51 | result_ = assert_that(val) 52 | 53 | call prif_this_image_no_coarray(this_image=me) 54 | if (me == 1) then 55 | val = .false. 56 | end if 57 | call prif_co_reduce(val, op, c_null_ptr) 58 | result_ = result_.and.assert_not(val) 59 | end function 60 | 61 | subroutine and_wrapper(arg1, arg2_and_out, count, cdata) bind(C) 62 | type(c_ptr), intent(in), value :: arg1, arg2_and_out 63 | integer(c_size_t), intent(in), value :: count 64 | type(c_ptr), intent(in), value :: cdata 65 | 66 | logical, pointer :: lhs(:), rhs_and_result(:) 67 | integer(c_size_t) :: i 68 | 69 | if (count == 0) return 70 | call c_f_pointer(arg1, lhs, [count]) 71 | call c_f_pointer(arg2_and_out, rhs_and_result, [count]) 72 | do i = 1, count 73 | rhs_and_result(i) = lhs(i).and.rhs_and_result(i) 74 | end do 75 | end subroutine 76 | 77 | function check_derived_type_reduction() result(result_) 78 | type(result_t) :: result_ 79 | type(pair), parameter :: values(*,*) = reshape( & 80 | [ pair(1, 53.), pair(3, 47.) & 81 | , pair(5, 43.), pair(7, 41.) & 82 | , pair(11, 37.), pair(13, 31.) & 83 | , pair(17, 29.), pair(19, 23.) & 84 | ], & 85 | [2, 4]) 86 | integer :: me, ni, i 87 | type(pair), dimension(size(values,1)) :: my_val, expected 88 | type(pair), dimension(:,:), allocatable :: tmp 89 | procedure(prif_operation_wrapper_interface), pointer :: op 90 | 91 | op => pair_adder 92 | call prif_this_image_no_coarray(this_image=me) 93 | call prif_num_images(ni) 94 | 95 | my_val = values(:, mod(me-1, size(values,2))+1) 96 | call prif_co_reduce(my_val, op, c_null_ptr) 97 | 98 | allocate(tmp(size(values,1),ni)) 99 | tmp = reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]) 100 | #if defined(__GFORTRAN__) 101 | ! gfortran 14 lacks the F18 intrinsic REDUCE() 102 | block 103 | integer :: j 104 | do i = 1, size(tmp,1) 105 | expected(i) = tmp(i,1) 106 | do j = 2, size(tmp,2) 107 | expected(i) = add_pair(expected(i), tmp(i,j)) 108 | end do 109 | end do 110 | end block 111 | #else 112 | expected = reduce(tmp, add_pair, dim=2) 113 | #endif 114 | result_ = & 115 | assert_equals(expected%fst, my_val%fst) & 116 | .and. assert_equals(real(expected%snd, kind=kind(0.d0)), real(my_val%snd, kind=kind(0.d0))) 117 | end function 118 | 119 | pure function add_pair(lhs, rhs) result(total) 120 | type(pair), intent(in) :: lhs, rhs 121 | type(pair) :: total 122 | 123 | total%fst = lhs%fst + rhs%fst 124 | total%snd = lhs%snd + rhs%snd 125 | end function 126 | 127 | subroutine pair_adder(arg1, arg2_and_out, count, cdata) bind(C) 128 | type(c_ptr), intent(in), value :: arg1, arg2_and_out 129 | integer(c_size_t), intent(in), value :: count 130 | type(c_ptr), intent(in), value :: cdata 131 | 132 | type(pair), pointer :: lhs(:), rhs_and_result(:) 133 | integer(c_size_t) :: i 134 | 135 | if (count == 0) return 136 | call c_f_pointer(arg1, lhs, [count]) 137 | call c_f_pointer(arg2_and_out, rhs_and_result, [count]) 138 | do i = 1, count 139 | rhs_and_result(i) = add_pair(lhs(i), rhs_and_result(i)) 140 | end do 141 | end subroutine 142 | 143 | #if HAVE_PARAM_DERIVED 144 | ! As of LLVM20, flang does not implement the types used by this test: 145 | ! flang/lib/Lower/ConvertType.cpp:482: not yet implemented: parameterized derived types 146 | ! error: Actual argument associated with TYPE(*) dummy argument 'a=' may not have a parameterized derived type 147 | 148 | ! Gfortran 14.2 also lacks the type support for this test: 149 | ! Error: Derived type 'pdtarray' at (1) is being used before it is defined 150 | 151 | function check_type_parameter_reduction() result(result_) 152 | type(result_t) :: result_ 153 | type(array), parameter :: values(*,*) = reshape( & 154 | [ array(elements=[1, 53]), array(elements=[3, 47]) & 155 | , array(elements=[5, 43]), array(elements=[7, 41]) & 156 | , array(elements=[11, 37]), array(elements=[13, 31]) & 157 | , array(elements=[17, 29]), array(elements=[19, 23]) & 158 | ], & 159 | [2, 4]) 160 | integer :: me, ni, i 161 | type(array(values%length)), dimension(size(values,1)) :: my_val, expected 162 | procedure(prif_operation_wrapper_interface), pointer :: op 163 | type(reduction_context_data), target :: context 164 | 165 | op => array_wrapper 166 | context%user_op = c_funloc(add_array) 167 | context%length = values%length 168 | call prif_this_image_no_coarray(this_image=me) 169 | call prif_num_images(ni) 170 | 171 | my_val = values(:, mod(me-1, size(values,2))+1) 172 | call prif_co_reduce(my_val, op, c_loc(context)) 173 | 174 | expected = reduce(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), add_array, dim=2) 175 | do i = 1, size(expected) 176 | result_ = result_.and.assert_equals(expected(i)%elements, my_val(i)%elements) 177 | end do 178 | end function 179 | 180 | pure function add_array(lhs, rhs) result(total) 181 | type(array), intent(in) :: lhs, rhs 182 | type(array) :: total 183 | 184 | total%elements = lhs%elements + rhs%elements 185 | end function 186 | 187 | subroutine array_wrapper(arg1, arg2_and_out, count, cdata) bind(C) 188 | type(c_ptr), intent(in), value :: arg1, arg2_and_out 189 | integer(c_size_t), intent(in), value :: count 190 | type(c_ptr), intent(in), value :: cdata 191 | 192 | type(reduction_context_data), pointer :: context 193 | 194 | if (count == 0) return 195 | call c_f_pointer(cdata, context) 196 | block 197 | abstract interface 198 | pure function op_interface(lhs, rhs) result(res) 199 | import :: array, context 200 | implicit none 201 | type(array(context%length)), intent(in) :: lhs, rhs 202 | type(array(context%length)) :: res 203 | end function 204 | end interface 205 | procedure(op_interface), pointer :: op 206 | type(array(context%length)), pointer :: lhs(:), rhs_and_result(:) 207 | integer(c_size_t) :: i 208 | 209 | call c_f_procpointer(context%user_op, op) 210 | call c_f_pointer(arg1, lhs, [count]) 211 | call c_f_pointer(arg2_and_out, rhs_and_result, [count]) 212 | do i = 1, count 213 | rhs_and_result(i) = op(lhs(i), rhs_and_result(i)) 214 | end do 215 | end block 216 | end subroutine 217 | #endif /* HAVE_PARAM_DERIVED */ 218 | 219 | end module caf_co_reduce_test 220 | -------------------------------------------------------------------------------- /test/prif_co_sum_test.F90: -------------------------------------------------------------------------------- 1 | module caf_co_sum_test 2 | use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double 3 | use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray 4 | use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed 5 | 6 | implicit none 7 | private 8 | public :: test_prif_co_sum 9 | 10 | contains 11 | function test_prif_co_sum() result(tests) 12 | type(test_item_t) tests 13 | 14 | tests = describe( & 15 | "The prif_co_sum subroutine computes the sum across images for corresponding elements for", & 16 | [ it("a 1D default integer array", check_default_integer) & 17 | , it("a 1D 8-bit integer array", check_8_bit_integer) & 18 | , it("a 1D 16-bit integer array", check_16_bit_integer) & 19 | , it("32-bit integer scalars", check_32_bit_integer) & 20 | , it("a 1D 64-bit integer array", check_64_bit_integer) & 21 | , it("a 2D 32-bit real array", check_32_bit_real) & 22 | , it("a 1D 64-bit real array", check_64_bit_real) & 23 | , it("a 2D complex array with 32-bit components", check_32_bit_complex) & 24 | , it("a 1D complex array with 64-bit components", check_64_bit_complex) & 25 | ]) 26 | end function 27 | 28 | function check_default_integer() result(result_) 29 | type(result_t) :: result_ 30 | 31 | integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 32 | integer :: me, ni, i 33 | integer, dimension(size(values,1)) :: my_val, expected 34 | 35 | call prif_this_image_no_coarray(this_image=me) 36 | call prif_num_images(ni) 37 | 38 | my_val = values(:, mod(me-1, size(values,2))+1) 39 | call prif_co_sum(my_val) 40 | 41 | expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 42 | result_ = assert_equals(int(expected), int(my_val)) 43 | end function 44 | 45 | function check_8_bit_integer() result(result_) 46 | type(result_t) :: result_ 47 | 48 | integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) 49 | integer :: me, ni, i 50 | integer(c_int8_t), dimension(size(values,1)) :: my_val, expected 51 | 52 | call prif_this_image_no_coarray(this_image=me) 53 | call prif_num_images(ni) 54 | 55 | my_val = values(:, mod(me-1, size(values,2))+1) 56 | call prif_co_sum(my_val) 57 | 58 | expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 59 | result_ = assert_equals(int(expected), int(my_val)) 60 | end function 61 | 62 | function check_16_bit_integer() result(result_) 63 | type(result_t) :: result_ 64 | 65 | integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) 66 | integer :: me, ni, i 67 | integer(c_int16_t), dimension(size(values,1)) :: my_val, expected 68 | 69 | call prif_this_image_no_coarray(this_image=me) 70 | call prif_num_images(ni) 71 | 72 | my_val = values(:, mod(me-1, size(values,2))+1) 73 | call prif_co_sum(my_val) 74 | 75 | expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 76 | result_ = assert_equals(int(expected), int(my_val)) 77 | end function 78 | 79 | function check_32_bit_integer() result(result_) 80 | type(result_t) :: result_ 81 | 82 | integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] 83 | integer :: me, ni, i 84 | integer(c_int32_t) :: my_val, expected 85 | 86 | call prif_this_image_no_coarray(this_image=me) 87 | call prif_num_images(ni) 88 | 89 | my_val = values(mod(me-1, size(values))+1) 90 | call prif_co_sum(my_val) 91 | 92 | expected = sum([(values(mod(i-1,size(values))+1), i = 1, ni)]) 93 | result_ = assert_equals(expected, my_val) 94 | end function 95 | 96 | function check_64_bit_integer() result(result_) 97 | type(result_t) :: result_ 98 | 99 | integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) 100 | integer :: me, ni, i 101 | integer(c_int64_t), dimension(size(values,1)) :: my_val, expected 102 | 103 | call prif_this_image_no_coarray(this_image=me) 104 | call prif_num_images(ni) 105 | 106 | my_val = values(:, mod(me-1, size(values,2))+1) 107 | call prif_co_sum(my_val) 108 | 109 | expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 110 | result_ = assert_equals(int(expected), int(my_val)) 111 | end function 112 | 113 | function check_32_bit_real() result(result_) 114 | type(result_t) :: result_ 115 | 116 | real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) 117 | integer :: me, ni, i 118 | real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected 119 | 120 | call prif_this_image_no_coarray(this_image=me) 121 | call prif_num_images(ni) 122 | 123 | my_val = values(:, :, mod(me-1, size(values,3))+1) 124 | call prif_co_sum(my_val) 125 | 126 | expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) 127 | result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) 128 | end function 129 | 130 | function check_64_bit_real() result(result_) 131 | type(result_t) :: result_ 132 | 133 | real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) 134 | integer :: me, ni, i 135 | real(c_double), dimension(size(values,1)) :: my_val, expected 136 | 137 | call prif_this_image_no_coarray(this_image=me) 138 | call prif_num_images(ni) 139 | 140 | my_val = values(:, mod(me-1, size(values,2))+1) 141 | call prif_co_sum(my_val) 142 | 143 | expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) 144 | result_ = assert_equals(expected, my_val) 145 | end function 146 | 147 | function check_32_bit_complex() result(result_) 148 | type(result_t) :: result_ 149 | 150 | complex(c_float), parameter :: values(*,*,*) = reshape( & 151 | [ cmplx(1., 53.), cmplx(3., 47.) & 152 | , cmplx(5., 43.), cmplx(7., 41.) & 153 | , cmplx(11., 37.), cmplx(13., 31.) & 154 | , cmplx(17., 29.), cmplx(19., 23.) & 155 | ], & 156 | [2,2,2]) 157 | integer :: me, ni, i 158 | complex(c_float), dimension(size(values,1),size(values,2)) :: my_val, expected 159 | 160 | call prif_this_image_no_coarray(this_image=me) 161 | call prif_num_images(ni) 162 | 163 | my_val = values(:, :, mod(me-1, size(values,3))+1) 164 | call prif_co_sum(my_val) 165 | 166 | expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) 167 | result_ = & 168 | assert_equals(real(expected, kind=c_double), real(my_val, kind=c_double)) & 169 | .and.assert_equals(real(aimag(expected), kind=c_double), real(aimag(my_val), kind=c_double)) 170 | end function 171 | 172 | function check_64_bit_complex() result(result_) 173 | type(result_t) :: result_ 174 | 175 | complex(c_double), parameter :: values(*,*) = reshape( & 176 | [ cmplx(1., 53.), cmplx(3., 47.) & 177 | , cmplx(5., 43.), cmplx(7., 41.) & 178 | , cmplx(11., 37.), cmplx(13., 31.) & 179 | , cmplx(17., 29.), cmplx(19., 23.) & 180 | ], & 181 | [2,4]) 182 | integer :: me, ni, i 183 | complex(c_double), dimension(size(values,1)) :: my_val, expected 184 | 185 | call prif_this_image_no_coarray(this_image=me) 186 | call prif_num_images(ni) 187 | 188 | my_val = values(:, mod(me-1, size(values,2))+1) 189 | call prif_co_sum(my_val) 190 | 191 | expected = sum(reshape([(values(:,mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1), ni]), dim=2) 192 | result_ = & 193 | assert_equals(real(expected), real(my_val)) & 194 | .and.assert_equals(aimag(expected), aimag(my_val)) 195 | end function 196 | 197 | end module caf_co_sum_test 198 | -------------------------------------------------------------------------------- /test/prif_coarray_inquiry_test.F90: -------------------------------------------------------------------------------- 1 | module caf_coarray_inquiry_test 2 | use prif, only : & 3 | prif_allocate_coarray, prif_deallocate_coarray, & 4 | prif_coarray_handle, prif_num_images, & 5 | prif_local_data_pointer, prif_size_bytes, & 6 | prif_lcobound_no_dim, prif_lcobound_with_dim, & 7 | prif_ucobound_no_dim, prif_ucobound_with_dim, & 8 | prif_coshape 9 | use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed 10 | use iso_c_binding, only: & 11 | c_ptr, c_null_ptr, c_int64_t, c_int, c_size_t, c_null_funptr, c_associated 12 | 13 | implicit none 14 | private 15 | public :: test_coarray_inquiry 16 | contains 17 | function test_coarray_inquiry() result(tests) 18 | type(test_item_t) :: tests 19 | 20 | tests = & 21 | describe( & 22 | "PRIF coarray inquiry functions", & 23 | [ describe( & 24 | "prif_local_data_pointer", & 25 | [ it( & 26 | "returns the same pointer as when the coarray was allocated", & 27 | check_prif_local_data_pointer) & 28 | ]), & 29 | describe( & 30 | "PRIF coarrays", & 31 | [ it("pass cobounds testing", check_cobounds) ]) & 32 | ]) 33 | end function 34 | 35 | function check_prif_local_data_pointer() result(result_) 36 | type(result_t) :: result_ 37 | 38 | integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds 39 | integer :: dummy_element, num_imgs 40 | type(prif_coarray_handle) :: coarray_handle 41 | type(c_ptr) :: allocation_ptr, local_ptr 42 | 43 | call prif_num_images(num_images=num_imgs) 44 | lcobounds(1) = 1 45 | ucobounds(1) = num_imgs 46 | 47 | call prif_allocate_coarray( & 48 | lcobounds, & 49 | ucobounds, & 50 | int(storage_size(dummy_element)/8, c_size_t), & 51 | c_null_funptr, & 52 | coarray_handle, & 53 | allocation_ptr) 54 | call prif_local_data_pointer(coarray_handle, local_ptr) 55 | result_ = assert_that(c_associated(local_ptr, allocation_ptr)) 56 | call prif_deallocate_coarray([coarray_handle]) 57 | end function 58 | 59 | function check_cobound(corank) result(result_) 60 | type(result_t) :: result_ 61 | integer(c_int), intent(in) :: corank 62 | 63 | ! Allocate memory for an integer scalar coarray with given corank 64 | ! and then test some queries on it 65 | 66 | integer :: num_imgs, i 67 | integer(kind=c_int64_t), dimension(corank) :: lcobounds, ucobounds, tmp_bounds 68 | integer(kind=c_int64_t) :: tmp_bound 69 | integer(kind=c_size_t), dimension(corank) :: sizes 70 | type(prif_coarray_handle) :: coarray_handle 71 | type(c_ptr) :: allocated_memory 72 | integer(c_size_t) :: data_size, query_size 73 | 74 | result_ = succeed("") 75 | 76 | call prif_num_images(num_images=num_imgs) 77 | lcobounds(1) = 1 78 | ucobounds(1) = num_imgs 79 | do i = 2,corank 80 | lcobounds(i) = i 81 | ucobounds(i) = i*2 82 | end do 83 | 84 | allocated_memory = c_null_ptr 85 | data_size = 64 * corank 86 | 87 | call prif_allocate_coarray( & 88 | lcobounds, ucobounds, data_size, c_null_funptr, & 89 | coarray_handle, allocated_memory) 90 | 91 | result_ = result_ .and. & 92 | assert_that(c_associated(allocated_memory)) 93 | 94 | call prif_size_bytes(coarray_handle, data_size=query_size) 95 | result_ = result_ .and. & 96 | assert_that(query_size == data_size, "prif_size_bytes is valid") 97 | 98 | call prif_lcobound_no_dim(coarray_handle, tmp_bounds) 99 | result_ = result_ .and. & 100 | assert_that(all(tmp_bounds == lcobounds), "prif_lcobound_no_dim is valid") 101 | 102 | call prif_ucobound_no_dim(coarray_handle, tmp_bounds) 103 | result_ = result_ .and. & 104 | assert_that(all(tmp_bounds == ucobounds), "prif_ucobound_no_dim is valid") 105 | 106 | do i = 1,corank 107 | call prif_lcobound_with_dim(coarray_handle, i, tmp_bound) 108 | result_ = result_ .and. & 109 | assert_that(tmp_bound == lcobounds(i), "prif_lcobound_with_dim is valid") 110 | 111 | call prif_ucobound_with_dim(coarray_handle, i, tmp_bound) 112 | result_ = result_ .and. & 113 | assert_that(tmp_bound == ucobounds(i), "prif_ucobound_with_dim is valid") 114 | end do 115 | 116 | call prif_coshape(coarray_handle, sizes) 117 | result_ = result_ .and. & 118 | assert_that(all(sizes == (ucobounds - lcobounds + 1)), "prif_coshape is valid") 119 | 120 | call prif_deallocate_coarray([coarray_handle]) 121 | end function 122 | 123 | function check_cobounds() result(result_) 124 | type(result_t) :: result_ 125 | integer(c_int) :: corank 126 | 127 | result_ = succeed("") 128 | 129 | do corank = 1, 15 130 | result_ = result_ .and. check_cobound(corank) 131 | end do 132 | 133 | end function 134 | 135 | end module 136 | -------------------------------------------------------------------------------- /test/prif_error_stop_test.F90: -------------------------------------------------------------------------------- 1 | module caf_error_stop_test 2 | use prif, only: prif_this_image_no_coarray, prif_sync_all 3 | use veggies, only: test_item_t, describe, result_t, it, assert_that, assert_equals, succeed 4 | use unit_test_parameters_m, only : expected_error_stop_code, & 5 | image_one => subjob_setup, cmd_prefix => subjob_prefix 6 | 7 | implicit none 8 | private 9 | public :: test_prif_error_stop 10 | 11 | integer, parameter :: max_message_len = 128 12 | 13 | contains 14 | function test_prif_error_stop() result(tests) 15 | type(test_item_t) :: tests 16 | 17 | tests = describe( & 18 | "A program that executes the prif_error_stop function", & 19 | [ it("exits with a non-zero exitstat when the program omits the stop code", exit_with_no_stop_code) & 20 | ,it("prints a character stop code and exits with a non-zero exitstat", exit_with_character_stop_code) & 21 | ,it("prints an integer stop code and exits with exitstat equal to the stop code", exit_with_integer_stop_code) & 22 | ]) 23 | end function 24 | 25 | function exit_with_no_stop_code() result(result_) 26 | type(result_t) :: result_ 27 | integer exit_status 28 | integer command_status 29 | character(len=max_message_len) command_message 30 | 31 | if (image_one()) then 32 | command_message = "exit_with_no_stop_code" 33 | 34 | call execute_command_line( & 35 | command = cmd_prefix//"./build/run-fpm.sh run --example error_stop_with_no_code > /dev/null 2>&1" & 36 | ,wait = .true. & 37 | ,exitstat = exit_status & 38 | ,cmdstat = command_status & 39 | ,cmdmsg = command_message & 40 | ) 41 | result_ = assert_that(exit_status /= 0, command_message) 42 | else 43 | result_ = succeed("skipped") 44 | end if 45 | 46 | end function 47 | 48 | function exit_with_integer_stop_code() result(result_) 49 | type(result_t) :: result_ 50 | integer exit_status 51 | integer command_status 52 | character(len=max_message_len) command_message 53 | 54 | if (image_one()) then 55 | command_message = "exit_with_integer_stop_code" 56 | 57 | call execute_command_line( & 58 | command = cmd_prefix//"./build/run-fpm.sh run --example error_stop_with_integer_code > /dev/null 2>&1" & 59 | ,wait = .true. & 60 | ,exitstat = exit_status & 61 | ,cmdstat = command_status & 62 | ,cmdmsg = command_message & 63 | ) 64 | result_ = & 65 | assert_equals(expected_error_stop_code, exit_status, command_message) 66 | else 67 | result_ = succeed("skipped") 68 | end if 69 | 70 | end function 71 | 72 | function exit_with_character_stop_code() result(result_) 73 | type(result_t) :: result_ 74 | integer exit_status 75 | integer command_status 76 | character(len=max_message_len) command_message 77 | 78 | if (image_one()) then 79 | command_message = "exit_with_character_stop_code" 80 | 81 | call execute_command_line( & 82 | command = cmd_prefix//"./build/run-fpm.sh run --example error_stop_with_character_code > /dev/null 2>&1" & 83 | ,wait = .true. & 84 | ,exitstat = exit_status & 85 | ,cmdstat = command_status & 86 | ,cmdmsg = command_message & 87 | ) 88 | result_ = assert_that(exit_status /= 0, command_message) 89 | else 90 | result_ = succeed("skipped") 91 | end if 92 | 93 | end function 94 | 95 | end module caf_error_stop_test 96 | -------------------------------------------------------------------------------- /test/prif_image_index_test.F90: -------------------------------------------------------------------------------- 1 | module caf_image_index_test 2 | use iso_c_binding, only: c_int, c_ptr, c_size_t, c_null_funptr, c_int64_t 3 | use prif, only: prif_coarray_handle, prif_allocate_coarray, prif_deallocate_coarray, & 4 | prif_image_index, prif_num_images, & 5 | prif_team_type, prif_get_team, & 6 | prif_this_image_no_coarray, & 7 | prif_form_team, prif_change_team, prif_end_team, & 8 | prif_image_index_with_team, prif_image_index_with_team_number, & 9 | prif_this_image_with_coarray, prif_this_image_with_dim, & 10 | prif_lcobound_no_dim, prif_ucobound_no_dim, & 11 | prif_num_images_with_team 12 | use veggies, only: result_t, test_item_t, assert_equals, assert_that, describe, it, succeed 13 | 14 | implicit none 15 | private 16 | public :: test_prif_image_index 17 | contains 18 | function test_prif_image_index() result(tests) 19 | type(test_item_t) :: tests 20 | 21 | tests = describe( & 22 | "prif_image_index", & 23 | [ it("returns 1 for the simplest case", check_simple_case) & 24 | , it("returns 1 when given the lower bounds", check_lower_bounds) & 25 | , it("returns 0 with invalid subscripts", check_invalid_subscripts) & 26 | , it("returns the expected answer for a more complicated case w/corank=2", check_complicated_2d) & 27 | , it("returns the expected answer for a more complicated case w/corank=3", check_complicated_3d) & 28 | , it("returns the expected answer with a child team and corank=2", check_complicated_2d_team) & 29 | ]) 30 | end function 31 | 32 | function check_this_image_coarray(coarray_handle, corank, team) result(result_) 33 | type(prif_coarray_handle) :: coarray_handle 34 | integer(c_int) :: corank 35 | type(prif_team_type), optional :: team 36 | type(result_t) :: result_ 37 | 38 | integer(c_int64_t) :: co, cosubscripts(corank), colbound(corank), coubound(corank) 39 | integer(c_int) :: i, me 40 | 41 | result_ = succeed("") 42 | 43 | call prif_lcobound_no_dim(coarray_handle, colbound) 44 | call prif_ucobound_no_dim(coarray_handle, coubound) 45 | call prif_this_image_no_coarray(team, me) 46 | 47 | call prif_this_image_with_coarray(coarray_handle, team=team, cosubscripts=cosubscripts) 48 | do i=1,corank 49 | call prif_this_image_with_dim(coarray_handle, dim=i, team=team, cosubscript=co) 50 | result_ = result_ .and. assert_equals(int(co), int(cosubscripts(i))) 51 | 52 | result_ = result_ .and. assert_that(co >= colbound(i)) 53 | result_ = result_ .and. assert_that(co <= coubound(i)) 54 | end do 55 | 56 | ! verify reverse mapping 57 | if (present(team)) then 58 | call prif_image_index_with_team(coarray_handle, cosubscripts, team, i) 59 | else 60 | call prif_image_index(coarray_handle, cosubscripts, i) 61 | end if 62 | result_ = result_ .and. assert_equals(i, me) 63 | end function 64 | 65 | function check_simple_case() result(result_) 66 | type(result_t) :: result_ 67 | 68 | type(prif_coarray_handle) :: coarray_handle 69 | type(c_ptr) :: allocated_memory 70 | integer(c_int) :: answer, ni 71 | call prif_num_images(num_images=ni) 72 | 73 | call prif_allocate_coarray( & 74 | lcobounds = [1_c_int64_t], & 75 | ucobounds = [ni+2_c_int64_t], & 76 | size_in_bytes = 1_c_size_t, & 77 | final_func = c_null_funptr, & 78 | coarray_handle = coarray_handle, & 79 | allocated_memory = allocated_memory) 80 | call prif_image_index(coarray_handle, [1_c_int64_t], image_index=answer) 81 | result_ = assert_equals(1_c_int, answer) 82 | 83 | result_ = result_ .and. & 84 | check_this_image_coarray(coarray_handle, 1) 85 | 86 | call prif_deallocate_coarray([coarray_handle]) 87 | end function 88 | 89 | function check_lower_bounds() result(result_) 90 | type(result_t) :: result_ 91 | 92 | type(prif_coarray_handle) :: coarray_handle 93 | type(c_ptr) :: allocated_memory 94 | integer(c_int) :: answer, ni 95 | call prif_num_images(num_images=ni) 96 | 97 | call prif_allocate_coarray( & 98 | lcobounds = [2_c_int64_t, 3_c_int64_t], & 99 | ucobounds = [3_c_int64_t, ni+4_c_int64_t], & 100 | size_in_bytes = 1_c_size_t, & 101 | final_func = c_null_funptr, & 102 | coarray_handle = coarray_handle, & 103 | allocated_memory = allocated_memory) 104 | call prif_image_index(coarray_handle, [2_c_int64_t, 3_c_int64_t], image_index=answer) 105 | result_ = assert_equals(1_c_int, answer) 106 | 107 | result_ = result_ .and. & 108 | check_this_image_coarray(coarray_handle, 2) 109 | 110 | call prif_deallocate_coarray([coarray_handle]) 111 | end function 112 | 113 | function check_invalid_subscripts() result(result_) 114 | type(result_t) :: result_ 115 | 116 | type(prif_coarray_handle) :: coarray_handle 117 | type(c_ptr) :: allocated_memory 118 | integer(c_int) :: answer, ni 119 | call prif_num_images(num_images=ni) 120 | 121 | call prif_allocate_coarray( & 122 | lcobounds = [-2_c_int64_t, 2_c_int64_t], & 123 | ucobounds = [2_c_int64_t, ni+6_c_int64_t], & 124 | size_in_bytes = 1_c_size_t, & 125 | final_func = c_null_funptr, & 126 | coarray_handle = coarray_handle, & 127 | allocated_memory = allocated_memory) 128 | call prif_image_index(coarray_handle, [-1_c_int64_t, 1_c_int64_t], image_index=answer) 129 | result_ = assert_equals(0_c_int, answer) 130 | 131 | result_ = result_ .and. & 132 | check_this_image_coarray(coarray_handle, 2) 133 | 134 | call prif_deallocate_coarray([coarray_handle]) 135 | end function 136 | 137 | function check_complicated_2d() result(result_) 138 | type(result_t) :: result_ 139 | 140 | type(prif_coarray_handle) :: coarray_handle 141 | type(c_ptr) :: allocated_memory 142 | integer(c_int) :: answer, ni 143 | call prif_num_images(num_images=ni) 144 | 145 | call prif_allocate_coarray( & 146 | lcobounds = [1_c_int64_t, 2_c_int64_t], & 147 | ucobounds = [2_c_int64_t, ni+3_c_int64_t], & 148 | size_in_bytes = 1_c_size_t, & 149 | final_func = c_null_funptr, & 150 | coarray_handle = coarray_handle, & 151 | allocated_memory = allocated_memory) 152 | call prif_image_index(coarray_handle, [1_c_int64_t, 3_c_int64_t], image_index=answer) 153 | result_ = assert_equals(merge(3_c_int,0_c_int,ni >= 3), answer) 154 | 155 | result_ = result_ .and. & 156 | check_this_image_coarray(coarray_handle, 2) 157 | 158 | call prif_deallocate_coarray([coarray_handle]) 159 | end function 160 | 161 | function check_complicated_3d() result(result_) 162 | type(result_t) :: result_ 163 | 164 | type(prif_coarray_handle) :: coarray_handle 165 | type(c_ptr) :: allocated_memory 166 | integer(c_int) :: answer, ni 167 | type(prif_team_type) :: initial_team 168 | call prif_get_team(team=initial_team) 169 | call prif_num_images_with_team(team=initial_team, num_images=ni) 170 | 171 | call prif_allocate_coarray( & 172 | lcobounds = [1_c_int64_t, 0_c_int64_t, 0_c_int64_t], & 173 | ucobounds = [2_c_int64_t, 1_c_int64_t, ni+0_c_int64_t], & 174 | size_in_bytes = 1_c_size_t, & 175 | final_func = c_null_funptr, & 176 | coarray_handle = coarray_handle, & 177 | allocated_memory = allocated_memory) 178 | call prif_image_index_with_team(coarray_handle, & 179 | [2_c_int64_t, 1_c_int64_t, 1_c_int64_t], & 180 | team=initial_team, image_index=answer) 181 | result_ = assert_equals(merge(8_c_int,0_c_int,ni >= 8), answer) 182 | 183 | result_ = result_ .and. & 184 | check_this_image_coarray(coarray_handle, 3) 185 | 186 | call prif_deallocate_coarray([coarray_handle]) 187 | end function 188 | 189 | function check_complicated_2d_team() result(result_) 190 | type(result_t) :: result_ 191 | 192 | type(prif_coarray_handle) :: coarray_handle 193 | type(c_ptr) :: allocated_memory 194 | integer(c_int) :: answer, ni, cni, me 195 | integer(c_int64_t) :: which_team 196 | type(prif_team_type) :: initial_team, child_team 197 | 198 | result_ = succeed("") 199 | 200 | call prif_get_team(team=initial_team) 201 | call prif_num_images_with_team(team=initial_team, num_images=ni) 202 | call prif_this_image_no_coarray(this_image=me) 203 | 204 | call prif_allocate_coarray( & 205 | lcobounds = [0_c_int64_t, 2_c_int64_t], & 206 | ucobounds = [1_c_int64_t, ni+3_c_int64_t], & 207 | size_in_bytes = 1_c_size_t, & 208 | final_func = c_null_funptr, & 209 | coarray_handle = coarray_handle, & 210 | allocated_memory = allocated_memory) 211 | 212 | which_team = merge(1_c_int64_t, 2_c_int64_t, mod(me, 2) == 0) 213 | call prif_form_team(team_number = which_team, team = child_team) 214 | call prif_change_team(child_team) 215 | 216 | call prif_num_images_with_team(team=child_team, num_images=cni) 217 | 218 | call prif_image_index_with_team(coarray_handle, & 219 | [0_c_int64_t, 2_c_int64_t], & 220 | team=initial_team, image_index=answer) 221 | result_ = result_ .and. & 222 | assert_equals(1_c_int, answer) 223 | 224 | call prif_image_index_with_team_number(coarray_handle, & 225 | [0_c_int64_t, 2_c_int64_t], & 226 | team_number=-1_c_int64_t, image_index=answer) 227 | result_ = result_ .and. & 228 | assert_equals(1_c_int, answer) 229 | 230 | call prif_image_index_with_team(coarray_handle, & 231 | [0_c_int64_t, 2_c_int64_t], & 232 | team=child_team, image_index=answer) 233 | result_ = result_ .and. & 234 | assert_equals(1_c_int, answer) 235 | 236 | call prif_image_index_with_team_number(coarray_handle, & 237 | [0_c_int64_t, 2_c_int64_t], & 238 | team_number=which_team, image_index=answer) 239 | result_ = result_ .and. & 240 | assert_equals(1_c_int, answer) 241 | 242 | call prif_image_index(coarray_handle, & 243 | [0_c_int64_t, 2_c_int64_t], & 244 | image_index=answer) 245 | result_ = result_ .and. & 246 | assert_equals(1_c_int, answer) 247 | 248 | call prif_image_index_with_team(coarray_handle, & 249 | [0_c_int64_t, 3_c_int64_t], & 250 | team=initial_team, image_index=answer) 251 | result_ = result_ .and. & 252 | assert_equals(merge(3_c_int,0_c_int,ni >= 3), answer) 253 | 254 | call prif_image_index_with_team_number(coarray_handle, & 255 | [0_c_int64_t, 3_c_int64_t], & 256 | team_number=-1_c_int64_t, image_index=answer) 257 | result_ = result_ .and. & 258 | assert_equals(merge(3_c_int,0_c_int,ni >= 3), answer) 259 | 260 | call prif_image_index_with_team(coarray_handle, & 261 | [0_c_int64_t, 3_c_int64_t], & 262 | team=child_team, image_index=answer) 263 | result_ = result_ .and. & 264 | assert_equals(merge(3_c_int,0_c_int,cni >= 3), answer) 265 | 266 | call prif_image_index_with_team_number(coarray_handle, & 267 | [0_c_int64_t, 3_c_int64_t], & 268 | team_number=which_team, image_index=answer) 269 | result_ = result_ .and. & 270 | assert_equals(merge(3_c_int,0_c_int,cni >= 3), answer) 271 | 272 | call prif_image_index(coarray_handle, & 273 | [0_c_int64_t, 3_c_int64_t], & 274 | image_index=answer) 275 | result_ = result_ .and. & 276 | assert_equals(merge(3_c_int,0_c_int,cni >= 3), answer) 277 | 278 | result_ = result_ .and. & 279 | check_this_image_coarray(coarray_handle, 2, initial_team) 280 | result_ = result_ .and. & 281 | check_this_image_coarray(coarray_handle, 2, child_team) 282 | 283 | call prif_end_team() 284 | call prif_deallocate_coarray([coarray_handle]) 285 | end function 286 | 287 | 288 | 289 | end module 290 | -------------------------------------------------------------------------------- /test/prif_image_queries_test.F90: -------------------------------------------------------------------------------- 1 | module caf_image_queries_test 2 | use iso_c_binding, only: c_int 3 | use prif, only : prif_image_status, prif_stopped_images, prif_failed_images, PRIF_STAT_FAILED_IMAGE, PRIF_STAT_STOPPED_IMAGE 4 | use prif, only : prif_num_images 5 | use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed 6 | 7 | implicit none 8 | private 9 | public :: test_prif_image_queries 10 | 11 | contains 12 | function test_prif_image_queries() result(tests) 13 | type(test_item_t) :: tests 14 | 15 | tests = describe( & 16 | "PRIF image queries", [ & 17 | it("provide valid prif_image_status()", check_image_status), & 18 | it("provide valid prif_stopped_images()", check_stopped_images), & 19 | it("provide valid prif_failed_images()", check_failed_images) & 20 | ]) 21 | end function 22 | 23 | function check_image_status() result(result_) 24 | type(result_t) :: result_ 25 | integer(c_int) :: image_status 26 | 27 | call prif_image_status(1, image_status=image_status) 28 | result_ = assert_that(image_status == 0 .or. & 29 | image_status == PRIF_STAT_FAILED_IMAGE .or. & 30 | image_status == PRIF_STAT_STOPPED_IMAGE, "permitted image status") 31 | end function 32 | 33 | function valid_image_list(nums) result(result_) 34 | integer, allocatable, intent(in) :: nums(:) 35 | type(result_t) :: result_ 36 | integer i, ni 37 | 38 | call prif_num_images(num_images=ni) 39 | result_ = assert_that( allocated(nums) .and. size(nums) <= ni .and. & 40 | all([(nums(i) >= 1 .and. nums(i) <= ni, i = 1, size(nums))]) .and. & 41 | all([(nums(i) < nums(i+1), i = 1, size(nums)-1)]), & 42 | "valid stopped images") 43 | end function 44 | 45 | function check_stopped_images() result(result_) 46 | type(result_t) :: result_ 47 | integer, allocatable :: nums(:) 48 | 49 | call prif_stopped_images(stopped_images=nums) 50 | result_ = valid_image_list(nums) 51 | end function 52 | 53 | function check_failed_images() result(result_) 54 | type(result_t) :: result_ 55 | integer, allocatable :: nums(:) 56 | 57 | call prif_failed_images(failed_images=nums) 58 | result_ = valid_image_list(nums) 59 | end function 60 | 61 | end module caf_image_queries_test 62 | -------------------------------------------------------------------------------- /test/prif_num_images_test.F90: -------------------------------------------------------------------------------- 1 | module caf_num_images_test 2 | use prif, only : prif_num_images 3 | use veggies, only: result_t, test_item_t, assert_that, describe, it 4 | 5 | implicit none 6 | private 7 | public :: test_prif_num_images 8 | 9 | contains 10 | function test_prif_num_images() result(tests) 11 | type(test_item_t) :: tests 12 | 13 | tests = & 14 | describe( & 15 | "The prif_num_images function result", & 16 | [ it("is a valid number of images when invoked with no arguments", check_num_images_valid) & 17 | ]) 18 | end function 19 | 20 | function check_num_images_valid() result(result_) 21 | type(result_t) :: result_ 22 | integer :: num_imgs 23 | call prif_num_images(num_images=num_imgs) 24 | result_ = assert_that(num_imgs>0, "positive number of images") 25 | end function 26 | 27 | end module caf_num_images_test 28 | -------------------------------------------------------------------------------- /test/prif_rma_test.F90: -------------------------------------------------------------------------------- 1 | module caf_rma_test 2 | use iso_c_binding, only: & 3 | c_ptr, c_int64_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof 4 | use prif, only: & 5 | prif_coarray_handle, & 6 | prif_allocate_coarray, & 7 | prif_deallocate_coarray, & 8 | prif_allocate, & 9 | prif_deallocate, & 10 | prif_num_images, & 11 | prif_put, & 12 | prif_put_indirect, & 13 | prif_get, & 14 | prif_get_indirect, & 15 | prif_sync_all, & 16 | prif_sync_memory, & 17 | prif_this_image_no_coarray 18 | use veggies, only: result_t, test_item_t, assert_equals, describe, it 19 | 20 | implicit none 21 | private 22 | public :: test_prif_rma 23 | contains 24 | function test_prif_rma() result(tests) 25 | type(test_item_t) :: tests 26 | 27 | tests = describe( & 28 | "PRIF RMA", & 29 | [ it("can send a value to another image", check_put) & 30 | , it("can send a value with indirect interface", check_put_indirect) & 31 | , it("can get a value from another image", check_get) & 32 | , it("can get a value with indirect interface", check_get_indirect) & 33 | ]) 34 | end function 35 | 36 | function check_put() result(result_) 37 | type(result_t) :: result_ 38 | 39 | integer :: dummy_element, num_imgs, expected, neighbor 40 | integer, target :: me 41 | type(prif_coarray_handle) :: coarray_handle 42 | type(c_ptr) :: allocated_memory 43 | integer, pointer :: local_slice 44 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 45 | 46 | call prif_num_images(num_images=num_imgs) 47 | lcobounds(1) = 1 48 | ucobounds(1) = num_imgs 49 | call prif_allocate_coarray( & 50 | lcobounds = lcobounds, & 51 | ucobounds = ucobounds, & 52 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 53 | final_func = c_null_funptr, & 54 | coarray_handle = coarray_handle, & 55 | allocated_memory = allocated_memory) 56 | call c_f_pointer(allocated_memory, local_slice) 57 | 58 | call prif_this_image_no_coarray(this_image=me) 59 | neighbor = merge(me+1, 1, me < num_imgs) 60 | expected = merge(me-1, num_imgs, me > 1) 61 | 62 | call prif_put( & 63 | image_num = neighbor, & 64 | coarray_handle = coarray_handle, & 65 | offset = 0_c_size_t, & 66 | current_image_buffer = c_loc(me), & 67 | size_in_bytes = c_sizeof(me)) 68 | call prif_sync_all 69 | 70 | ! superfluous, just to ensure prif_sync_memory is usable 71 | call prif_sync_memory 72 | 73 | result_ = assert_equals(expected, local_slice) 74 | 75 | call prif_deallocate_coarray([coarray_handle]) 76 | end function 77 | 78 | function check_put_indirect() result(result_) 79 | type(result_t) :: result_ 80 | 81 | type :: my_type 82 | type(c_ptr) :: my_component 83 | end type 84 | 85 | type(my_type), target :: dummy_element 86 | integer, pointer :: component_access 87 | integer :: dummy_component, num_imgs, expected, neighbor 88 | integer, target :: me 89 | type(prif_coarray_handle) :: coarray_handle 90 | type(c_ptr) :: allocated_memory 91 | type(my_type), pointer :: local_slice 92 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 93 | integer(c_intptr_t) :: base_addr 94 | 95 | call prif_num_images(num_images=num_imgs) 96 | lcobounds(1) = 1 97 | ucobounds(1) = num_imgs 98 | call prif_allocate_coarray( & 99 | lcobounds = lcobounds, & 100 | ucobounds = ucobounds, & 101 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 102 | final_func = c_null_funptr, & 103 | coarray_handle = coarray_handle, & 104 | allocated_memory = allocated_memory) 105 | call c_f_pointer(allocated_memory, local_slice) 106 | call prif_allocate( & 107 | size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & 108 | allocated_memory = local_slice%my_component) 109 | call prif_sync_all 110 | 111 | call prif_this_image_no_coarray(this_image=me) 112 | neighbor = merge(me+1, 1, me < num_imgs) 113 | expected = merge(me-1, num_imgs, me > 1) 114 | 115 | call prif_get( & 116 | image_num = neighbor, & 117 | coarray_handle = coarray_handle, & 118 | offset = 0_c_size_t, & 119 | current_image_buffer = c_loc(dummy_element), & 120 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) 121 | base_addr = transfer(dummy_element%my_component, base_addr) 122 | call prif_put_indirect( & 123 | image_num = neighbor, & 124 | remote_ptr = base_addr, & 125 | current_image_buffer = c_loc(me), & 126 | size_in_bytes = int(storage_size(me)/8, c_size_t)) 127 | call prif_sync_all 128 | 129 | call c_f_pointer(local_slice%my_component, component_access) 130 | result_ = assert_equals(expected, component_access) 131 | 132 | call prif_deallocate(local_slice%my_component) 133 | call prif_deallocate_coarray([coarray_handle]) 134 | end function 135 | 136 | function check_get() result(result_) 137 | type(result_t) :: result_ 138 | 139 | integer :: dummy_element, num_imgs, me, neighbor, expected 140 | integer, target :: retrieved 141 | type(prif_coarray_handle) :: coarray_handle 142 | type(c_ptr) :: allocated_memory 143 | integer, pointer :: local_slice 144 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 145 | 146 | call prif_num_images(num_images=num_imgs) 147 | lcobounds(1) = 1 148 | ucobounds(1) = num_imgs 149 | call prif_allocate_coarray( & 150 | lcobounds = lcobounds, & 151 | ucobounds = ucobounds, & 152 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 153 | final_func = c_null_funptr, & 154 | coarray_handle = coarray_handle, & 155 | allocated_memory = allocated_memory) 156 | call c_f_pointer(allocated_memory, local_slice) 157 | 158 | call prif_this_image_no_coarray(this_image=me) 159 | neighbor = merge(me+1, 1, me < num_imgs) 160 | expected = neighbor 161 | local_slice = me 162 | call prif_sync_all 163 | 164 | call prif_get( & 165 | image_num = neighbor, & 166 | coarray_handle = coarray_handle, & 167 | offset = 0_c_size_t, & 168 | current_image_buffer = c_loc(retrieved), & 169 | size_in_bytes = c_sizeof(retrieved)) 170 | 171 | result_ = assert_equals(expected, retrieved) 172 | 173 | call prif_deallocate_coarray([coarray_handle]) 174 | end function 175 | 176 | function check_get_indirect() result(result_) 177 | type(result_t) :: result_ 178 | 179 | type :: my_type 180 | type(c_ptr) :: my_component 181 | end type 182 | 183 | type(my_type), target :: dummy_element 184 | integer, pointer :: component_access 185 | integer :: dummy_component, num_imgs, me, expected, neighbor 186 | integer, target :: retrieved 187 | type(prif_coarray_handle) :: coarray_handle 188 | type(c_ptr) :: allocated_memory 189 | type(my_type), pointer :: local_slice 190 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 191 | integer(c_intptr_t) :: base_addr 192 | 193 | call prif_num_images(num_images=num_imgs) 194 | lcobounds(1) = 1 195 | ucobounds(1) = num_imgs 196 | call prif_allocate_coarray( & 197 | lcobounds = lcobounds, & 198 | ucobounds = ucobounds, & 199 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 200 | final_func = c_null_funptr, & 201 | coarray_handle = coarray_handle, & 202 | allocated_memory = allocated_memory) 203 | call c_f_pointer(allocated_memory, local_slice) 204 | call prif_allocate( & 205 | size_in_bytes = int(storage_size(dummy_component)/8, c_size_t), & 206 | allocated_memory = local_slice%my_component) 207 | 208 | call prif_this_image_no_coarray(this_image=me) 209 | neighbor = merge(me+1, 1, me < num_imgs) 210 | expected = neighbor 211 | call c_f_pointer(local_slice%my_component, component_access) 212 | component_access = me 213 | call prif_sync_all 214 | 215 | call prif_get( & 216 | image_num = neighbor, & 217 | coarray_handle = coarray_handle, & 218 | offset = 0_c_size_t, & 219 | current_image_buffer = c_loc(dummy_element), & 220 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) 221 | base_addr = transfer(dummy_element%my_component, base_addr) 222 | call prif_get_indirect( & 223 | image_num = neighbor, & 224 | remote_ptr = base_addr, & 225 | current_image_buffer = c_loc(retrieved), & 226 | size_in_bytes = int(storage_size(retrieved)/8, c_size_t)) 227 | 228 | result_ = assert_equals(expected, retrieved) 229 | 230 | call prif_deallocate(local_slice%my_component) 231 | call prif_deallocate_coarray([coarray_handle]) 232 | end function 233 | end module 234 | -------------------------------------------------------------------------------- /test/prif_stop_test.F90: -------------------------------------------------------------------------------- 1 | module caf_stop_test 2 | use prif, only: prif_this_image_no_coarray, prif_sync_all 3 | use veggies, only: test_item_t, describe, result_t, it, assert_that, assert_equals, succeed 4 | use unit_test_parameters_m, only : expected_stop_code, & 5 | image_one => subjob_setup, cmd_prefix => subjob_prefix 6 | 7 | implicit none 8 | private 9 | public :: test_prif_stop 10 | 11 | integer, parameter :: max_message_len = 128 12 | 13 | contains 14 | function test_prif_stop() result(tests) 15 | type(test_item_t) :: tests 16 | 17 | tests = describe( & 18 | "A program that executes the prif_stop function", & 19 | [ it("exits with a zero exitstat when the program omits the stop code", exit_with_no_stop_code) & 20 | ,it("prints an integer stop code and exits with exitstat equal to the stop code", exit_with_integer_stop_code) & 21 | ,it("prints a character stop code and exits with a non-zero exitstat", exit_with_character_stop_code) & 22 | ,it("invokes a registered callback", check_callback_invocation) & 23 | ]) 24 | end function 25 | 26 | function exit_with_no_stop_code() result(result_) 27 | type(result_t) :: result_ 28 | integer exit_status, cmd_stat 29 | character(len=max_message_len) command_message 30 | 31 | if (image_one()) then 32 | command_message = "exit_with_no_stop_code" 33 | 34 | call execute_command_line( & 35 | command = cmd_prefix//"./build/run-fpm.sh run --example stop_with_no_code > /dev/null 2>&1", & 36 | wait = .true., & 37 | exitstat = exit_status, & 38 | cmdstat = cmd_stat, & 39 | cmdmsg = command_message & 40 | ) 41 | result_ = assert_equals(0, exit_status, command_message) 42 | else 43 | result_ = succeed("skipped") 44 | end if 45 | 46 | end function 47 | 48 | function exit_with_integer_stop_code() result(result_) 49 | type(result_t) :: result_ 50 | integer exit_status, cmd_stat 51 | character(len=max_message_len) command_message 52 | 53 | if (image_one()) then 54 | command_message = "exit_with_integer_stop_code" 55 | 56 | call execute_command_line( & 57 | command = cmd_prefix//"./build/run-fpm.sh run --example stop_with_integer_code > /dev/null 2>&1", & 58 | wait = .true., & 59 | exitstat = exit_status, & 60 | cmdstat = cmd_stat, & 61 | cmdmsg = command_message & 62 | ) 63 | result_ = assert_equals(expected_stop_code, exit_status, command_message) 64 | else 65 | result_ = succeed("skipped") 66 | end if 67 | 68 | end function 69 | 70 | function exit_with_character_stop_code() result(result_) 71 | type(result_t) :: result_ 72 | integer exit_status, cmd_stat 73 | character(len=max_message_len) command_message 74 | 75 | if (image_one()) then 76 | command_message = "exit_with_character_stop_code" 77 | 78 | call execute_command_line( & 79 | command = cmd_prefix//"./build/run-fpm.sh run --example stop_with_character_code > /dev/null 2>&1", & 80 | wait = .true., & 81 | exitstat = exit_status, & 82 | cmdstat = cmd_stat, & 83 | cmdmsg = command_message & 84 | ) 85 | ! the standard recommends zero exit status for character stop codes 86 | result_ = assert_equals(0, exit_status, command_message) 87 | else 88 | result_ = succeed("skipped") 89 | end if 90 | 91 | end function 92 | 93 | function check_callback_invocation() result(result_) 94 | type(result_t) :: result_ 95 | integer exit_status, cmd_stat 96 | character(len=max_message_len) command_message 97 | 98 | if (image_one()) then 99 | call execute_command_line( & 100 | command = cmd_prefix//"./build/run-fpm.sh run --example register_stop_callback > /dev/null 2>&1", & 101 | wait = .true., & 102 | exitstat = exit_status, & 103 | cmdstat = cmd_stat, & 104 | cmdmsg = command_message & 105 | ) 106 | result_ = assert_equals(0, exit_status, command_message) 107 | else 108 | result_ = succeed("skipped") 109 | end if 110 | end function 111 | 112 | end module caf_stop_test 113 | -------------------------------------------------------------------------------- /test/prif_strided_test.F90: -------------------------------------------------------------------------------- 1 | module caf_strided_test 2 | use iso_c_binding, only: & 3 | c_ptr, c_int64_t, c_intptr_t, c_size_t, c_null_funptr, c_f_pointer, c_loc, c_sizeof 4 | use prif, only: & 5 | prif_coarray_handle, & 6 | prif_allocate_coarray, & 7 | prif_deallocate_coarray, & 8 | prif_allocate, & 9 | prif_deallocate, & 10 | prif_num_images, & 11 | prif_get, & 12 | prif_put_strided, & 13 | prif_put_strided_indirect, & 14 | prif_get_strided, & 15 | prif_get_strided_indirect, & 16 | prif_sync_all, & 17 | prif_this_image_no_coarray 18 | use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed, fail 19 | 20 | implicit none 21 | private 22 | public :: test_prif_rma_strided 23 | contains 24 | function test_prif_rma_strided() result(tests) 25 | type(test_item_t) :: tests 26 | 27 | tests = describe( & 28 | "PRIF Strided RMA", & 29 | [ it("can put strided data to another image", check_put) & 30 | , it("can put strided data with indirect interface", check_put_indirect) & 31 | , it("can get strided data from another image", check_get) & 32 | , it("can get strided data with indirect interface", check_get_indirect) & 33 | ]) 34 | end function 35 | 36 | function assert_equals_array2d(expected, actual) result(result_) 37 | integer, intent(in) :: expected(:,:) 38 | integer, intent(in) :: actual(:,:) 39 | type(result_t) :: result_ 40 | integer :: i,j 41 | 42 | result_ = succeed("") 43 | result_ = result_ .and. assert_equals(size(expected,1), size(actual,1)) 44 | result_ = result_ .and. assert_equals(size(expected,2), size(actual,2)) 45 | 46 | do i = lbound(actual,1), ubound(actual,1) 47 | do j = lbound(actual,2), ubound(actual,2) 48 | block 49 | character(len=100) :: result_string 50 | 51 | write(result_string, '("At position (", I0, ",", I0, ") expected=", I0, " actual=", I0)') & 52 | i, j, expected(i,j), actual(i,j) 53 | 54 | result_ = result_ .and. & 55 | assert_equals(expected(i,j), actual(i,j), result_string) 56 | end block 57 | end do 58 | end do 59 | 60 | end function 61 | 62 | function check_put() result(result_) 63 | type(result_t) :: result_ 64 | 65 | integer :: me, num_imgs, neighbor 66 | type(prif_coarray_handle) :: coarray_handle 67 | type(c_ptr) :: allocated_memory 68 | integer, target :: mydata(1:4, 1:4) 69 | integer, target :: expected(1:4, 1:4) 70 | integer, pointer :: local_slice(:,:) 71 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 72 | integer(c_size_t) :: sizeof_int 73 | 74 | sizeof_int = storage_size(me)/8 75 | call prif_num_images(num_images=num_imgs) 76 | call prif_this_image_no_coarray(this_image=me) 77 | neighbor = merge(me+1, 1, me < num_imgs) 78 | 79 | lcobounds(1) = 1 80 | ucobounds(1) = num_imgs 81 | call prif_allocate_coarray( & 82 | lcobounds = lcobounds, & 83 | ucobounds = ucobounds, & 84 | size_in_bytes = sizeof_int*product(shape(mydata)), & 85 | final_func = c_null_funptr, & 86 | coarray_handle = coarray_handle, & 87 | allocated_memory = allocated_memory) 88 | call c_f_pointer(allocated_memory, local_slice, shape(mydata)) 89 | 90 | ! init data arrays to known values 91 | local_slice = -1 92 | expected = -1 93 | mydata = 0 94 | 95 | call prif_sync_all 96 | 97 | ! simple example: we set, then copy the interior rectangle of a 4x4 array 98 | mydata(2:3, 2:3) = me 99 | expected(2:3, 2:3) = merge(me-1, num_imgs, me > 1) 100 | 101 | call prif_put_strided( & 102 | image_num = neighbor, & 103 | coarray_handle = coarray_handle, & 104 | offset = 5*sizeof_int, & 105 | remote_stride = [4*sizeof_int, sizeof_int], & 106 | current_image_buffer = c_loc(mydata(2,2)), & 107 | current_image_stride = [4*sizeof_int, sizeof_int], & 108 | element_size = sizeof_int, & 109 | extent = [2_c_size_t, 2_c_size_t]) 110 | 111 | call prif_sync_all 112 | 113 | result_ = assert_equals_array2d(expected, local_slice) 114 | 115 | call prif_deallocate_coarray([coarray_handle]) 116 | end function 117 | 118 | function check_put_indirect() result(result_) 119 | type(result_t) :: result_ 120 | 121 | type :: my_type 122 | type(c_ptr) :: my_component 123 | end type 124 | 125 | type(my_type), target :: dummy_element 126 | integer, pointer :: component_access(:,:) 127 | integer :: me, num_imgs, neighbor 128 | integer, target :: mydata(1:4, 1:4) 129 | integer, target :: expected(1:4, 1:4) 130 | type(prif_coarray_handle) :: coarray_handle 131 | type(c_ptr) :: allocated_memory 132 | type(my_type), pointer :: local_slice 133 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 134 | integer(c_intptr_t) :: base_addr 135 | integer(c_size_t) :: sizeof_int 136 | 137 | sizeof_int = storage_size(me)/8 138 | call prif_num_images(num_images=num_imgs) 139 | call prif_this_image_no_coarray(this_image=me) 140 | neighbor = merge(me+1, 1, me < num_imgs) 141 | 142 | lcobounds(1) = 1 143 | ucobounds(1) = num_imgs 144 | call prif_allocate_coarray( & 145 | lcobounds = lcobounds, & 146 | ucobounds = ucobounds, & 147 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 148 | final_func = c_null_funptr, & 149 | coarray_handle = coarray_handle, & 150 | allocated_memory = allocated_memory) 151 | call c_f_pointer(allocated_memory, local_slice) 152 | call prif_allocate( & 153 | size_in_bytes = int(sizeof_int*product(shape(mydata)), c_size_t), & 154 | allocated_memory = local_slice%my_component) 155 | call c_f_pointer(local_slice%my_component, component_access, shape(mydata)) 156 | 157 | ! init data arrays to known values 158 | component_access = -1 159 | expected = -1 160 | mydata = 0 161 | 162 | call prif_sync_all 163 | 164 | ! simple example: we set, then copy the interior rectangle of a 4x4 array 165 | mydata(2:3, 2:3) = me 166 | expected(2:3, 2:3) = merge(me-1, num_imgs, me > 1) 167 | 168 | call prif_get( & 169 | image_num = neighbor, & 170 | coarray_handle = coarray_handle, & 171 | offset = 0_c_size_t, & 172 | current_image_buffer = c_loc(dummy_element), & 173 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) 174 | base_addr = transfer(dummy_element%my_component, base_addr) 175 | 176 | call prif_put_strided_indirect( & 177 | image_num = neighbor, & 178 | remote_ptr = base_addr + 5*sizeof_int, & 179 | remote_stride = [4*sizeof_int, sizeof_int], & 180 | current_image_buffer = c_loc(mydata(2,2)), & 181 | current_image_stride = [4*sizeof_int, sizeof_int], & 182 | element_size = sizeof_int, & 183 | extent = [2_c_size_t, 2_c_size_t]) 184 | 185 | call prif_sync_all 186 | 187 | result_ = assert_equals_array2d(expected, component_access) 188 | 189 | call prif_deallocate(local_slice%my_component) 190 | call prif_deallocate_coarray([coarray_handle]) 191 | end function 192 | 193 | function check_get() result(result_) 194 | type(result_t) :: result_ 195 | 196 | integer :: me, num_imgs, neighbor 197 | type(prif_coarray_handle) :: coarray_handle 198 | type(c_ptr) :: allocated_memory 199 | integer, target :: mydata(1:4, 1:4) 200 | integer, target :: expected(1:4, 1:4) 201 | integer, pointer :: local_slice(:,:) 202 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 203 | integer(c_size_t) :: sizeof_int 204 | 205 | sizeof_int = storage_size(me)/8 206 | call prif_num_images(num_images=num_imgs) 207 | call prif_this_image_no_coarray(this_image=me) 208 | neighbor = merge(me+1, 1, me < num_imgs) 209 | 210 | lcobounds(1) = 1 211 | ucobounds(1) = num_imgs 212 | call prif_allocate_coarray( & 213 | lcobounds = lcobounds, & 214 | ucobounds = ucobounds, & 215 | size_in_bytes = sizeof_int*product(shape(mydata)), & 216 | final_func = c_null_funptr, & 217 | coarray_handle = coarray_handle, & 218 | allocated_memory = allocated_memory) 219 | call c_f_pointer(allocated_memory, local_slice, shape(mydata)) 220 | 221 | ! simple example: we copy the interior rectangle of a 4x4 array 222 | local_slice = -1 223 | local_slice(2:3, 2:3) = me 224 | expected = 0 225 | expected(2:3, 2:3) = neighbor 226 | mydata = 0 227 | 228 | call prif_sync_all 229 | 230 | call prif_get_strided( & 231 | image_num = neighbor, & 232 | coarray_handle = coarray_handle, & 233 | offset = 5*sizeof_int, & 234 | remote_stride = [4*sizeof_int, sizeof_int], & 235 | current_image_buffer = c_loc(mydata(2,2)), & 236 | current_image_stride = [4*sizeof_int, sizeof_int], & 237 | element_size = sizeof_int, & 238 | extent = [2_c_size_t, 2_c_size_t]) 239 | 240 | call prif_sync_all 241 | 242 | result_ = assert_equals_array2d(expected, mydata) 243 | 244 | call prif_deallocate_coarray([coarray_handle]) 245 | end function 246 | 247 | function check_get_indirect() result(result_) 248 | type(result_t) :: result_ 249 | 250 | type :: my_type 251 | type(c_ptr) :: my_component 252 | end type 253 | 254 | type(my_type), target :: dummy_element 255 | integer, pointer :: component_access(:,:) 256 | integer :: me, num_imgs, neighbor 257 | integer, target :: mydata(1:4, 1:4) 258 | integer, target :: expected(1:4, 1:4) 259 | type(prif_coarray_handle) :: coarray_handle 260 | type(c_ptr) :: allocated_memory 261 | type(my_type), pointer :: local_slice 262 | integer(c_int64_t) :: lcobounds(1), ucobounds(1) 263 | integer(c_intptr_t) :: base_addr 264 | integer(c_size_t) :: sizeof_int 265 | 266 | sizeof_int = storage_size(me)/8 267 | call prif_num_images(num_images=num_imgs) 268 | call prif_this_image_no_coarray(this_image=me) 269 | neighbor = merge(me+1, 1, me < num_imgs) 270 | 271 | lcobounds(1) = 1 272 | ucobounds(1) = num_imgs 273 | call prif_allocate_coarray( & 274 | lcobounds = lcobounds, & 275 | ucobounds = ucobounds, & 276 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t), & 277 | final_func = c_null_funptr, & 278 | coarray_handle = coarray_handle, & 279 | allocated_memory = allocated_memory) 280 | call c_f_pointer(allocated_memory, local_slice) 281 | call prif_allocate( & 282 | size_in_bytes = int(sizeof_int*product(shape(mydata)), c_size_t), & 283 | allocated_memory = local_slice%my_component) 284 | call c_f_pointer(local_slice%my_component, component_access, shape(mydata)) 285 | 286 | ! simple example: we copy the interior rectangle of a 4x4 array 287 | component_access = -1 288 | component_access(2:3, 2:3) = me 289 | expected = 0 290 | expected(2:3, 2:3) = neighbor 291 | mydata = 0 292 | 293 | call prif_sync_all 294 | 295 | call prif_get( & 296 | image_num = neighbor, & 297 | coarray_handle = coarray_handle, & 298 | offset = 0_c_size_t, & 299 | current_image_buffer = c_loc(dummy_element), & 300 | size_in_bytes = int(storage_size(dummy_element)/8, c_size_t)) 301 | base_addr = transfer(dummy_element%my_component, base_addr) 302 | 303 | call prif_get_strided_indirect( & 304 | image_num = neighbor, & 305 | remote_ptr = base_addr + 5*sizeof_int, & 306 | remote_stride = [4*sizeof_int, sizeof_int], & 307 | current_image_buffer = c_loc(mydata(2,2)), & 308 | current_image_stride = [4*sizeof_int, sizeof_int], & 309 | element_size = sizeof_int, & 310 | extent = [2_c_size_t, 2_c_size_t]) 311 | 312 | call prif_sync_all 313 | 314 | result_ = assert_equals_array2d(expected, mydata) 315 | 316 | call prif_deallocate(local_slice%my_component) 317 | call prif_deallocate_coarray([coarray_handle]) 318 | end function 319 | 320 | end module 321 | -------------------------------------------------------------------------------- /test/prif_sync_images_test.F90: -------------------------------------------------------------------------------- 1 | module caf_sync_images_test 2 | use iso_c_binding, only: c_int 3 | use prif, only : prif_sync_images, prif_this_image_no_coarray, prif_num_images, prif_sync_all 4 | use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed 5 | 6 | implicit none 7 | private 8 | public :: test_prif_sync_images 9 | 10 | integer, parameter :: lim = 10 11 | 12 | contains 13 | function test_prif_sync_images() result(tests) 14 | type(test_item_t) :: tests 15 | 16 | tests = describe( & 17 | "PRIF sync images", [ & 18 | it("pass serial prif_sync_images test", check_serial), & 19 | it("pass prif_sync_images neighbor test", check_neighbor), & 20 | it("pass prif_sync_images hot-spot test", check_hot) & 21 | ]) 22 | end function 23 | 24 | function check_serial() result(result_) 25 | type(result_t) :: result_ 26 | integer(c_int) :: me 27 | integer :: i 28 | 29 | call prif_this_image_no_coarray(this_image=me) 30 | call prif_sync_all 31 | 32 | ! synchronize with myself an image-dependent number of times: 33 | do i=1, lim*me 34 | call prif_sync_images([me]) 35 | end do 36 | 37 | call prif_sync_all 38 | result_ = succeed("") 39 | end function 40 | 41 | 42 | function check_neighbor() result(result_) 43 | type(result_t) :: result_ 44 | integer(c_int) :: me, num_imgs 45 | integer :: i 46 | 47 | call prif_this_image_no_coarray(this_image=me) 48 | call prif_num_images(num_images=num_imgs) 49 | call prif_sync_all 50 | 51 | ! test based on F23 11.7.4 note 3 52 | do i=1, lim 53 | if (me > 1) call prif_sync_images([me-1]) 54 | if (me < num_imgs) call prif_sync_images([me+1]) 55 | end do 56 | 57 | call prif_sync_all 58 | result_ = succeed("") 59 | end function 60 | 61 | function check_hot() result(result_) 62 | type(result_t) :: result_ 63 | integer(c_int) :: me, num_imgs 64 | integer :: i 65 | 66 | call prif_this_image_no_coarray(this_image=me) 67 | call prif_num_images(num_images=num_imgs) 68 | call prif_sync_all 69 | 70 | ! all images synchronize with 1 71 | if (me == 1) then 72 | block 73 | integer(c_int) :: everyone(num_imgs) 74 | everyone = [(i, i=1,num_imgs)] 75 | do i=1, lim 76 | ! SYNC IMAGES (*) 77 | call prif_sync_images() 78 | end do 79 | do i=1, lim 80 | call prif_sync_images(everyone) 81 | end do 82 | end block 83 | else 84 | do i=1, lim*2 85 | call prif_sync_images([1]) 86 | end do 87 | endif 88 | 89 | call prif_sync_all 90 | result_ = succeed("") 91 | end function 92 | 93 | 94 | end module 95 | -------------------------------------------------------------------------------- /test/prif_teams_test.F90: -------------------------------------------------------------------------------- 1 | module caf_teams_test 2 | use iso_c_binding, only: c_size_t, c_ptr, c_null_funptr, c_int64_t, c_int 3 | use prif 4 | use veggies, only: result_t, test_item_t, assert_equals, assert_that, describe, it, succeed, fail 5 | 6 | implicit none 7 | private 8 | public :: test_caf_teams 9 | contains 10 | function test_caf_teams() result(tests) 11 | type(test_item_t) :: tests 12 | 13 | tests = describe( & 14 | "Teams", & 15 | [ it("can be created, changed to, and allocate coarrays", check_teams) & 16 | ]) 17 | end function 18 | 19 | function check_teams() result(result_) 20 | type(result_t) :: result_ 21 | 22 | ! TODO: use final_func to observe automatic deallocation of coarrays 23 | integer :: dummy_element, i 24 | integer(c_int) :: initial_num_imgs, num_imgs, me, me_child, x 25 | integer(c_size_t) :: element_size 26 | integer(c_int64_t) :: which_team, n 27 | integer, parameter :: num_coarrays = 4 28 | type(prif_coarray_handle) :: coarrays(num_coarrays) 29 | type(c_ptr) :: allocated_memory 30 | type(prif_team_type) :: team, initial_team, t 31 | 32 | result_ = succeed("") 33 | 34 | call prif_num_images(num_images=initial_num_imgs) 35 | result_ = result_ .and. & 36 | assert_that(initial_num_imgs > 0, "prif_num_images is valid") 37 | 38 | call prif_this_image_no_coarray(this_image=me) 39 | result_ = result_ .and. & 40 | assert_that(me >= 1 .and. me <= initial_num_imgs, "prif_this_image is valid") 41 | 42 | n = 0 ! clear outputs 43 | call prif_team_number(team_number=n) 44 | result_ = result_ .and. & 45 | assert_equals(int(n), -1, "Initial team number is -1") 46 | 47 | n = 0 ! clear outputs 48 | call prif_get_team(team=initial_team) 49 | call prif_team_number(team=initial_team, team_number=n) 50 | result_ = result_ .and. & 51 | assert_equals(int(n), -1, "prif_get_team retrieves current initial team") 52 | 53 | ! ensure prif_sync_team is usable 54 | call prif_sync_team(team=initial_team) 55 | 56 | x = 0 ! clear outputs 57 | call prif_num_images_with_team(team=initial_team, num_images=x) 58 | result_ = result_ .and. & 59 | assert_equals(x, initial_num_imgs, "prif_num_images works with initial team") 60 | 61 | x = 0 ! clear outputs 62 | call prif_num_images_with_team_number(team_number=-1_c_int64_t, num_images=x) 63 | result_ = result_ .and. & 64 | assert_equals(x, initial_num_imgs, "prif_num_images_with_team_number works with initial team") 65 | 66 | x = 0 ! clear outputs 67 | call prif_this_image_no_coarray(team=initial_team, this_image=x) 68 | result_ = result_ .and. & 69 | assert_equals(x, me, "prif_this_image_no_coarray works with initial team") 70 | 71 | t = prif_team_type() ; n = 0 ! clear outputs 72 | call prif_get_team(level=PRIF_INITIAL_TEAM, team=t) 73 | call prif_team_number(team=t, team_number=n) 74 | result_ = result_ .and. & 75 | assert_equals(int(n), -1, "prif_get_team(PRIF_INITIAL_TEAM) retrieves initial team") 76 | 77 | t = prif_team_type() ; n = 0 ! clear outputs 78 | call prif_get_team(level=PRIF_CURRENT_TEAM, team=t) 79 | call prif_team_number(team=t, team_number=n) 80 | result_ = result_ .and. & 81 | assert_equals(int(n), -1, "prif_get_team(PRIF_CURRENT_TEAM) retrieves initial team when current team is initial team") 82 | 83 | t = prif_team_type() ; n = 0 ! clear outputs 84 | call prif_get_team(level=PRIF_PARENT_TEAM, team=t) 85 | call prif_team_number(team=t, team_number=n) 86 | result_ = result_ .and. & 87 | assert_equals(int(n), -1, "prif_get_team(PRIF_PARENT_TEAM) retrieves initial team when parent team is initial team") 88 | 89 | which_team = merge(1_c_int64_t, 2_c_int64_t, mod(me, 2) == 0) 90 | element_size = int(storage_size(dummy_element)/8, c_size_t) 91 | call prif_form_team(team_number = which_team, team = team) 92 | call prif_change_team(team) 93 | call prif_num_images(num_images=num_imgs) 94 | result_ = result_ .and. & 95 | assert_equals( & 96 | initial_num_imgs/2 + mod(initial_num_imgs,2)*(int(which_team)-1), & 97 | num_imgs, & 98 | "Team has correct number of images") 99 | 100 | ! ensure prif_sync_team is usable 101 | call prif_sync_team(team=team) 102 | call prif_sync_team(team=initial_team) 103 | 104 | x = 0 ! clear outputs 105 | call prif_num_images_with_team(team=team, num_images=x) 106 | result_ = result_ .and. & 107 | assert_equals(x, num_imgs, "prif_num_images works with team") 108 | 109 | x = 0 ! clear outputs 110 | call prif_num_images_with_team_number(team_number=which_team, num_images=x) 111 | result_ = result_ .and. & 112 | assert_equals(x, num_imgs, "prif_num_images_with_team_number works with current team") 113 | 114 | call prif_this_image_no_coarray(this_image=me_child) 115 | result_ = result_ .and. & 116 | assert_equals(me_child, (me - 1)/2 + 1, "prif_this_image is valid") 117 | 118 | x = 0 ! clear outputs 119 | call prif_this_image_no_coarray(team=team, this_image=x) 120 | result_ = result_ .and. & 121 | assert_equals(x, me_child, "prif_this_image is valid") 122 | 123 | n = 0 ! clear outputs 124 | call prif_team_number(team_number=n) 125 | result_ = result_ .and. & 126 | assert_equals(int(n), int(which_team), "Correct current team number") 127 | 128 | n = 0 ! clear outputs 129 | call prif_team_number(team=team, team_number=n) 130 | result_ = result_ .and. & 131 | assert_equals(int(n), int(which_team), "Correct current team number") 132 | 133 | t = prif_team_type() ; n = 0 ! clear outputs 134 | call prif_get_team(team=t) 135 | call prif_team_number(team=t, team_number=n) 136 | result_ = result_ .and. & 137 | assert_equals(int(n), int(which_team), "prif_get_team retrieves current team") 138 | 139 | t = prif_team_type() ; n = 0 ! clear outputs 140 | call prif_get_team(level=PRIF_INITIAL_TEAM, team=t) 141 | call prif_team_number(team=t, team_number=n) 142 | result_ = result_ .and. & 143 | assert_equals(int(n), -1, "prif_get_team(PRIF_INITIAL_TEAM) retrieves initial team") 144 | 145 | t = prif_team_type() ; n = 0 ! clear outputs 146 | call prif_get_team(level=PRIF_CURRENT_TEAM, team=t) 147 | call prif_team_number(team=t, team_number=n) 148 | result_ = result_ .and. & 149 | assert_equals(int(n), int(which_team), "prif_get_team(PRIF_CURRENT_TEAM) retrieves current team") 150 | 151 | t = prif_team_type() ; n = 0 ! clear outputs 152 | call prif_get_team(level=PRIF_PARENT_TEAM, team=t) 153 | call prif_team_number(team=t, team_number=n) 154 | result_ = result_ .and. & 155 | assert_equals(int(n), -1, "prif_get_team(PRIF_PARENT_TEAM) retrieves initial team when parent team is initial team") 156 | 157 | x = 0 ! clear outputs 158 | call prif_num_images_with_team(team=initial_team, num_images=x) 159 | result_ = result_ .and. & 160 | assert_equals(x, initial_num_imgs, "prif_num_images works with initial team") 161 | 162 | x = 0 ! clear outputs 163 | call prif_num_images_with_team_number(team_number=-1_c_int64_t, num_images=x) 164 | result_ = result_ .and. & 165 | assert_equals(x, initial_num_imgs, "prif_num_images_with_team_number works with initial team") 166 | 167 | x = 0 ! clear outputs 168 | call prif_this_image_no_coarray(team=initial_team, this_image=x) 169 | result_ = result_ .and. & 170 | assert_equals(x, me, "prif_this_image_no_coarray works with initial team") 171 | 172 | 173 | do i = 1, num_coarrays 174 | call prif_allocate_coarray( & 175 | lcobounds = [1_c_int64_t], & 176 | ucobounds = [int(num_imgs, c_int64_t)], & 177 | size_in_bytes = element_size, & 178 | final_func = c_null_funptr, & 179 | coarray_handle = coarrays(i), & 180 | allocated_memory = allocated_memory) 181 | end do 182 | call prif_deallocate_coarray(coarrays(4:4)) 183 | call prif_deallocate_coarray(coarrays(2:2)) 184 | 185 | call prif_end_team() 186 | 187 | ! ensure prif_sync_team is usable 188 | call prif_sync_team(team=team) 189 | call prif_sync_team(team=initial_team) 190 | 191 | t = prif_team_type() ; n = 0 ! clear outputs 192 | call prif_get_team(team=t) 193 | call prif_team_number(team=t, team_number=n) 194 | result_ = result_ .and. & 195 | assert_equals(int(n), -1, "prif_end_team restores initial team") 196 | 197 | result_ = result_.and.succeed("Seems to have worked") 198 | end function 199 | end module 200 | -------------------------------------------------------------------------------- /test/prif_this_image_test.F90: -------------------------------------------------------------------------------- 1 | module caf_this_image_test 2 | use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum 3 | use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed 4 | 5 | implicit none 6 | private 7 | public :: test_prif_this_image_no_coarray 8 | 9 | contains 10 | function test_prif_this_image_no_coarray() result(tests) 11 | type(test_item_t) :: tests 12 | 13 | tests = describe( & 14 | "The prif_this_image_no_coarray function result", & 15 | [ it("is the proper member of the set {1,2,...,num_images()} when invoked as this_image()", check_this_image_set) & 16 | ]) 17 | end function 18 | 19 | function check_this_image_set() result(result_) 20 | type(result_t) :: result_ 21 | integer, allocatable :: image_numbers(:) 22 | integer i, me, ni 23 | 24 | allocate(image_numbers(0)) 25 | 26 | call prif_this_image_no_coarray(this_image=me) 27 | call prif_num_images(num_images=ni) 28 | image_numbers = [(merge(0, me, me/=i), i = 1, ni)] 29 | call prif_co_sum(image_numbers) 30 | result_ = assert_that(all(image_numbers == [(i, i = 1, ni)]) .and. size(image_numbers)>0, "correct image set") 31 | end function 32 | 33 | end module caf_this_image_test 34 | --------------------------------------------------------------------------------