# 1 "../mpp/mpp.F90" !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !----------------------------------------------------------------------- ! Communication for message-passing codes ! ! AUTHOR: V. Balaji (V.Balaji@noaa.gov) ! SGI/GFDL Princeton University ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! For the full text of the GNU General Public License, ! write to: Free Software Foundation, Inc., ! 675 Mass Ave, Cambridge, MA 02139, USA. !----------------------------------------------------------------------- module mpp_mod !a generalized communication package for use with shmem and MPI !will add: co_array_fortran, MPI2 !Balaji (V.Balaji@noaa.gov) 11 May 1998 ! ! V. Balaji ! ! ! ! ! mpp_mod, is a set of simple calls to provide a uniform interface ! to different message-passing libraries. It currently can be ! implemented either in the SGI/Cray native SHMEM library or in the MPI ! standard. Other libraries (e.g MPI-2, Co-Array Fortran) can be ! incorporated as the need arises. ! ! ! The data transfer between a processor and its own memory is based ! on load and store operations upon ! memory. Shared-memory systems (including distributed shared memory ! systems) have a single address space and any processor can acquire any ! data within the memory by load and ! store. The situation is different for distributed ! parallel systems. Specialized MPP systems such as the T3E can simulate ! shared-memory by direct data acquisition from remote memory. But if ! the parallel code is distributed across a cluster, or across the Net, ! messages must be sent and received using the protocols for ! long-distance communication, such as TCP/IP. This requires a ! ``handshaking'' between nodes of the distributed system. One can think ! of the two different methods as involving puts or ! gets (e.g the SHMEM library), or in the case of ! negotiated communication (e.g MPI), sends and ! recvs. ! ! The difference between SHMEM and MPI is that SHMEM uses one-sided ! communication, which can have very low-latency high-bandwidth ! implementations on tightly coupled systems. MPI is a standard ! developed for distributed computing across loosely-coupled systems, ! and therefore incurs a software penalty for negotiating the ! communication. It is however an open industry standard whereas SHMEM ! is a proprietary interface. Besides, the puts or ! gets on which it is based cannot currently be implemented in ! a cluster environment (there are recent announcements from Compaq that ! occasion hope). ! ! The message-passing requirements of climate and weather codes can be ! reduced to a fairly simple minimal set, which is easily implemented in ! any message-passing API. mpp_mod provides this API. ! ! Features of mpp_mod include: ! ! 1) Simple, minimal API, with free access to underlying API for ! more complicated stuff.
! 2) Design toward typical use in climate/weather CFD codes.
! 3) Performance to be not significantly lower than any native API. ! ! This module is used to develop higher-level calls for domain decomposition and parallel I/O. ! ! Parallel computing is initially daunting, but it soon becomes ! second nature, much the way many of us can now write vector code ! without much effort. The key insight required while reading and ! writing parallel code is in arriving at a mental grasp of several ! independent parallel execution streams through the same code (the 1 ! model). Each variable you examine may have different values for each ! stream, the processor ID being an obvious example. Subroutines and ! function calls are particularly subtle, since it is not always obvious ! from looking at a call what synchronization between execution streams ! it implies. An example of erroneous code would be a global barrier ! call (see mpp_sync below) placed ! within a code block that not all PEs will execute, e.g: ! !
!   if( pe.EQ.0 )call mpp_sync()
!   
! ! Here only PE 0 reaches the barrier, where it will wait ! indefinitely. While this is a particularly egregious example to ! illustrate the coding flaw, more subtle versions of the same are ! among the most common errors in parallel code. ! ! It is therefore important to be conscious of the context of a ! subroutine or function call, and the implied synchronization. There ! are certain calls here (e.g mpp_declare_pelist, mpp_init, ! mpp_malloc, mpp_set_stack_size) which must be called by all ! PEs. There are others which must be called by a subset of PEs (here ! called a pelist) which must be called by all the PEs in the ! pelist (e.g mpp_max, mpp_sum, mpp_sync). Still ! others imply no synchronization at all. I will make every effort to ! highlight the context of each call in the MPP modules, so that the ! implicit synchronization is spelt out. ! ! For performance it is necessary to keep synchronization as limited ! as the algorithm being implemented will allow. For instance, a single ! message between two PEs should only imply synchronization across the ! PEs in question. A global synchronization (or barrier) ! is likely to be slow, and is best avoided. But codes first ! parallelized on a Cray T3E tend to have many global syncs, as very ! fast barriers were implemented there in hardware. ! ! Another reason to use pelists is to run a single program in MPMD ! mode, where different PE subsets work on different portions of the ! code. A typical example is to assign an ocean model and atmosphere ! model to different PE subsets, and couple them concurrently instead of ! running them serially. The MPP module provides the notion of a ! current pelist, which is set when a group of PEs branch off ! into a subset. Subsequent calls that omit the pelist optional ! argument (seen below in many of the individual calls) assume that the ! implied synchronization is across the current pelist. The calls ! mpp_root_pe and mpp_npes also return the values ! appropriate to the current pelist. The mpp_set_current_pelist ! call is provided to set the current pelist. !
! ! F90 is a strictly-typed language, and the syntax pass of the ! compiler requires matching of type, kind and rank (TKR). Most calls ! listed here use a generic type, shown here as MPP_TYPE_. This ! is resolved in the pre-processor stage to any of a variety of ! types. In general the MPP operations work on 4-byte and 8-byte ! variants of integer, real, complex, logical variables, of ! rank 0 to 5, leading to 48 specific module procedures under the same ! generic interface. Any of the variables below shown as ! MPP_TYPE_ is treated in this way. ! ! Define rank(X) for PGI compiler # 173 # 1 "../include/fms_platform.h" 1 ! -*-f90-*-* !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !Set type kinds. # 37 !These values are not necessarily portable. !DEC$ MESSAGE:'Using 8-byte addressing' !Control "pure" functions. # 54 !DEC$ MESSAGE:'Using pure routines.' !Control array members of derived types. # 66 !DEC$ MESSAGE:'Using allocatable derived type array members.' !Control use of cray pointers. # 78 !DEC$ MESSAGE:'Using cray pointers.' !Control size of integers that will hold address values. !Appears for legacy reasons, but seems rather dangerous. # 89 !If you do not want to use 64-bit integers. # 95 !If you do not want to use 32-bit floats. # 106 !If you want to use quad-precision. # 115 # 176 "../mpp/mpp.F90" 2 # 179 # 183 use mpp_parameter_mod, only : MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE use mpp_parameter_mod, only : NOTE, WARNING, FATAL, MPP_CLOCK_DETAILED,MPP_CLOCK_SYNC use mpp_parameter_mod, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER use mpp_parameter_mod, only : CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA use mpp_parameter_mod, only : MAX_EVENTS, MAX_BINS, MAX_EVENT_TYPES, MAX_CLOCKS use mpp_parameter_mod, only : MAXPES, EVENT_WAIT, EVENT_ALLREDUCE, EVENT_BROADCAST use mpp_parameter_mod, only : EVENT_ALLTOALL use mpp_parameter_mod, only : EVENT_TYPE_CREATE, EVENT_TYPE_FREE use mpp_parameter_mod, only : EVENT_RECV, EVENT_SEND, MPP_READY, MPP_WAIT use mpp_parameter_mod, only : mpp_parameter_version=>version use mpp_parameter_mod, only : DEFAULT_TAG use mpp_parameter_mod, only : COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4 use mpp_parameter_mod, only : COMM_TAG_5, COMM_TAG_6, COMM_TAG_7, COMM_TAG_8 use mpp_parameter_mod, only : COMM_TAG_9, COMM_TAG_10, COMM_TAG_11, COMM_TAG_12 use mpp_parameter_mod, only : COMM_TAG_13, COMM_TAG_14, COMM_TAG_15, COMM_TAG_16 use mpp_parameter_mod, only : COMM_TAG_17, COMM_TAG_18, COMM_TAG_19, COMM_TAG_20 use mpp_parameter_mod, only : MPP_FILL_INT,MPP_FILL_DOUBLE use mpp_data_mod, only : stat, mpp_stack, ptr_stack, status, ptr_status, sync, ptr_sync use mpp_data_mod, only : mpp_from_pe, ptr_from, remote_data_loc, ptr_remote use mpp_data_mod, only : mpp_data_version=>version implicit none private # 211 # 1 "/opt/cray/pe/mpich/8.1.9/ofi/intel/19.0/include/mpif.h" 1 ! /* -*- Mode: Fortran; -*- */ ! ! (C) 2001 by Argonne National Laboratory. ! See COPYRIGHT in top-level directory. ! ! DO NOT EDIT ! This file created by buildiface ! INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR PARAMETER (MPI_SOURCE=3,MPI_TAG=4,MPI_ERROR=5) INTEGER MPI_STATUS_SIZE PARAMETER (MPI_STATUS_SIZE=5) INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE) INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE,1) INTEGER MPI_ERRCODES_IGNORE(1) CHARACTER*1 MPI_ARGVS_NULL(1,1) CHARACTER*1 MPI_ARGV_NULL(1) INTEGER MPI_SUCCESS PARAMETER (MPI_SUCCESS=0) INTEGER MPI_ERR_DIMS PARAMETER (MPI_ERR_DIMS=11) INTEGER MPI_ERR_OP PARAMETER (MPI_ERR_OP=9) INTEGER MPI_ERR_QUOTA PARAMETER (MPI_ERR_QUOTA=39) INTEGER MPI_ERR_NAME PARAMETER (MPI_ERR_NAME=33) INTEGER MPI_ERR_RMA_FLAVOR PARAMETER (MPI_ERR_RMA_FLAVOR=58) INTEGER MPI_ERR_GROUP PARAMETER (MPI_ERR_GROUP=8) INTEGER MPI_ERR_ASSERT PARAMETER (MPI_ERR_ASSERT=53) INTEGER MPI_ERR_UNSUPPORTED_DATAREP PARAMETER (MPI_ERR_UNSUPPORTED_DATAREP=43) INTEGER MPI_ERR_INFO PARAMETER (MPI_ERR_INFO=28) INTEGER MPI_ERR_SIZE PARAMETER (MPI_ERR_SIZE=51) INTEGER MPI_ERR_RMA_CONFLICT PARAMETER (MPI_ERR_RMA_CONFLICT=49) INTEGER MPI_ERR_COUNT PARAMETER (MPI_ERR_COUNT=2) INTEGER MPI_ERR_NOT_SAME PARAMETER (MPI_ERR_NOT_SAME=35) INTEGER MPI_ERR_IO PARAMETER (MPI_ERR_IO=32) INTEGER MPI_ERR_NO_SPACE PARAMETER (MPI_ERR_NO_SPACE=36) INTEGER MPI_ERR_BUFFER PARAMETER (MPI_ERR_BUFFER=1) INTEGER MPI_ERR_PORT PARAMETER (MPI_ERR_PORT=38) INTEGER MPI_ERR_RMA_ATTACH PARAMETER (MPI_ERR_RMA_ATTACH=56) INTEGER MPI_ERR_NO_MEM PARAMETER (MPI_ERR_NO_MEM=34) INTEGER MPI_ERR_INFO_VALUE PARAMETER (MPI_ERR_INFO_VALUE=30) INTEGER MPI_ERR_IN_STATUS PARAMETER (MPI_ERR_IN_STATUS=17) INTEGER MPI_ERR_PENDING PARAMETER (MPI_ERR_PENDING=18) INTEGER MPI_ERR_RMA_RANGE PARAMETER (MPI_ERR_RMA_RANGE=55) INTEGER MPI_ERR_INFO_KEY PARAMETER (MPI_ERR_INFO_KEY=29) INTEGER MPI_ERR_FILE PARAMETER (MPI_ERR_FILE=27) INTEGER MPI_ERR_READ_ONLY PARAMETER (MPI_ERR_READ_ONLY=40) INTEGER MPI_ERR_REQUEST PARAMETER (MPI_ERR_REQUEST=19) INTEGER MPI_ERR_OTHER PARAMETER (MPI_ERR_OTHER=15) INTEGER MPI_ERR_TRUNCATE PARAMETER (MPI_ERR_TRUNCATE=14) INTEGER MPI_ERR_DISP PARAMETER (MPI_ERR_DISP=52) INTEGER MPI_ERR_SPAWN PARAMETER (MPI_ERR_SPAWN=42) INTEGER MPI_ERR_UNSUPPORTED_OPERATION PARAMETER (MPI_ERR_UNSUPPORTED_OPERATION=44) INTEGER MPI_ERR_UNKNOWN PARAMETER (MPI_ERR_UNKNOWN=13) INTEGER MPI_ERR_INTERN PARAMETER (MPI_ERR_INTERN=16) INTEGER MPI_ERR_AMODE PARAMETER (MPI_ERR_AMODE=21) INTEGER MPI_ERR_KEYVAL PARAMETER (MPI_ERR_KEYVAL=48) INTEGER MPI_ERR_ROOT PARAMETER (MPI_ERR_ROOT=7) INTEGER MPI_ERR_BAD_FILE PARAMETER (MPI_ERR_BAD_FILE=22) INTEGER MPI_ERR_TYPE PARAMETER (MPI_ERR_TYPE=3) INTEGER MPI_ERR_ARG PARAMETER (MPI_ERR_ARG=12) INTEGER MPI_ERR_TAG PARAMETER (MPI_ERR_TAG=4) INTEGER MPI_ERR_TOPOLOGY PARAMETER (MPI_ERR_TOPOLOGY=10) INTEGER MPI_ERR_RMA_SYNC PARAMETER (MPI_ERR_RMA_SYNC=50) INTEGER MPI_ERR_LOCKTYPE PARAMETER (MPI_ERR_LOCKTYPE=47) INTEGER MPI_ERR_DUP_DATAREP PARAMETER (MPI_ERR_DUP_DATAREP=24) INTEGER MPI_ERR_INFO_NOKEY PARAMETER (MPI_ERR_INFO_NOKEY=31) INTEGER MPI_ERR_CONVERSION PARAMETER (MPI_ERR_CONVERSION=23) INTEGER MPI_ERR_FILE_IN_USE PARAMETER (MPI_ERR_FILE_IN_USE=26) INTEGER MPI_ERR_SERVICE PARAMETER (MPI_ERR_SERVICE=41) INTEGER MPI_ERR_NO_SUCH_FILE PARAMETER (MPI_ERR_NO_SUCH_FILE=37) INTEGER MPI_ERR_FILE_EXISTS PARAMETER (MPI_ERR_FILE_EXISTS=25) INTEGER MPI_ERR_ACCESS PARAMETER (MPI_ERR_ACCESS=20) INTEGER MPI_ERR_RMA_SHARED PARAMETER (MPI_ERR_RMA_SHARED=57) INTEGER MPI_ERR_LASTCODE PARAMETER (MPI_ERR_LASTCODE=1073741823) INTEGER MPI_ERR_RANK PARAMETER (MPI_ERR_RANK=6) INTEGER MPI_ERR_COMM PARAMETER (MPI_ERR_COMM=5) INTEGER MPI_ERR_BASE PARAMETER (MPI_ERR_BASE=46) INTEGER MPI_ERR_WIN PARAMETER (MPI_ERR_WIN=45) INTEGER MPI_ERRORS_ARE_FATAL PARAMETER (MPI_ERRORS_ARE_FATAL=1409286144) INTEGER MPI_ERRORS_RETURN PARAMETER (MPI_ERRORS_RETURN=1409286145) INTEGER MPI_IDENT PARAMETER (MPI_IDENT=0) INTEGER MPI_CONGRUENT PARAMETER (MPI_CONGRUENT=1) INTEGER MPI_SIMILAR PARAMETER (MPI_SIMILAR=2) INTEGER MPI_UNEQUAL PARAMETER (MPI_UNEQUAL=3) INTEGER MPI_WIN_FLAVOR_CREATE PARAMETER (MPI_WIN_FLAVOR_CREATE=1) INTEGER MPI_WIN_FLAVOR_ALLOCATE PARAMETER (MPI_WIN_FLAVOR_ALLOCATE=2) INTEGER MPI_WIN_FLAVOR_DYNAMIC PARAMETER (MPI_WIN_FLAVOR_DYNAMIC=3) INTEGER MPI_WIN_FLAVOR_SHARED PARAMETER (MPI_WIN_FLAVOR_SHARED=4) INTEGER MPI_WIN_SEPARATE PARAMETER (MPI_WIN_SEPARATE=1) INTEGER MPI_WIN_UNIFIED PARAMETER (MPI_WIN_UNIFIED=2) INTEGER MPI_MAX PARAMETER (MPI_MAX=1476395009) INTEGER MPI_MIN PARAMETER (MPI_MIN=1476395010) INTEGER MPI_SUM PARAMETER (MPI_SUM=1476395011) INTEGER MPI_PROD PARAMETER (MPI_PROD=1476395012) INTEGER MPI_LAND PARAMETER (MPI_LAND=1476395013) INTEGER MPI_BAND PARAMETER (MPI_BAND=1476395014) INTEGER MPI_LOR PARAMETER (MPI_LOR=1476395015) INTEGER MPI_BOR PARAMETER (MPI_BOR=1476395016) INTEGER MPI_LXOR PARAMETER (MPI_LXOR=1476395017) INTEGER MPI_BXOR PARAMETER (MPI_BXOR=1476395018) INTEGER MPI_MINLOC PARAMETER (MPI_MINLOC=1476395019) INTEGER MPI_MAXLOC PARAMETER (MPI_MAXLOC=1476395020) INTEGER MPI_REPLACE PARAMETER (MPI_REPLACE=1476395021) INTEGER MPI_NO_OP PARAMETER (MPI_NO_OP=1476395022) INTEGER MPI_COMM_WORLD PARAMETER (MPI_COMM_WORLD=1140850688) INTEGER MPI_COMM_SELF PARAMETER (MPI_COMM_SELF=1140850689) INTEGER MPI_GROUP_EMPTY PARAMETER (MPI_GROUP_EMPTY=1207959552) INTEGER MPI_COMM_NULL PARAMETER (MPI_COMM_NULL=67108864) INTEGER MPI_WIN_NULL PARAMETER (MPI_WIN_NULL=536870912) INTEGER MPI_FILE_NULL PARAMETER (MPI_FILE_NULL=0) INTEGER MPI_GROUP_NULL PARAMETER (MPI_GROUP_NULL=134217728) INTEGER MPI_OP_NULL PARAMETER (MPI_OP_NULL=402653184) INTEGER MPI_DATATYPE_NULL PARAMETER (MPI_DATATYPE_NULL=201326592) INTEGER MPI_REQUEST_NULL PARAMETER (MPI_REQUEST_NULL=738197504) INTEGER MPI_ERRHANDLER_NULL PARAMETER (MPI_ERRHANDLER_NULL=335544320) INTEGER MPI_INFO_NULL PARAMETER (MPI_INFO_NULL=469762048) INTEGER MPI_INFO_ENV PARAMETER (MPI_INFO_ENV=1543503873) INTEGER MPI_TAG_UB PARAMETER (MPI_TAG_UB=1681915906) INTEGER MPI_HOST PARAMETER (MPI_HOST=1681915908) INTEGER MPI_IO PARAMETER (MPI_IO=1681915910) INTEGER MPI_WTIME_IS_GLOBAL PARAMETER (MPI_WTIME_IS_GLOBAL=1681915912) INTEGER MPI_UNIVERSE_SIZE PARAMETER (MPI_UNIVERSE_SIZE=1681915914) INTEGER MPI_LASTUSEDCODE PARAMETER (MPI_LASTUSEDCODE=1681915916) INTEGER MPI_APPNUM PARAMETER (MPI_APPNUM=1681915918) INTEGER MPI_WIN_BASE PARAMETER (MPI_WIN_BASE=1711276034) INTEGER MPI_WIN_SIZE PARAMETER (MPI_WIN_SIZE=1711276036) INTEGER MPI_WIN_DISP_UNIT PARAMETER (MPI_WIN_DISP_UNIT=1711276038) INTEGER MPI_WIN_CREATE_FLAVOR PARAMETER (MPI_WIN_CREATE_FLAVOR=1711276040) INTEGER MPI_WIN_MODEL PARAMETER (MPI_WIN_MODEL=1711276042) INTEGER MPI_MAX_ERROR_STRING PARAMETER (MPI_MAX_ERROR_STRING=512-1) INTEGER MPI_MAX_PORT_NAME PARAMETER (MPI_MAX_PORT_NAME=255) INTEGER MPI_MAX_OBJECT_NAME PARAMETER (MPI_MAX_OBJECT_NAME=127) INTEGER MPI_MAX_INFO_KEY PARAMETER (MPI_MAX_INFO_KEY=254) INTEGER MPI_MAX_INFO_VAL PARAMETER (MPI_MAX_INFO_VAL=1023) INTEGER MPI_MAX_PROCESSOR_NAME PARAMETER (MPI_MAX_PROCESSOR_NAME=128-1) INTEGER MPI_MAX_DATAREP_STRING PARAMETER (MPI_MAX_DATAREP_STRING=127) INTEGER MPI_MAX_LIBRARY_VERSION_STRING PARAMETER (MPI_MAX_LIBRARY_VERSION_STRING=8192-1) INTEGER MPI_UNDEFINED PARAMETER (MPI_UNDEFINED=(-32766)) INTEGER MPI_KEYVAL_INVALID PARAMETER (MPI_KEYVAL_INVALID=603979776) INTEGER MPI_BSEND_OVERHEAD PARAMETER (MPI_BSEND_OVERHEAD=96) INTEGER MPI_PROC_NULL PARAMETER (MPI_PROC_NULL=-1) INTEGER MPI_ANY_SOURCE PARAMETER (MPI_ANY_SOURCE=-2) INTEGER MPI_ANY_TAG PARAMETER (MPI_ANY_TAG=-1) INTEGER MPI_ROOT PARAMETER (MPI_ROOT=-3) INTEGER MPI_GRAPH PARAMETER (MPI_GRAPH=1) INTEGER MPI_CART PARAMETER (MPI_CART=2) INTEGER MPI_DIST_GRAPH PARAMETER (MPI_DIST_GRAPH=3) INTEGER MPI_VERSION PARAMETER (MPI_VERSION=3) INTEGER MPI_SUBVERSION PARAMETER (MPI_SUBVERSION=1) INTEGER MPI_LOCK_EXCLUSIVE PARAMETER (MPI_LOCK_EXCLUSIVE=234) INTEGER MPI_LOCK_SHARED PARAMETER (MPI_LOCK_SHARED=235) INTEGER MPI_COMPLEX PARAMETER (MPI_COMPLEX=1275070494) INTEGER MPI_DOUBLE_COMPLEX PARAMETER (MPI_DOUBLE_COMPLEX=1275072546) INTEGER MPI_LOGICAL PARAMETER (MPI_LOGICAL=1275069469) INTEGER MPI_REAL PARAMETER (MPI_REAL=1275069468) INTEGER MPI_DOUBLE_PRECISION PARAMETER (MPI_DOUBLE_PRECISION=1275070495) INTEGER MPI_INTEGER PARAMETER (MPI_INTEGER=1275069467) INTEGER MPI_2INTEGER PARAMETER (MPI_2INTEGER=1275070496) INTEGER MPI_2DOUBLE_PRECISION PARAMETER (MPI_2DOUBLE_PRECISION=1275072547) INTEGER MPI_2REAL PARAMETER (MPI_2REAL=1275070497) INTEGER MPI_CHARACTER PARAMETER (MPI_CHARACTER=1275068698) INTEGER MPI_BYTE PARAMETER (MPI_BYTE=1275068685) INTEGER MPI_UB PARAMETER (MPI_UB=1275068433) INTEGER MPI_LB PARAMETER (MPI_LB=1275068432) INTEGER MPI_PACKED PARAMETER (MPI_PACKED=1275068687) INTEGER MPI_INTEGER1 PARAMETER (MPI_INTEGER1=1275068717) INTEGER MPI_INTEGER2 PARAMETER (MPI_INTEGER2=1275068975) INTEGER MPI_INTEGER4 PARAMETER (MPI_INTEGER4=1275069488) INTEGER MPI_INTEGER8 PARAMETER (MPI_INTEGER8=1275070513) INTEGER MPI_INTEGER16 PARAMETER (MPI_INTEGER16=MPI_DATATYPE_NULL) INTEGER MPI_REAL4 PARAMETER (MPI_REAL4=1275069479) INTEGER MPI_REAL8 PARAMETER (MPI_REAL8=1275070505) INTEGER MPI_REAL16 PARAMETER (MPI_REAL16=1275072555) INTEGER MPI_COMPLEX8 PARAMETER (MPI_COMPLEX8=1275070504) INTEGER MPI_COMPLEX16 PARAMETER (MPI_COMPLEX16=1275072554) INTEGER MPI_COMPLEX32 PARAMETER (MPI_COMPLEX32=1275076652) INTEGER MPI_ADDRESS_KIND PARAMETER (MPI_ADDRESS_KIND=8) INTEGER MPI_OFFSET_KIND PARAMETER (MPI_OFFSET_KIND=8) INTEGER MPI_COUNT_KIND PARAMETER (MPI_COUNT_KIND=8) INTEGER MPI_INTEGER_KIND PARAMETER (MPI_INTEGER_KIND=4) INTEGER MPI_CHAR PARAMETER (MPI_CHAR=1275068673) INTEGER MPI_SIGNED_CHAR PARAMETER (MPI_SIGNED_CHAR=1275068696) INTEGER MPI_UNSIGNED_CHAR PARAMETER (MPI_UNSIGNED_CHAR=1275068674) INTEGER MPI_WCHAR PARAMETER (MPI_WCHAR=1275069454) INTEGER MPI_SHORT PARAMETER (MPI_SHORT=1275068931) INTEGER MPI_UNSIGNED_SHORT PARAMETER (MPI_UNSIGNED_SHORT=1275068932) INTEGER MPI_INT PARAMETER (MPI_INT=1275069445) INTEGER MPI_UNSIGNED PARAMETER (MPI_UNSIGNED=1275069446) INTEGER MPI_LONG PARAMETER (MPI_LONG=1275070471) INTEGER MPI_UNSIGNED_LONG PARAMETER (MPI_UNSIGNED_LONG=1275070472) INTEGER MPI_FLOAT PARAMETER (MPI_FLOAT=1275069450) INTEGER MPI_DOUBLE PARAMETER (MPI_DOUBLE=1275070475) INTEGER MPI_LONG_DOUBLE PARAMETER (MPI_LONG_DOUBLE=1275072524) INTEGER MPI_LONG_LONG_INT PARAMETER (MPI_LONG_LONG_INT=1275070473) INTEGER MPI_UNSIGNED_LONG_LONG PARAMETER (MPI_UNSIGNED_LONG_LONG=1275070489) INTEGER MPI_LONG_LONG PARAMETER (MPI_LONG_LONG=1275070473) INTEGER MPI_FLOAT_INT PARAMETER (MPI_FLOAT_INT=-1946157056) INTEGER MPI_DOUBLE_INT PARAMETER (MPI_DOUBLE_INT=-1946157055) INTEGER MPI_LONG_INT PARAMETER (MPI_LONG_INT=-1946157054) INTEGER MPI_SHORT_INT PARAMETER (MPI_SHORT_INT=-1946157053) INTEGER MPI_2INT PARAMETER (MPI_2INT=1275070486) INTEGER MPI_LONG_DOUBLE_INT PARAMETER (MPI_LONG_DOUBLE_INT=-1946157052) INTEGER MPI_INT8_T PARAMETER (MPI_INT8_T=1275068727) INTEGER MPI_INT16_T PARAMETER (MPI_INT16_T=1275068984) INTEGER MPI_INT32_T PARAMETER (MPI_INT32_T=1275069497) INTEGER MPI_INT64_T PARAMETER (MPI_INT64_T=1275070522) INTEGER MPI_UINT8_T PARAMETER (MPI_UINT8_T=1275068731) INTEGER MPI_UINT16_T PARAMETER (MPI_UINT16_T=1275068988) INTEGER MPI_UINT32_T PARAMETER (MPI_UINT32_T=1275069501) INTEGER MPI_UINT64_T PARAMETER (MPI_UINT64_T=1275070526) INTEGER MPI_C_BOOL PARAMETER (MPI_C_BOOL=1275068735) INTEGER MPI_C_FLOAT_COMPLEX PARAMETER (MPI_C_FLOAT_COMPLEX=1275070528) INTEGER MPI_C_COMPLEX PARAMETER (MPI_C_COMPLEX=1275070528) INTEGER MPI_C_DOUBLE_COMPLEX PARAMETER (MPI_C_DOUBLE_COMPLEX=1275072577) INTEGER MPI_C_LONG_DOUBLE_COMPLEX PARAMETER (MPI_C_LONG_DOUBLE_COMPLEX=1275076674) INTEGER MPI_AINT PARAMETER (MPI_AINT=1275070531) INTEGER MPI_OFFSET PARAMETER (MPI_OFFSET=1275070532) INTEGER MPI_COUNT PARAMETER (MPI_COUNT=1275070533) INTEGER MPI_CXX_BOOL PARAMETER (MPI_CXX_BOOL=MPI_DATATYPE_NULL) INTEGER MPI_CXX_FLOAT_COMPLEX PARAMETER (MPI_CXX_FLOAT_COMPLEX=MPI_DATATYPE_NULL) INTEGER MPI_CXX_DOUBLE_COMPLEX PARAMETER (MPI_CXX_DOUBLE_COMPLEX=MPI_DATATYPE_NULL) INTEGER MPI_CXX_LONG_DOUBLE_COMPLEX PARAMETER (MPI_CXX_LONG_DOUBLE_COMPLEX=MPI_DATATYPE_NULL) INTEGER MPI_COMBINER_NAMED PARAMETER (MPI_COMBINER_NAMED=1) INTEGER MPI_COMBINER_DUP PARAMETER (MPI_COMBINER_DUP=2) INTEGER MPI_COMBINER_CONTIGUOUS PARAMETER (MPI_COMBINER_CONTIGUOUS=3) INTEGER MPI_COMBINER_VECTOR PARAMETER (MPI_COMBINER_VECTOR=4) INTEGER MPI_COMBINER_HVECTOR_INTEGER PARAMETER (MPI_COMBINER_HVECTOR_INTEGER=5) INTEGER MPI_COMBINER_HVECTOR PARAMETER (MPI_COMBINER_HVECTOR=6) INTEGER MPI_COMBINER_INDEXED PARAMETER (MPI_COMBINER_INDEXED=7) INTEGER MPI_COMBINER_HINDEXED_INTEGER PARAMETER (MPI_COMBINER_HINDEXED_INTEGER=8) INTEGER MPI_COMBINER_HINDEXED PARAMETER (MPI_COMBINER_HINDEXED=9) INTEGER MPI_COMBINER_INDEXED_BLOCK PARAMETER (MPI_COMBINER_INDEXED_BLOCK=10) INTEGER MPI_COMBINER_STRUCT_INTEGER PARAMETER (MPI_COMBINER_STRUCT_INTEGER=11) INTEGER MPI_COMBINER_STRUCT PARAMETER (MPI_COMBINER_STRUCT=12) INTEGER MPI_COMBINER_SUBARRAY PARAMETER (MPI_COMBINER_SUBARRAY=13) INTEGER MPI_COMBINER_DARRAY PARAMETER (MPI_COMBINER_DARRAY=14) INTEGER MPI_COMBINER_F90_REAL PARAMETER (MPI_COMBINER_F90_REAL=15) INTEGER MPI_COMBINER_F90_COMPLEX PARAMETER (MPI_COMBINER_F90_COMPLEX=16) INTEGER MPI_COMBINER_F90_INTEGER PARAMETER (MPI_COMBINER_F90_INTEGER=17) INTEGER MPI_COMBINER_RESIZED PARAMETER (MPI_COMBINER_RESIZED=18) INTEGER MPI_COMBINER_HINDEXED_BLOCK PARAMETER (MPI_COMBINER_HINDEXED_BLOCK=19) INTEGER MPI_TYPECLASS_REAL PARAMETER (MPI_TYPECLASS_REAL=1) INTEGER MPI_TYPECLASS_INTEGER PARAMETER (MPI_TYPECLASS_INTEGER=2) INTEGER MPI_TYPECLASS_COMPLEX PARAMETER (MPI_TYPECLASS_COMPLEX=3) INTEGER MPI_MODE_NOCHECK PARAMETER (MPI_MODE_NOCHECK=1024) INTEGER MPI_MODE_NOSTORE PARAMETER (MPI_MODE_NOSTORE=2048) INTEGER MPI_MODE_NOPUT PARAMETER (MPI_MODE_NOPUT=4096) INTEGER MPI_MODE_NOPRECEDE PARAMETER (MPI_MODE_NOPRECEDE=8192) INTEGER MPI_MODE_NOSUCCEED PARAMETER (MPI_MODE_NOSUCCEED=16384) INTEGER MPI_COMM_TYPE_SHARED PARAMETER (MPI_COMM_TYPE_SHARED=1) INTEGER MPI_MESSAGE_NULL PARAMETER (MPI_MESSAGE_NULL=738197504) INTEGER MPI_MESSAGE_NO_PROC PARAMETER (MPI_MESSAGE_NO_PROC=1811939328) INTEGER MPI_THREAD_SINGLE PARAMETER (MPI_THREAD_SINGLE=0) INTEGER MPI_THREAD_FUNNELED PARAMETER (MPI_THREAD_FUNNELED=1) INTEGER MPI_THREAD_SERIALIZED PARAMETER (MPI_THREAD_SERIALIZED=2) INTEGER MPI_THREAD_MULTIPLE PARAMETER (MPI_THREAD_MULTIPLE=3) INTEGER MPI_MODE_RDONLY PARAMETER (MPI_MODE_RDONLY=2) INTEGER MPI_MODE_RDWR PARAMETER (MPI_MODE_RDWR=8) INTEGER MPI_MODE_WRONLY PARAMETER (MPI_MODE_WRONLY=4) INTEGER MPI_MODE_DELETE_ON_CLOSE PARAMETER (MPI_MODE_DELETE_ON_CLOSE=16) INTEGER MPI_MODE_UNIQUE_OPEN PARAMETER (MPI_MODE_UNIQUE_OPEN=32) INTEGER MPI_MODE_CREATE PARAMETER (MPI_MODE_CREATE=1) INTEGER MPI_MODE_EXCL PARAMETER (MPI_MODE_EXCL=64) INTEGER MPI_MODE_APPEND PARAMETER (MPI_MODE_APPEND=128) INTEGER MPI_MODE_SEQUENTIAL PARAMETER (MPI_MODE_SEQUENTIAL=256) INTEGER MPI_SEEK_SET PARAMETER (MPI_SEEK_SET=600) INTEGER MPI_SEEK_CUR PARAMETER (MPI_SEEK_CUR=602) INTEGER MPI_SEEK_END PARAMETER (MPI_SEEK_END=604) INTEGER MPI_ORDER_C PARAMETER (MPI_ORDER_C=56) INTEGER MPI_ORDER_FORTRAN PARAMETER (MPI_ORDER_FORTRAN=57) INTEGER MPI_DISTRIBUTE_BLOCK PARAMETER (MPI_DISTRIBUTE_BLOCK=121) INTEGER MPI_DISTRIBUTE_CYCLIC PARAMETER (MPI_DISTRIBUTE_CYCLIC=122) INTEGER MPI_DISTRIBUTE_NONE PARAMETER (MPI_DISTRIBUTE_NONE=123) INTEGER MPI_DISTRIBUTE_DFLT_DARG PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767) integer*8 MPI_DISPLACEMENT_CURRENT PARAMETER (MPI_DISPLACEMENT_CURRENT=-54278278) LOGICAL MPI_SUBARRAYS_SUPPORTED PARAMETER(MPI_SUBARRAYS_SUPPORTED=.FALSE.) LOGICAL MPI_ASYNC_PROTECTS_NONBLOCKING PARAMETER(MPI_ASYNC_PROTECTS_NONBLOCKING=.FALSE.) INTEGER MPI_BOTTOM, MPI_IN_PLACE, MPI_UNWEIGHTED INTEGER MPI_WEIGHTS_EMPTY EXTERNAL MPI_DUP_FN, MPI_NULL_DELETE_FN, MPI_NULL_COPY_FN EXTERNAL MPI_WTIME, MPI_WTICK EXTERNAL PMPI_WTIME, PMPI_WTICK EXTERNAL MPI_COMM_DUP_FN, MPI_COMM_NULL_DELETE_FN EXTERNAL MPI_COMM_NULL_COPY_FN EXTERNAL MPI_WIN_DUP_FN, MPI_WIN_NULL_DELETE_FN EXTERNAL MPI_WIN_NULL_COPY_FN EXTERNAL MPI_TYPE_DUP_FN, MPI_TYPE_NULL_DELETE_FN EXTERNAL MPI_TYPE_NULL_COPY_FN EXTERNAL MPI_CONVERSION_FN_NULL REAL*8 MPI_WTIME, MPI_WTICK REAL*8 PMPI_WTIME, PMPI_WTICK COMMON /MPIFCMB5/ MPI_UNWEIGHTED COMMON /MPIFCMB9/ MPI_WEIGHTS_EMPTY SAVE /MPIFCMB5/ SAVE /MPIFCMB9/ COMMON /MPIPRIV1/ MPI_BOTTOM, MPI_IN_PLACE, MPI_STATUS_IGNORE COMMON /MPIPRIV2/ MPI_STATUSES_IGNORE, MPI_ERRCODES_IGNORE SAVE /MPIPRIV1/,/MPIPRIV2/ COMMON /MPIPRIVC/ MPI_ARGVS_NULL, MPI_ARGV_NULL SAVE /MPIPRIVC/ # 215 "../mpp/mpp.F90" 2 !sgi_mipspro gets this from 'use mpi' !--- public paramters ----------------------------------------------- public :: MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, NOTE, WARNING, FATAL public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT public :: CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA public :: MAXPES, EVENT_RECV, EVENT_SEND, INPUT_STR_LENGTH public :: COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4 public :: COMM_TAG_5, COMM_TAG_6, COMM_TAG_7, COMM_TAG_8 public :: COMM_TAG_9, COMM_TAG_10, COMM_TAG_11, COMM_TAG_12 public :: COMM_TAG_13, COMM_TAG_14, COMM_TAG_15, COMM_TAG_16 public :: COMM_TAG_17, COMM_TAG_18, COMM_TAG_19, COMM_TAG_20 public :: MPP_FILL_INT,MPP_FILL_DOUBLE !--- public data from mpp_data_mod ------------------------------ ! public :: request !--- public interface from mpp_util.h ------------------------------ public :: stdin, stdout, stderr, stdlog, lowercase, uppercase, mpp_error, mpp_error_state public :: mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, mpp_pe public :: mpp_node, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist public :: mpp_get_current_pelist, mpp_set_current_pelist, mpp_get_current_pelist_name public :: mpp_clock_id, mpp_clock_set_grain, mpp_record_timing_data, get_unit public :: read_ascii_file, read_input_nml, mpp_clock_begin, mpp_clock_end public :: get_ascii_file_num_lines public :: mpp_record_time_start, mpp_record_time_end !--- public interface from mpp_comm.h ------------------------------ public :: mpp_chksum, mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv public :: mpp_sum_ad public :: mpp_broadcast, mpp_malloc, mpp_init, mpp_exit public :: mpp_gather, mpp_scatter, mpp_alltoall public :: mpp_type, mpp_byte, mpp_type_create, mpp_type_free # 251 !********************************************************************* ! ! public data type ! !********************************************************************* !peset hold communicators as SHMEM-compatible triads (start, log2(stride), num) type :: communicator private character(len=32) :: name integer, pointer :: list(:) =>NULL() integer :: count integer :: start, log2stride ! dummy variables when libMPI is defined. integer :: id, group ! MPI communicator and group id for this PE set. ! dummy variables when libSMA is defined. end type communicator type :: event private character(len=16) :: name integer(8), dimension(MAX_EVENTS) :: ticks, bytes integer :: calls end type event !a clock contains an array of event profiles for a region type :: clock private character(len=32) :: name integer(8) :: tick integer(8) :: total_ticks integer :: peset_num logical :: sync_on_begin, detailed integer :: grain type(event), pointer :: events(:) =>NULL() !if needed, allocate to MAX_EVENT_TYPES logical :: is_on !initialize to false. set true when calling mpp_clock_begin ! set false when calling mpp_clock_end end type clock type :: Clock_Data_Summary private character(len=16) :: name real(8) :: msg_size_sums(MAX_BINS) real(8) :: msg_time_sums(MAX_BINS) real(8) :: total_data real(8) :: total_time integer(8) :: msg_size_cnts(MAX_BINS) integer(8) :: total_cnts end type Clock_Data_Summary type :: Summary_Struct private character(len=16) :: name type (Clock_Data_Summary) :: event(MAX_EVENT_TYPES) end type Summary_Struct ! Data types for generalized data transfer (e.g. MPI_Type) type :: mpp_type private integer :: counter ! Number of instances of this type integer :: ndims integer, allocatable :: sizes(:) integer, allocatable :: subsizes(:) integer, allocatable :: starts(:) integer :: etype ! Elementary data type (e.g. MPI_BYTE) integer :: id ! Identifier within message passing library (e.g. MPI) type(mpp_type), pointer :: prev => null() type(mpp_type), pointer :: next => null() end type mpp_type ! Persisent elements for linked list interaction type :: mpp_type_list private type(mpp_type), pointer :: head => null() type(mpp_type), pointer :: tail => null() integer :: length end type mpp_type_list !*********************************************************************** ! ! public interface from mpp_util.h ! !*********************************************************************** ! ! ! Error handler. ! ! ! It is strongly recommended that all error exits pass through ! mpp_error to assure the program fails cleanly. An individual ! PE encountering a STOP statement, for instance, can cause the ! program to hang. The use of the STOP statement is strongly ! discouraged. ! ! Calling mpp_error with no arguments produces an immediate error ! exit, i.e: !
!    call mpp_error
!    call mpp_error(FATAL)
!    
! are equivalent. ! ! The argument order !
!    call mpp_error( routine, errormsg, errortype )
!    
! is also provided to support legacy code. In this version of the ! call, none of the arguments may be omitted. ! ! The behaviour of mpp_error for a WARNING can be ! controlled with an additional call mpp_set_warn_level. !
!    call mpp_set_warn_level(ERROR)
!    
! causes mpp_error to treat WARNING ! exactly like FATAL. !
!    call mpp_set_warn_level(WARNING)
!    
! resets to the default behaviour described above. ! ! mpp_error also has an internal error state which ! maintains knowledge of whether a warning has been issued. This can be ! used at startup in a subroutine that checks if the model has been ! properly configured. You can generate a series of warnings using ! mpp_error, and then check at the end if any warnings has been ! issued using the function mpp_error_state(). If the value of ! this is WARNING, at least one warning has been issued, and ! the user can take appropriate action: ! !
!    if( ... )call mpp_error( WARNING, '...' )
!    if( ... )call mpp_error( WARNING, '...' )
!    if( ... )call mpp_error( WARNING, '...' )
!    ...
!    if( mpp_error_state().EQ.WARNING )call mpp_error( FATAL, '...' )
!    
!
! ! ! One of NOTE, WARNING or FATAL ! (these definitions are acquired by use association). ! NOTE writes errormsg to STDOUT. ! WARNING writes errormsg to STDERR. ! FATAL writes errormsg to STDERR, ! and induces a clean error exit with a call stack traceback. ! !
interface mpp_error module procedure mpp_error_basic module procedure mpp_error_mesg module procedure mpp_error_noargs module procedure mpp_error_is module procedure mpp_error_rs module procedure mpp_error_ia module procedure mpp_error_ra module procedure mpp_error_ia_ia module procedure mpp_error_ia_ra module procedure mpp_error_ra_ia module procedure mpp_error_ra_ra module procedure mpp_error_ia_is module procedure mpp_error_ia_rs module procedure mpp_error_ra_is module procedure mpp_error_ra_rs module procedure mpp_error_is_ia module procedure mpp_error_is_ra module procedure mpp_error_rs_ia module procedure mpp_error_rs_ra module procedure mpp_error_is_is module procedure mpp_error_is_rs module procedure mpp_error_rs_is module procedure mpp_error_rs_rs end interface interface array_to_char module procedure iarray_to_char module procedure rarray_to_char end interface !*********************************************************************** ! ! public interface from mpp_comm.h ! !*********************************************************************** # 445 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ROUTINES TO INITIALIZE/FINALIZE MPP MODULE: mpp_init, mpp_exit ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Initialize mpp_mod. ! ! ! Called to initialize the mpp_mod package. It is recommended ! that this call be the first executed line in your program. It sets the ! number of PEs assigned to this run (acquired from the command line, or ! through the environment variable NPES), and associates an ID ! number to each PE. These can be accessed by calling mpp_npes and mpp_pe. ! ! ! ! flags can be set to MPP_VERBOSE to ! have mpp_mod keep you informed of what it's up to. ! ! ! ! ! Exit mpp_mod. ! ! ! Called at the end of the run, or to re-initialize mpp_mod, ! should you require that for some odd reason. ! ! This call implies synchronization across all PEs. ! ! ! !####################################################################### ! ! ! Symmetric memory allocation. ! ! ! This routine is used on SGI systems when mpp_mod is ! invoked in the SHMEM library. It ensures that dynamically allocated ! memory can be used with shmem_get and ! shmem_put. This is called symmetric ! allocation and is described in the ! intro_shmem man page. ptr is a Cray ! pointer (see the section on portability). The operation can be expensive ! (since it requires a global barrier). We therefore attempt to re-use ! existing allocation whenever possible. Therefore len ! and ptr must have the SAVE attribute ! in the calling routine, and retain the information about the last call ! to mpp_malloc. Additional memory is symmetrically ! allocated if and only if newlen exceeds ! len. ! ! This is never required on Cray PVP or MPP systems. While the T3E ! manpages do talk about symmetric allocation, mpp_mod ! is coded to remove this restriction. ! ! It is never required if mpp_mod is invoked in MPI. ! ! This call implies synchronization across all PEs. ! ! ! ! a cray pointer, points to a dummy argument in this routine. ! ! ! the required allocation length for the pointer ptr ! ! ! the current allocation (0 if unallocated). ! ! !##################################################################### ! ! ! Allocate module internal workspace. ! ! ! mpp_mod maintains a private internal array called ! mpp_stack for private workspace. This call sets the length, ! in words, of this array. ! ! The mpp_init call sets this ! workspace length to a default of 32768, and this call may be used if a ! longer workspace is needed. ! ! This call implies synchronization across all PEs. ! ! This workspace is symmetrically allocated, as required for ! efficient communication on SGI and Cray MPP systems. Since symmetric ! allocation must be performed by all PEs in a job, this call ! must also be called by all PEs, using the same value of ! n. Calling mpp_set_stack_size from a subset of PEs, ! or with unequal argument n, may cause the program to hang. ! ! If any MPP call using mpp_stack overflows the declared ! stack array, the program will abort with a message specifying the ! stack length that is required. Many users wonder why, if the required ! stack length can be computed, it cannot also be specified at that ! point. This cannot be automated because there is no way for the ! program to know if all PEs are present at that call, and with equal ! values of n. The program must be rerun by the user with the ! correct argument to mpp_set_stack_size, called at an ! appropriate point in the code where all PEs are known to be present. ! ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! DATA TRANSFER TYPES: mpp_type_create ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! interface mpp_type_create module procedure mpp_type_create_int4 module procedure mpp_type_create_int8 module procedure mpp_type_create_real4 module procedure mpp_type_create_real8 module procedure mpp_type_create_logical4 module procedure mpp_type_create_logical8 end interface mpp_type_create !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! GLOBAL REDUCTION ROUTINES: mpp_max, mpp_sum, mpp_min ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Reduction operations. ! ! ! Find the max of scalar a the PEs in pelist ! result is also automatically broadcast to all PEs ! ! ! ! real or integer, of 4-byte of 8-byte kind. ! ! ! If pelist is omitted, the context is assumed to be the ! current pelist. This call implies synchronization across the PEs in ! pelist, or the current pelist if pelist is absent. ! ! interface mpp_max module procedure mpp_max_real8_0d module procedure mpp_max_real8_1d module procedure mpp_max_int8_0d module procedure mpp_max_int8_1d module procedure mpp_max_real4_0d module procedure mpp_max_real4_1d module procedure mpp_max_int4_0d module procedure mpp_max_int4_1d end interface interface mpp_min module procedure mpp_min_real8_0d module procedure mpp_min_real8_1d module procedure mpp_min_int8_0d module procedure mpp_min_int8_1d module procedure mpp_min_real4_0d module procedure mpp_min_real4_1d module procedure mpp_min_int4_0d module procedure mpp_min_int4_1d end interface ! ! ! Reduction operation. ! ! ! MPP_TYPE_ corresponds to any 4-byte and 8-byte variant of ! integer, real, complex variables, of rank 0 or 1. A ! contiguous block from a multi-dimensional array may be passed by its ! starting address and its length, as in f77. ! ! Library reduction operators are not required or guaranteed to be ! bit-reproducible. In any case, changing the processor count changes ! the data layout, and thus very likely the order of operations. For ! bit-reproducible sums of distributed arrays, consider using the ! mpp_global_sum routine provided by the mpp_domains module. ! ! The bit_reproducible flag provided in earlier versions of ! this routine has been removed. ! ! ! If pelist is omitted, the context is assumed to be the ! current pelist. This call implies synchronization across the PEs in ! pelist, or the current pelist if pelist is absent. ! ! ! ! ! ! interface mpp_sum module procedure mpp_sum_int8 module procedure mpp_sum_int8_scalar module procedure mpp_sum_int8_2d module procedure mpp_sum_int8_3d module procedure mpp_sum_int8_4d module procedure mpp_sum_int8_5d module procedure mpp_sum_real8 module procedure mpp_sum_real8_scalar module procedure mpp_sum_real8_2d module procedure mpp_sum_real8_3d module procedure mpp_sum_real8_4d module procedure mpp_sum_real8_5d # 702 module procedure mpp_sum_int4 module procedure mpp_sum_int4_scalar module procedure mpp_sum_int4_2d module procedure mpp_sum_int4_3d module procedure mpp_sum_int4_4d module procedure mpp_sum_int4_5d module procedure mpp_sum_real4 module procedure mpp_sum_real4_scalar module procedure mpp_sum_real4_2d module procedure mpp_sum_real4_3d module procedure mpp_sum_real4_4d module procedure mpp_sum_real4_5d # 724 end interface interface mpp_sum_ad module procedure mpp_sum_int8_ad module procedure mpp_sum_int8_scalar_ad module procedure mpp_sum_int8_2d_ad module procedure mpp_sum_int8_3d_ad module procedure mpp_sum_int8_4d_ad module procedure mpp_sum_int8_5d_ad module procedure mpp_sum_real8_ad module procedure mpp_sum_real8_scalar_ad module procedure mpp_sum_real8_2d_ad module procedure mpp_sum_real8_3d_ad module procedure mpp_sum_real8_4d_ad module procedure mpp_sum_real8_5d_ad # 749 module procedure mpp_sum_int4_ad module procedure mpp_sum_int4_scalar_ad module procedure mpp_sum_int4_2d_ad module procedure mpp_sum_int4_3d_ad module procedure mpp_sum_int4_4d_ad module procedure mpp_sum_int4_5d_ad module procedure mpp_sum_real4_ad module procedure mpp_sum_real4_scalar_ad module procedure mpp_sum_real4_2d_ad module procedure mpp_sum_real4_3d_ad module procedure mpp_sum_real4_4d_ad module procedure mpp_sum_real4_5d_ad # 771 end interface !##################################################################### ! ! ! gather information onto root pe. ! ! interface mpp_gather module procedure mpp_gather_logical_1d module procedure mpp_gather_int4_1d module procedure mpp_gather_real4_1d module procedure mpp_gather_real8_1d module procedure mpp_gather_logical_1dv module procedure mpp_gather_int4_1dv module procedure mpp_gather_real4_1dv module procedure mpp_gather_real8_1dv module procedure mpp_gather_pelist_logical_2d module procedure mpp_gather_pelist_logical_3d module procedure mpp_gather_pelist_int4_2d module procedure mpp_gather_pelist_int4_3d module procedure mpp_gather_pelist_real4_2d module procedure mpp_gather_pelist_real4_3d module procedure mpp_gather_pelist_real8_2d module procedure mpp_gather_pelist_real8_3d end interface !##################################################################### ! ! ! gather information onto root pe. ! ! interface mpp_scatter module procedure mpp_scatter_pelist_int4_2d module procedure mpp_scatter_pelist_int4_3d module procedure mpp_scatter_pelist_real4_2d module procedure mpp_scatter_pelist_real4_3d module procedure mpp_scatter_pelist_real8_2d module procedure mpp_scatter_pelist_real8_3d end interface !##################################################################### ! ! ! scatter a vector across all PEs ! (e.g. transpose the vector and PE index) ! ! interface mpp_alltoall module procedure mpp_alltoall_int4 module procedure mpp_alltoall_int8 module procedure mpp_alltoall_real4 module procedure mpp_alltoall_real8 module procedure mpp_alltoall_logical4 module procedure mpp_alltoall_logical8 module procedure mpp_alltoall_int4_v module procedure mpp_alltoall_int8_v module procedure mpp_alltoall_real4_v module procedure mpp_alltoall_real8_v module procedure mpp_alltoall_logical4_v module procedure mpp_alltoall_logical8_v module procedure mpp_alltoall_int4_w module procedure mpp_alltoall_int8_w module procedure mpp_alltoall_real4_w module procedure mpp_alltoall_real8_w module procedure mpp_alltoall_logical4_w module procedure mpp_alltoall_logical8_w end interface !##################################################################### ! ! ! Basic message-passing call. ! ! ! MPP_TYPE_ corresponds to any 4-byte and 8-byte variant of ! integer, real, complex, logical variables, of rank 0 or 1. A ! contiguous block from a multi-dimensional array may be passed by its ! starting address and its length, as in f77. ! ! mpp_transmit is currently implemented as asynchronous ! outward transmission and synchronous inward transmission. This follows ! the behaviour of shmem_put and shmem_get. In MPI, it ! is implemented as mpi_isend and mpi_recv. For most ! applications, transmissions occur in pairs, and are here accomplished ! in a single call. ! ! The special PE designations NULL_PE, ! ANY_PE and ALL_PES are provided by use ! association. ! ! NULL_PE: is used to disable one of the pair of ! transmissions.
! ANY_PE: is used for unspecific remote ! destination. (Please note that put_pe=ANY_PE has no meaning ! in the MPI context, though it is available in the SHMEM invocation. If ! portability is a concern, it is best avoided).
! ALL_PES: is used for broadcast operations. ! ! It is recommended that mpp_broadcast be used for ! broadcasts. ! ! The following example illustrates the use of ! NULL_PE and ALL_PES: ! !
!    real, dimension(n) :: a
!    if( pe.EQ.0 )then
!        do p = 1,npes-1
!           call mpp_transmit( a, n, p, a, n, NULL_PE )
!        end do
!    else
!        call mpp_transmit( a, n, NULL_PE, a, n, 0 )
!    end if
!
!    call mpp_transmit( a, n, ALL_PES, a, n, 0 )
!    
! ! The do loop and the broadcast operation above are equivalent. ! ! Two overloaded calls mpp_send and ! mpp_recv have also been ! provided. mpp_send calls mpp_transmit ! with get_pe=NULL_PE. mpp_recv calls ! mpp_transmit with put_pe=NULL_PE. Thus ! the do loop above could be written more succinctly: ! !
!    if( pe.EQ.0 )then
!        do p = 1,npes-1
!           call mpp_send( a, n, p )
!        end do
!    else
!        call mpp_recv( a, n, 0 )
!    end if
!    
!
! !
interface mpp_transmit module procedure mpp_transmit_real8 module procedure mpp_transmit_real8_scalar module procedure mpp_transmit_real8_2d module procedure mpp_transmit_real8_3d module procedure mpp_transmit_real8_4d module procedure mpp_transmit_real8_5d # 931 module procedure mpp_transmit_int8 module procedure mpp_transmit_int8_scalar module procedure mpp_transmit_int8_2d module procedure mpp_transmit_int8_3d module procedure mpp_transmit_int8_4d module procedure mpp_transmit_int8_5d module procedure mpp_transmit_logical8 module procedure mpp_transmit_logical8_scalar module procedure mpp_transmit_logical8_2d module procedure mpp_transmit_logical8_3d module procedure mpp_transmit_logical8_4d module procedure mpp_transmit_logical8_5d module procedure mpp_transmit_real4 module procedure mpp_transmit_real4_scalar module procedure mpp_transmit_real4_2d module procedure mpp_transmit_real4_3d module procedure mpp_transmit_real4_4d module procedure mpp_transmit_real4_5d # 961 module procedure mpp_transmit_int4 module procedure mpp_transmit_int4_scalar module procedure mpp_transmit_int4_2d module procedure mpp_transmit_int4_3d module procedure mpp_transmit_int4_4d module procedure mpp_transmit_int4_5d module procedure mpp_transmit_logical4 module procedure mpp_transmit_logical4_scalar module procedure mpp_transmit_logical4_2d module procedure mpp_transmit_logical4_3d module procedure mpp_transmit_logical4_4d module procedure mpp_transmit_logical4_5d end interface interface mpp_recv module procedure mpp_recv_real8 module procedure mpp_recv_real8_scalar module procedure mpp_recv_real8_2d module procedure mpp_recv_real8_3d module procedure mpp_recv_real8_4d module procedure mpp_recv_real8_5d # 989 module procedure mpp_recv_int8 module procedure mpp_recv_int8_scalar module procedure mpp_recv_int8_2d module procedure mpp_recv_int8_3d module procedure mpp_recv_int8_4d module procedure mpp_recv_int8_5d module procedure mpp_recv_logical8 module procedure mpp_recv_logical8_scalar module procedure mpp_recv_logical8_2d module procedure mpp_recv_logical8_3d module procedure mpp_recv_logical8_4d module procedure mpp_recv_logical8_5d module procedure mpp_recv_real4 module procedure mpp_recv_real4_scalar module procedure mpp_recv_real4_2d module procedure mpp_recv_real4_3d module procedure mpp_recv_real4_4d module procedure mpp_recv_real4_5d # 1019 module procedure mpp_recv_int4 module procedure mpp_recv_int4_scalar module procedure mpp_recv_int4_2d module procedure mpp_recv_int4_3d module procedure mpp_recv_int4_4d module procedure mpp_recv_int4_5d module procedure mpp_recv_logical4 module procedure mpp_recv_logical4_scalar module procedure mpp_recv_logical4_2d module procedure mpp_recv_logical4_3d module procedure mpp_recv_logical4_4d module procedure mpp_recv_logical4_5d end interface interface mpp_send module procedure mpp_send_real8 module procedure mpp_send_real8_scalar module procedure mpp_send_real8_2d module procedure mpp_send_real8_3d module procedure mpp_send_real8_4d module procedure mpp_send_real8_5d # 1047 module procedure mpp_send_int8 module procedure mpp_send_int8_scalar module procedure mpp_send_int8_2d module procedure mpp_send_int8_3d module procedure mpp_send_int8_4d module procedure mpp_send_int8_5d module procedure mpp_send_logical8 module procedure mpp_send_logical8_scalar module procedure mpp_send_logical8_2d module procedure mpp_send_logical8_3d module procedure mpp_send_logical8_4d module procedure mpp_send_logical8_5d module procedure mpp_send_real4 module procedure mpp_send_real4_scalar module procedure mpp_send_real4_2d module procedure mpp_send_real4_3d module procedure mpp_send_real4_4d module procedure mpp_send_real4_5d # 1077 module procedure mpp_send_int4 module procedure mpp_send_int4_scalar module procedure mpp_send_int4_2d module procedure mpp_send_int4_3d module procedure mpp_send_int4_4d module procedure mpp_send_int4_5d module procedure mpp_send_logical4 module procedure mpp_send_logical4_scalar module procedure mpp_send_logical4_2d module procedure mpp_send_logical4_3d module procedure mpp_send_logical4_4d module procedure mpp_send_logical4_5d end interface ! ! ! Parallel broadcasts. ! ! ! The mpp_broadcast call has been added because the original ! syntax (using ALL_PES in mpp_transmit) did not ! support a broadcast across a pelist. ! ! MPP_TYPE_ corresponds to any 4-byte and 8-byte variant of ! integer, real, complex, logical variables, of rank 0 or 1. A ! contiguous block from a multi-dimensional array may be passed by its ! starting address and its length, as in f77. ! ! Global broadcasts through the ALL_PES argument to mpp_transmit are still provided for ! backward-compatibility. ! ! If pelist is omitted, the context is assumed to be the ! current pelist. from_pe must belong to the current ! pelist. This call implies synchronization across the PEs in ! pelist, or the current pelist if pelist is absent. ! ! ! ! ! ! ! interface mpp_broadcast module procedure mpp_broadcast_char module procedure mpp_broadcast_real8 module procedure mpp_broadcast_real8_scalar module procedure mpp_broadcast_real8_2d module procedure mpp_broadcast_real8_3d module procedure mpp_broadcast_real8_4d module procedure mpp_broadcast_real8_5d # 1139 module procedure mpp_broadcast_int8 module procedure mpp_broadcast_int8_scalar module procedure mpp_broadcast_int8_2d module procedure mpp_broadcast_int8_3d module procedure mpp_broadcast_int8_4d module procedure mpp_broadcast_int8_5d module procedure mpp_broadcast_logical8 module procedure mpp_broadcast_logical8_scalar module procedure mpp_broadcast_logical8_2d module procedure mpp_broadcast_logical8_3d module procedure mpp_broadcast_logical8_4d module procedure mpp_broadcast_logical8_5d module procedure mpp_broadcast_real4 module procedure mpp_broadcast_real4_scalar module procedure mpp_broadcast_real4_2d module procedure mpp_broadcast_real4_3d module procedure mpp_broadcast_real4_4d module procedure mpp_broadcast_real4_5d # 1169 module procedure mpp_broadcast_int4 module procedure mpp_broadcast_int4_scalar module procedure mpp_broadcast_int4_2d module procedure mpp_broadcast_int4_3d module procedure mpp_broadcast_int4_4d module procedure mpp_broadcast_int4_5d module procedure mpp_broadcast_logical4 module procedure mpp_broadcast_logical4_scalar module procedure mpp_broadcast_logical4_2d module procedure mpp_broadcast_logical4_3d module procedure mpp_broadcast_logical4_4d module procedure mpp_broadcast_logical4_5d end interface !##################################################################### ! ! ! Parallel checksums. ! ! ! mpp_chksum is a parallel checksum routine that returns an ! identical answer for the same array irrespective of how it has been ! partitioned across processors. 8is the KIND ! parameter corresponding to long integers (see discussion on ! OS-dependent preprocessor directives) defined in ! the header file fms_platform.h. MPP_TYPE_ corresponds to any ! 4-byte and 8-byte variant of integer, real, complex, logical ! variables, of rank 0 to 5. ! ! Integer checksums on FP data use the F90 TRANSFER() ! intrinsic. ! ! The serial checksum module is superseded ! by this function, and is no longer being actively maintained. This ! provides identical results on a single-processor job, and to perform ! serial checksums on a single processor of a parallel job, you only ! need to use the optional pelist argument. !
!     use mpp_mod
!     integer :: pe, chksum
!     real :: a(:)
!     pe = mpp_pe()
!     chksum = mpp_chksum( a, (/pe/) )
!     
! ! The additional functionality of mpp_chksum over ! serial checksums is to compute the checksum across the PEs in ! pelist. The answer is guaranteed to be the same for ! the same distributed array irrespective of how it has been ! partitioned. ! ! If pelist is omitted, the context is assumed to be the ! current pelist. This call implies synchronization across the PEs in ! pelist, or the current pelist if pelist is absent. !
! ! ! !
interface mpp_chksum module procedure mpp_chksum_i8_1d module procedure mpp_chksum_i8_2d module procedure mpp_chksum_i8_3d module procedure mpp_chksum_i8_4d module procedure mpp_chksum_i8_5d module procedure mpp_chksum_i8_1d_rmask module procedure mpp_chksum_i8_2d_rmask module procedure mpp_chksum_i8_3d_rmask module procedure mpp_chksum_i8_4d_rmask module procedure mpp_chksum_i8_5d_rmask module procedure mpp_chksum_i4_1d module procedure mpp_chksum_i4_2d module procedure mpp_chksum_i4_3d module procedure mpp_chksum_i4_4d module procedure mpp_chksum_i4_5d module procedure mpp_chksum_i4_1d_rmask module procedure mpp_chksum_i4_2d_rmask module procedure mpp_chksum_i4_3d_rmask module procedure mpp_chksum_i4_4d_rmask module procedure mpp_chksum_i4_5d_rmask module procedure mpp_chksum_r8_0d module procedure mpp_chksum_r8_1d module procedure mpp_chksum_r8_2d module procedure mpp_chksum_r8_3d module procedure mpp_chksum_r8_4d module procedure mpp_chksum_r8_5d # 1269 module procedure mpp_chksum_r4_0d module procedure mpp_chksum_r4_1d module procedure mpp_chksum_r4_2d module procedure mpp_chksum_r4_3d module procedure mpp_chksum_r4_4d module procedure mpp_chksum_r4_5d # 1285 end interface !*********************************************************************** ! ! module variables ! !*********************************************************************** integer, parameter :: PESET_MAX = 10000 integer :: current_peset_max = 32 type(communicator), allocatable :: peset(:) ! Will be allocated starting from 0, 0 is a dummy used to hold single-PE "self" communicator logical :: module_is_initialized = .false. logical :: debug = .false. integer :: npes=1, root_pe=0, pe=0 integer(8) :: tick, ticks_per_sec, max_ticks, start_tick, end_tick, tick0=0 integer :: mpp_comm_private logical :: first_call_system_clock_mpi=.TRUE. real(8) :: mpi_count0=0 ! use to prevent integer overflow real(8) :: mpi_tick_rate=0.d0 ! clock rate for mpi_wtick() logical :: mpp_record_timing_data=.TRUE. type(clock),save :: clocks(MAX_CLOCKS) integer :: log_unit, etc_unit character(len=32) :: configfile='logfile' integer :: peset_num=0, current_peset_num=0 integer :: world_peset_num !the world communicator integer :: error integer :: clock_num=0, num_clock_ids=0,current_clock=0, previous_clock(MAX_CLOCKS)=0 real :: tick_rate type(mpp_type_list) :: datatypes type(mpp_type), target :: mpp_byte integer :: cur_send_request = 0 integer :: cur_recv_request = 0 integer, allocatable :: request_send(:) integer, allocatable :: request_recv(:) integer, allocatable :: size_recv(:) integer, allocatable :: type_recv(:) ! if you want to save the non-root PE information uncomment out the following line ! and comment out the assigment of etcfile to '/dev/null' # 1327 character(len=32) :: etcfile='/dev/null' # 1333 integer :: in_unit=5, out_unit=6, err_unit=0 integer :: stdout_unit !--- variables used in mpp_util.h type(Summary_Struct) :: clock_summary(MAX_CLOCKS) logical :: warnings_are_fatal = .FALSE. integer :: error_state=0 integer :: clock_grain=CLOCK_LOOP-1 !--- variables used in mpp_comm.h # 1352 # 1358 integer :: clock0 !measures total runtime from mpp_init to mpp_exit integer :: mpp_stack_size=0, mpp_stack_hwm=0 logical :: verbose=.FALSE. # 1365 # 1368 integer :: get_len_nocomm = 0 ! needed for mpp_transmit_nocomm.h !*********************************************************************** ! variables needed for subroutine read_input_nml (include/mpp_util.inc) ! ! parameter defining length of character variables integer, parameter :: INPUT_STR_LENGTH = 256 ! public variable needed for reading input.nml from an internal file character(len=INPUT_STR_LENGTH), dimension(:), allocatable, target, public :: input_nml_file logical :: read_ascii_file_on = .FALSE. !*********************************************************************** ! Include variable "version" to be written to log file. # 1 "../include/file_version.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 23 character(len=*), parameter :: version = 'unknown' # 1384 "../mpp/mpp.F90" 2 public version integer, parameter :: MAX_REQUEST_MIN = 10000 integer :: request_multiply = 20 logical :: etc_unit_is_stderr = .false. integer :: max_request = 0 logical :: sync_all_clocks = .false. namelist /mpp_nml/ etc_unit_is_stderr, request_multiply, mpp_record_timing_data, sync_all_clocks contains # 1 "../mpp/include/system_clock.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 50 !####################################################################### subroutine system_clock_mpi( count, count_rate, count_max ) ! There can be one ONE baseline count0 and this routine is ! included in multiple places. !mimics F90 system_clock_mpi intrinsic integer(8), intent(out), optional :: count, count_rate, count_max !count must return a number between 0 and count_max integer(8), parameter :: maxtick=HUGE(count_max) if(first_call_system_clock_mpi)then first_call_system_clock_mpi=.false. mpi_count0 = MPI_WTime() mpi_tick_rate = 1.d0/MPI_WTick() endif if( PRESENT(count) )then count = (MPI_WTime()-mpi_count0)*mpi_tick_rate end if if( PRESENT(count_rate) )then count_rate = mpi_tick_rate end if if( PRESENT(count_max) )then count_max = maxtick-1 end if return end subroutine system_clock_mpi # 91 # 1396 "../mpp/mpp.F90" 2 # 1 "../mpp/include/mpp_util.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 25 # 1 "../mpp/include/mpp_util_mpi.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MISCELLANEOUS UTILITIES: mpp_error ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_error_basic( errortype, errormsg ) !a very basic error handler !uses ABORT and FLUSH calls, may need to use cpp to rename integer, intent(in) :: errortype character(len=*), intent(in), optional :: errormsg character(len=512) :: text logical :: opened integer :: istat, errunit if( .NOT.module_is_initialized )call ABORT() select case( errortype ) case(NOTE) text = 'NOTE' !just FYI case(WARNING) text = 'WARNING' !probable error case(FATAL) text = 'FATAL' !fatal error case default text = 'WARNING: non-existent errortype (must be NOTE|WARNING|FATAL)' end select if( npes.GT.1 )write( text,'(a,i6)' )trim(text)//' from PE', pe !this is the mpp part if( PRESENT(errormsg) )text = trim(text)//': '//trim(errormsg) !$OMP CRITICAL (MPP_ERROR_CRITICAL) select case( errortype ) case(NOTE) if(pe==root_pe)write( out_unit,'(a)' )trim(text) case default errunit = stderr() # 60 write( errunit, '(/a/)' )trim(text) if(pe==root_pe)write( out_unit,'(/a/)' )trim(text) if( errortype.EQ.FATAL .OR. warnings_are_fatal )then call FLUSH(out_unit) # 68 call MPI_ABORT( MPI_COMM_WORLD, 1, error ) end if end select error_state = errortype !$OMP END CRITICAL (MPP_ERROR_CRITICAL) end subroutine mpp_error_basic !##################################################################### !--- makes a PE set out of a PE list. A PE list is an ordered list of PEs !--- a PE set is a triad (start,log2stride,size) for SHMEM, an a communicator for MPI !--- if stride is non-uniform or not a power of 2, !--- will return error (not required for MPI but enforced for uniformity) function get_peset(pelist) integer :: get_peset integer, intent(in), optional :: pelist(:) integer :: group, errunit integer :: i, n, stride, l integer, allocatable :: sorted(:) character(len=128) :: text if( .NOT.PRESENT(pelist) )then !set it to current_peset_num get_peset = current_peset_num; return end if !--- first make sure pelist is monotonically increasing. if (size(pelist(:)) .GT. 1) then do n = 2, size(pelist(:)) if(pelist(n) <= pelist(n-1)) call mpp_error(FATAL, "GET_PESET: pelist is not monotonically increasing") enddo endif allocate( sorted(size(pelist(:))) ) sorted = pelist errunit = stderr() if( debug )write( errunit,* )'pelist=', pelist !find if this array matches any existing peset do i = 1,peset_num if( debug )write( errunit,'(a,3i6)' )'pe, i, peset_num=', pe, i, peset_num if( size(sorted(:)).EQ.size(peset(i)%list(:)) )then if( ALL(sorted.EQ.peset(i)%list) )then deallocate(sorted) get_peset = i; return end if end if end do !not found, so create new peset peset_num = peset_num + 1 if( peset_num > current_peset_max ) call expand_peset() i = peset_num !shorthand !create list allocate( peset(i)%list(size(sorted(:))) ) peset(i)%list(:) = sorted(:) peset(i)%count = size(sorted(:)) call MPI_GROUP_INCL( peset(current_peset_num)%group, size(sorted(:)), sorted-mpp_root_pe(), peset(i)%group, error ) call MPI_COMM_CREATE_GROUP(peset(current_peset_num)%id, peset(i)%group, & DEFAULT_TAG, peset(i)%id, error ) # 145 deallocate(sorted) get_peset = i return end function get_peset !####################################################################### !synchronize PEs in list subroutine mpp_sync( pelist, do_self ) integer, intent(in), optional :: pelist(:) logical, intent(in), optional :: do_self logical :: dself integer :: n dself=.true.; if(PRESENT(do_self))dself=do_self ! if(dself)call mpp_sync_self(pelist) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) # 173 call MPI_BARRIER( peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock(EVENT_WAIT) return end subroutine mpp_sync !####################################################################### !this is to check if current PE's outstanding puts are complete !but we can't use shmem_fence because we are actually waiting for !a remote PE to complete its get subroutine mpp_sync_self( pelist, check, request, msg_size, msg_type) integer, intent(in), optional :: pelist(:) integer, intent(in), optional :: check integer, intent(inout), optional :: request(:) integer, intent(in ), optional :: msg_size(:) integer, intent(in ), optional :: msg_type(:) integer :: i, m, n, stride, my_check, rsize if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) my_check = EVENT_SEND if(present(check)) my_check = check if( my_check .NE. EVENT_SEND .AND. my_check .NE. EVENT_RECV ) then call mpp_error( FATAL, 'mpp_sync_self: The value of optional argument check should be EVENT_SEND or EVENT_RECV') endif if(PRESENT(request)) then if( .not. present(check) ) then call mpp_error(FATAL, 'mpp_sync_self: check is not present when request is present') endif if( my_check == EVENT_RECV ) then if( .not. present(msg_size) ) then call mpp_error(FATAL, 'mpp_sync_self: msg_size is not present when request is present and it is EVENT_RECV') endif if( .not. present(msg_type) ) then call mpp_error(FATAL, 'mpp_sync_self: msg_type is not present when request is present and it is EVENT_RECV') endif if(size(msg_size) .NE. size(request)) then call mpp_error(FATAL, 'mpp_sync_self: dimension mismatch between msg_size and request') endif if(size(msg_type) .NE. size(request)) then call mpp_error(FATAL, 'mpp_sync_self: dimension mismatch between msg_type and request') endif do m = 1, size(request(:)) if( request(m) == MPI_REQUEST_NULL ) cycle call MPI_WAIT(request(m), stat, error ) call MPI_GET_COUNT(stat, msg_type(m), rsize, error) if(msg_size(m) .NE. rsize) then call mpp_error(FATAL, "mpp_sync_self: msg_size does not match size of data received") endif enddo else do m = 1, size(request(:)) if(request(m) .NE.MPI_REQUEST_NULL )call MPI_WAIT(request(m), stat, error ) enddo endif else select case(my_check) case(EVENT_SEND) do m = 1,cur_send_request if( request_send(m).NE.MPI_REQUEST_NULL )call MPI_WAIT( request_send(m), stat, error ) end do cur_send_request = 0 case(EVENT_RECV) do m = 1,cur_recv_request call MPI_WAIT( request_recv(m), stat, error ) call MPI_GET_COUNT(stat, type_recv(m), rsize, error) if(size_recv(m) .NE. rsize) then call mpp_error(FATAL, "mpp_sync_self: size_recv does not match of data received") endif size_recv(m) = 0 end do cur_recv_request = 0 end select endif if( debug .and. (current_clock.NE.0) )call increment_current_clock(EVENT_WAIT) return end subroutine mpp_sync_self # 27 "../mpp/include/mpp_util.inc" 2 # 29 !##################################################################### ! ! ! Standard fortran unit numbers. ! ! ! This function returns the current standard fortran unit numbers for input. ! ! ! function stdin() integer :: stdin stdin = in_unit return end function stdin !##################################################################### ! ! ! Standard fortran unit numbers. ! ! ! This function returns the current standard fortran unit numbers for output. ! ! ! function stdout() integer :: stdout stdout = out_unit if( pe.NE.root_pe )stdout = stdlog() return end function stdout !##################################################################### ! ! ! Standard fortran unit numbers. ! ! ! This function returns the current standard fortran unit numbers for error messages. ! ! ! function stderr() integer :: stderr stderr = err_unit return end function stderr !##################################################################### ! ! ! Standard fortran unit numbers. ! ! ! This function returns the current standard fortran unit numbers for log messages. ! Log messages, by convention, are written to the file logfile.out. ! ! ! function stdlog() integer :: stdlog,istat logical :: opened character(len=11) :: this_pe !$ logical :: omp_in_parallel !$ integer :: omp_get_num_threads !$ integer :: errunit !NOTES: We can not use mpp_error to handle the error because mpp_error ! will call stdout and stdout will call stdlog for non-root-pe. ! This will be a cicular call. !$ if( omp_in_parallel() .and. (omp_get_num_threads() > 1) ) then !$OMP single !$ errunit = stderr() !$ write( errunit,'(/a/)' ) 'FATAL: STDLOG: is called inside a OMP parallel region' # 118 !$ call MPI_ABORT( MPI_COMM_WORLD, 1, error ) # 123 !$OMP end single !$ endif if( pe.EQ.root_pe )then write(this_pe,'(a,i6.6,a)') '.',pe,'.out' inquire( file=trim(configfile)//this_pe, opened=opened ) if( opened )then call FLUSH(log_unit) else log_unit=get_unit() open( unit=log_unit, status='UNKNOWN', file=trim(configfile)//this_pe, position='APPEND', err=10 ) end if stdlog = log_unit else inquire( unit=etc_unit, opened=opened ) if( opened )then call FLUSH(etc_unit) else open( unit=etc_unit, status='UNKNOWN', file=trim(etcfile), position='APPEND', err=11 ) end if stdlog = etc_unit end if return 10 call mpp_error( FATAL, 'STDLOG: unable to open '//trim(configfile)//this_pe//'.' ) 11 call mpp_error( FATAL, 'STDLOG: unable to open '//trim(etcfile)//'.' ) end function stdlog !##################################################################### subroutine mpp_init_logfile() integer :: p logical :: exist character(len=11) :: this_pe if( pe.EQ.root_pe )then log_unit = get_unit() do p=0,npes-1 write(this_pe,'(a,i6.6,a)') '.',p,'.out' inquire( file=trim(configfile)//this_pe, exist=exist ) if(exist)then open( unit=log_unit, file=trim(configfile)//this_pe, status='REPLACE' ) close(log_unit) endif end do end if end subroutine mpp_init_logfile !##################################################################### subroutine mpp_set_warn_level(flag) integer, intent(in) :: flag if( flag.EQ.WARNING )then warnings_are_fatal = .FALSE. else if( flag.EQ.FATAL )then warnings_are_fatal = .TRUE. else call mpp_error( FATAL, 'MPP_SET_WARN_LEVEL: warning flag must be set to WARNING or FATAL.' ) end if return end subroutine mpp_set_warn_level !##################################################################### function mpp_error_state() integer :: mpp_error_state mpp_error_state = error_state return end function mpp_error_state !##################################################################### !overloads to mpp_error_basic !support for error_mesg routine in FMS subroutine mpp_error_mesg( routine, errormsg, errortype ) character(len=*), intent(in) :: routine, errormsg integer, intent(in) :: errortype call mpp_error( errortype, trim(routine)//': '//trim(errormsg) ) return end subroutine mpp_error_mesg !##################################################################### subroutine mpp_error_noargs() call mpp_error(FATAL) end subroutine mpp_error_noargs !##################################################################### subroutine mpp_error_Is(errortype, errormsg1, value, errormsg2) integer, intent(in) :: errortype INTEGER, intent(in) :: value character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 call mpp_error( errortype, errormsg1, (/value/), errormsg2) end subroutine mpp_error_Is !##################################################################### subroutine mpp_error_Rs(errortype, errormsg1, value, errormsg2) integer, intent(in) :: errortype REAL, intent(in) :: value character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 call mpp_error( errortype, errormsg1, (/value/), errormsg2) end subroutine mpp_error_Rs !##################################################################### subroutine mpp_error_Ia(errortype, errormsg1, array, errormsg2) integer, intent(in) :: errortype INTEGER, dimension(:), intent(in) :: array character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 character(len=512) :: string string = errormsg1//trim(array_to_char(array)) if(present(errormsg2)) string = trim(string)//errormsg2 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_Ia !##################################################################### subroutine mpp_error_Ra(errortype, errormsg1, array, errormsg2) integer, intent(in) :: errortype REAL, dimension(:), intent(in) :: array character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 character(len=512) :: string string = errormsg1//trim(array_to_char(array)) if(present(errormsg2)) string = trim(string)//errormsg2 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_Ra !##################################################################### # 1 "../mpp/include/mpp_error_a_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ia_ia(errortype, errormsg1, array1, errormsg2, array2, errormsg3) integer, intent(in) :: errortype integer, dimension(:), intent(in) :: array1 integer, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 character(len=512) :: string string = errormsg1//trim(array_to_char(array1)) string = trim(string)//errormsg2//trim(array_to_char(array2)) if(present(errormsg3)) string = trim(string)//errormsg3 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_ia_ia # 254 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ia_ra(errortype, errormsg1, array1, errormsg2, array2, errormsg3) integer, intent(in) :: errortype integer, dimension(:), intent(in) :: array1 real, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 character(len=512) :: string string = errormsg1//trim(array_to_char(array1)) string = trim(string)//errormsg2//trim(array_to_char(array2)) if(present(errormsg3)) string = trim(string)//errormsg3 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_ia_ra # 262 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ra_ia(errortype, errormsg1, array1, errormsg2, array2, errormsg3) integer, intent(in) :: errortype real, dimension(:), intent(in) :: array1 integer, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 character(len=512) :: string string = errormsg1//trim(array_to_char(array1)) string = trim(string)//errormsg2//trim(array_to_char(array2)) if(present(errormsg3)) string = trim(string)//errormsg3 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_ra_ia # 270 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ra_ra(errortype, errormsg1, array1, errormsg2, array2, errormsg3) integer, intent(in) :: errortype real, dimension(:), intent(in) :: array1 real, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 character(len=512) :: string string = errormsg1//trim(array_to_char(array1)) string = trim(string)//errormsg2//trim(array_to_char(array2)) if(present(errormsg3)) string = trim(string)//errormsg3 call mpp_error_basic( errortype, trim(string)) end subroutine mpp_error_ra_ra # 278 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ia_is(errortype, errormsg1, array, errormsg2, scalar, errormsg3) integer, intent(in) :: errortype integer, dimension(:), intent(in) :: array integer, intent(in) :: scalar character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, array, errormsg2, (/scalar/), errormsg3) end subroutine mpp_error_ia_is # 286 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ia_rs(errortype, errormsg1, array, errormsg2, scalar, errormsg3) integer, intent(in) :: errortype integer, dimension(:), intent(in) :: array real, intent(in) :: scalar character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, array, errormsg2, (/scalar/), errormsg3) end subroutine mpp_error_ia_rs # 294 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ra_is(errortype, errormsg1, array, errormsg2, scalar, errormsg3) integer, intent(in) :: errortype real, dimension(:), intent(in) :: array integer, intent(in) :: scalar character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, array, errormsg2, (/scalar/), errormsg3) end subroutine mpp_error_ra_is # 302 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_a_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_ra_rs(errortype, errormsg1, array, errormsg2, scalar, errormsg3) integer, intent(in) :: errortype real, dimension(:), intent(in) :: array real, intent(in) :: scalar character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, array, errormsg2, (/scalar/), errormsg3) end subroutine mpp_error_ra_rs # 310 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_is_ia(errortype, errormsg1, scalar2, errormsg2, array2, errormsg3) integer, intent(in) :: errortype integer, intent(in) :: scalar2 integer, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar2/), errormsg2, array2, errormsg3) end subroutine mpp_error_is_ia # 318 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_is_ra(errortype, errormsg1, scalar2, errormsg2, array2, errormsg3) integer, intent(in) :: errortype integer, intent(in) :: scalar2 real, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar2/), errormsg2, array2, errormsg3) end subroutine mpp_error_is_ra # 326 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_rs_ia(errortype, errormsg1, scalar2, errormsg2, array2, errormsg3) integer, intent(in) :: errortype real, intent(in) :: scalar2 integer, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar2/), errormsg2, array2, errormsg3) end subroutine mpp_error_rs_ia # 334 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_a.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_rs_ra(errortype, errormsg1, scalar2, errormsg2, array2, errormsg3) integer, intent(in) :: errortype real, intent(in) :: scalar2 real, dimension(:), intent(in) :: array2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar2/), errormsg2, array2, errormsg3) end subroutine mpp_error_rs_ra # 342 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_is_is(errortype, errormsg1, scalar1, errormsg2, scalar2, errormsg3) integer, intent(in) :: errortype integer, intent(in) :: scalar1 integer, intent(in) :: scalar2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar1/), errormsg2, (/scalar2/), errormsg3) end subroutine mpp_error_is_is # 350 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_is_rs(errortype, errormsg1, scalar1, errormsg2, scalar2, errormsg3) integer, intent(in) :: errortype integer, intent(in) :: scalar1 real, intent(in) :: scalar2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar1/), errormsg2, (/scalar2/), errormsg3) end subroutine mpp_error_is_rs # 358 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_rs_is(errortype, errormsg1, scalar1, errormsg2, scalar2, errormsg3) integer, intent(in) :: errortype real, intent(in) :: scalar1 integer, intent(in) :: scalar2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar1/), errormsg2, (/scalar2/), errormsg3) end subroutine mpp_error_rs_is # 366 "../mpp/include/mpp_util.inc" 2 !##################################################################### # 1 "../mpp/include/mpp_error_s_s.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_error_rs_rs(errortype, errormsg1, scalar1, errormsg2, scalar2, errormsg3) integer, intent(in) :: errortype real, intent(in) :: scalar1 real, intent(in) :: scalar2 character(len=*), intent(in) :: errormsg1, errormsg2 character(len=*), intent(in), optional :: errormsg3 call mpp_error( errortype, errormsg1, (/scalar1/), errormsg2, (/scalar2/), errormsg3) end subroutine mpp_error_rs_rs # 374 "../mpp/include/mpp_util.inc" 2 !##################################################################### function iarray_to_char(iarray) result(string) integer, intent(in) :: iarray(:) character(len=256) :: string character(len=32) :: chtmp integer :: i, len_tmp, len_string string = '' do i=1,size(iarray) write(chtmp,'(i16)') iarray(i) chtmp = adjustl(chtmp) len_tmp = len_trim(chtmp) len_string = len_trim(string) string(len_string+1:len_string+len_tmp) = trim(chtmp) string(len_string+len_tmp+1:len_string+len_tmp+1) = ',' enddo len_string = len_trim(string) string(len_string:len_string) = ' ' ! remove trailing comma end function iarray_to_char !##################################################################### function rarray_to_char(rarray) result(string) real, intent(in) :: rarray(:) character(len=256) :: string character(len=32) :: chtmp integer :: i, len_tmp, len_string string = '' do i=1,size(rarray) write(chtmp,'(G16.9)') rarray(i) chtmp = adjustl(chtmp) len_tmp = len_trim(chtmp) len_string = len_trim(string) string(len_string+1:len_string+len_tmp) = trim(chtmp) string(len_string+len_tmp+1:len_string+len_tmp+1) = ',' enddo len_string = len_trim(string) string(len_string:len_string) = ' ' ! remove trailing comma end function rarray_to_char !##################################################################### ! ! ! Returns processor ID. ! ! ! This returns the unique ID associated with a PE. This number runs ! between 0 and npes-1, where npes is the total ! processor count, returned by mpp_npes. For a uniprocessor ! application this will always return 0. ! ! ! function mpp_pe() integer :: mpp_pe if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_PE: You must first call mpp_init.' ) mpp_pe = pe return end function mpp_pe !##################################################################### function mpp_node() !calls mld_id from threadloc.c on sgi, which returns the hardware node ID from /hw/nodenum/... integer :: mpp_node integer :: mld_id if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_NODE: You must first call mpp_init.' ) mpp_node = mld_id() return end function mpp_node !##################################################################### ! ! ! Returns processor count for current pelist. ! ! ! This returns the number of PEs in the current pelist. For a ! uniprocessor application, this will always return 1. ! ! ! function mpp_npes() integer :: mpp_npes if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_NPES: You must first call mpp_init.' ) mpp_npes = size(peset(current_peset_num)%list(:)) return end function mpp_npes !##################################################################### function mpp_root_pe() integer :: mpp_root_pe if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_ROOT_PE: You must first call mpp_init.' ) mpp_root_pe = root_pe return end function mpp_root_pe !##################################################################### subroutine mpp_set_root_pe(num) integer, intent(in) :: num logical :: opened if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_ROOT_PE: You must first call mpp_init.' ) if( .NOT.(ANY(num.EQ.peset(current_peset_num)%list(:))) ) & call mpp_error( FATAL, 'MPP_SET_ROOT_PE: you cannot set a root PE outside the current pelist.' ) !actions to take if root_pe has changed: ! open log_unit on new root_pe, close it on old root_pe and point its log_unit to stdout. ! if( num.NE.root_pe )then !root_pe has changed ! if( pe.EQ.num )then !on the new root_pe ! if( log_unit.NE.out_unit )then ! inquire( unit=log_unit, opened=opened ) ! if( .NOT.opened )open( unit=log_unit, status='OLD', file=trim(configfile), position='APPEND' ) ! end if ! else if( pe.EQ.root_pe )then !on the old root_pe ! if( log_unit.NE.out_unit )then ! inquire( unit=log_unit, opened=opened ) ! if( opened )close(log_unit) ! log_unit = out_unit ! end if ! end if ! end if root_pe = num return end subroutine mpp_set_root_pe !##################################################################### ! ! ! Declare a pelist. ! ! ! This call is written specifically to accommodate a MPI restriction ! that requires a parent communicator to create a child communicator, In ! other words: a pelist cannot go off and declare a communicator, but ! every PE in the parent, including those not in pelist(:), must get ! together for the MPI_COMM_CREATE call. The parent is ! typically MPI_COMM_WORLD, though it could also be a subset ! that includes all PEs in pelist. ! ! The restriction does not apply to SMA but to have uniform code, you ! may as well call it. ! ! This call implies synchronization across the PEs in the current ! pelist, of which pelist is a subset. ! ! ! ! subroutine mpp_declare_pelist( pelist, name ) integer, intent(in) :: pelist(:) character(len=*), intent(in), optional :: name integer :: i if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DECLARE_PELIST: You must first call mpp_init.' ) i = get_peset(pelist) write( peset(i)%name,'(a,i2.2)' ) 'PElist', i !default name if( PRESENT(name) )peset(i)%name = name return end subroutine mpp_declare_pelist !##################################################################### ! ! ! Set context pelist. ! ! ! This call sets the value of the current pelist, which is the ! context for all subsequent "global" calls where the optional ! pelist argument is omitted. All the PEs that are to be in the ! current pelist must call it. ! ! In MPI, this call may hang unless pelist has been previous ! declared using mpp_declare_pelist. ! ! If the argument pelist is absent, the current pelist is ! set to the "world" pelist, of all PEs in the job. ! ! ! ! subroutine mpp_set_current_pelist( pelist, no_sync ) !Once we branch off into a PE subset, we want subsequent "global" calls to !sync only across this subset. This is declared as the current pelist (peset(current_peset_num)%list) !when current_peset all pelist ops with no pelist should apply the current pelist. !also, we set the start PE in this pelist to be the root_pe. !unlike mpp_declare_pelist, this is called by the PEs in the pelist only !so if the PEset has not been previously declared, this will hang in MPI. !if pelist is omitted, we reset pelist to the world pelist. integer, intent(in), optional :: pelist(:) logical, intent(in), optional :: no_sync integer :: i if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_CURRENT_PELIST: You must first call mpp_init.' ) if( PRESENT(pelist) )then if( .NOT.ANY(pe.EQ.pelist) )call mpp_error( FATAL, 'MPP_SET_CURRENT_PELIST: pe must be in pelist.' ) current_peset_num = get_peset(pelist) else current_peset_num = world_peset_num end if call mpp_set_root_pe( MINVAL(peset(current_peset_num)%list(:)) ) if(.not.PRESENT(no_sync))call mpp_sync() !this is called to make sure everyone in the current pelist is here. ! npes = mpp_npes() return end subroutine mpp_set_current_pelist !##################################################################### function mpp_get_current_pelist_name() ! Simply return the current pelist name character(len=len(peset(current_peset_num)%name)) :: mpp_get_current_pelist_name mpp_get_current_pelist_name = peset(current_peset_num)%name end function mpp_get_current_pelist_name !##################################################################### !this is created for use by mpp_define_domains within a pelist !will be published but not publicized subroutine mpp_get_current_pelist( pelist, name, commID ) integer, intent(out) :: pelist(:) character(len=*), intent(out), optional :: name integer, intent(out), optional :: commID if( size(pelist(:)).NE.size(peset(current_peset_num)%list(:)) ) & call mpp_error( FATAL, 'MPP_GET_CURRENT_PELIST: size(pelist) is wrong.' ) pelist(:) = peset(current_peset_num)%list(:) if( PRESENT(name) )name = peset(current_peset_num)%name if( PRESENT(commID) )commID = peset(current_peset_num)%id return end subroutine mpp_get_current_pelist !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! PERFORMANCE PROFILING CALLS ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Set the level of granularity of timing measurements. ! ! ! This routine and three other routines, mpp_clock_id, mpp_clock_begin(id), ! and mpp_clock_end(id) may be used to time parallel code sections, and ! extract parallel statistics. Clocks are identified by names, which ! should be unique in the first 32 characters. The mpp_clock_id ! call initializes a clock of a given name and returns an integer ! id. This id can be used by subsequent ! mpp_clock_begin and mpp_clock_end calls set around a ! code section to be timed. Example: !
!    integer :: id
!    id = mpp_clock_id( 'Atmosphere' )
!    call mpp_clock_begin(id)
!    call atmos_model()
!    call mpp_clock_end()
!    
! Two flags may be used to alter the behaviour of ! mpp_clock. If the flag MPP_CLOCK_SYNC is turned on ! by mpp_clock_id, the clock calls mpp_sync across all ! the PEs in the current pelist at the top of the timed code section, ! but allows each PE to complete the code section (and reach ! mpp_clock_end) at different times. This allows us to measure ! load imbalance for a given code section. Statistics are written to ! stdout by mpp_exit. ! ! The flag MPP_CLOCK_DETAILED may be turned on by ! mpp_clock_id to get detailed communication ! profiles. Communication events of the types SEND, RECV, BROADCAST, ! REDUCE and WAIT are separately measured for data volume ! and time. Statistics are written to stdout by ! mpp_exit, and individual PE info is also written to the file ! mpp_clock.out.#### where #### is the PE id given by ! mpp_pe. ! ! The flags MPP_CLOCK_SYNC and MPP_CLOCK_DETAILED are ! integer parameters available by use association, and may be summed to ! turn them both on. ! ! While the nesting of clocks is allowed, please note that turning on ! the non-optional flags on inner clocks has certain subtle issues. ! Turning on MPP_CLOCK_SYNC on an inner ! clock may distort outer clock measurements of load imbalance. Turning ! on MPP_CLOCK_DETAILED will stop detailed measurements on its ! outer clock, since only one detailed clock may be active at one time. ! Also, detailed clocks only time a certain number of events per clock ! (currently 40000) to conserve memory. If this array overflows, a ! warning message is printed, and subsequent events for this clock are ! not timed. ! ! Timings are done using the f90 standard ! system_clock_mpi intrinsic. ! ! The resolution of system_clock_mpi is often too coarse for use except ! across large swaths of code. On SGI systems this is transparently ! overloaded with a higher resolution clock made available in a ! non-portable fortran interface made available by ! nsclock.c. This approach will eventually be extended to other ! platforms. ! ! New behaviour added at the Havana release allows the user to embed ! profiling calls at varying levels of granularity all over the code, ! and for any particular run, set a threshold of granularity so that ! finer-grained clocks become dormant. ! ! The threshold granularity is held in the private module variable ! clock_grain. This value may be modified by the call ! mpp_clock_set_grain, and affect clocks initiated by ! subsequent calls to mpp_clock_id. The value of ! clock_grain is set to an arbitrarily large number initially. ! ! Clocks initialized by mpp_clock_id can set a new optional ! argument grain setting their granularity level. Clocks check ! this level against the current value of clock_grain, and are ! only triggered if they are at or below ("coarser than") the ! threshold. Finer-grained clocks are dormant for that run. ! !The following grain levels are pre-defined: ! !
!!predefined clock granularities, but you can use any integer
!!using CLOCK_LOOP and above may distort coarser-grain measurements
!  integer, parameter, public :: CLOCK_COMPONENT=1 !component level, e.g model, exchange
!  integer, parameter, public :: CLOCK_SUBCOMPONENT=11 !top level within a model component, e.g dynamics, physics
!  integer, parameter, public :: CLOCK_MODULE=21 !module level, e.g main subroutine of a physics module
!  integer, parameter, public :: CLOCK_ROUTINE=31 !level of individual subroutine or function
!  integer, parameter, public :: CLOCK_LOOP=41 !loops or blocks within a routine
!  integer, parameter, public :: CLOCK_INFRA=51 !infrastructure level, e.g halo update
!
! ! Note that subsequent changes to clock_grain do not ! change the status of already initiated clocks, and that if the ! optional grain argument is absent, the clock is always ! triggered. This guarantees backward compatibility. !
! ! !
subroutine mpp_clock_set_grain( grain ) integer, intent(in) :: grain !set the granularity of times: only clocks whose grain is lower than !clock_grain are triggered, finer-grained clocks are dormant. !clock_grain is initialized to CLOCK_LOOP, so all clocks above the loop level !are triggered if this is never called. if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_SET_GRAIN: You must first call mpp_init.' ) clock_grain = grain return end subroutine mpp_clock_set_grain !##################################################################### subroutine clock_init( id, name, flags, grain ) integer, intent(in) :: id character(len=*), intent(in) :: name integer, intent(in), optional :: flags, grain integer :: i clocks(id)%name = name clocks(id)%tick = 0 clocks(id)%total_ticks = 0 clocks(id)%sync_on_begin = .FALSE. clocks(id)%detailed = .FALSE. clocks(id)%peset_num = current_peset_num if( PRESENT(flags) )then if( BTEST(flags,0) )clocks(id)%sync_on_begin = .TRUE. if( BTEST(flags,1) )clocks(id)%detailed = .TRUE. end if clocks(id)%grain = 0 if( PRESENT(grain) )clocks(id)%grain = grain if( clocks(id)%detailed )then allocate( clocks(id)%events(MAX_EVENT_TYPES) ) clocks(id)%events(EVENT_ALLREDUCE)%name = 'ALLREDUCE' clocks(id)%events(EVENT_BROADCAST)%name = 'BROADCAST' clocks(id)%events(EVENT_RECV)%name = 'RECV' clocks(id)%events(EVENT_SEND)%name = 'SEND' clocks(id)%events(EVENT_WAIT)%name = 'WAIT' do i=1,MAX_EVENT_TYPES clocks(id)%events(i)%ticks(:) = 0 clocks(id)%events(i)%bytes(:) = 0 clocks(id)%events(i)%calls = 0 end do clock_summary(id)%name = name clock_summary(id)%event(EVENT_ALLREDUCE)%name = 'ALLREDUCE' clock_summary(id)%event(EVENT_BROADCAST)%name = 'BROADCAST' clock_summary(id)%event(EVENT_RECV)%name = 'RECV' clock_summary(id)%event(EVENT_SEND)%name = 'SEND' clock_summary(id)%event(EVENT_WAIT)%name = 'WAIT' do i=1,MAX_EVENT_TYPES clock_summary(id)%event(i)%msg_size_sums(:) = 0.0 clock_summary(id)%event(i)%msg_time_sums(:) = 0.0 clock_summary(id)%event(i)%total_data = 0.0 clock_summary(id)%event(i)%total_time = 0.0 clock_summary(id)%event(i)%msg_size_cnts(:) = 0 clock_summary(id)%event(i)%total_cnts = 0 end do end if return end subroutine clock_init !##################################################################### !return an ID for a new or existing clock function mpp_clock_id( name, flags, grain ) integer :: mpp_clock_id character(len=*), intent(in) :: name integer, intent(in), optional :: flags, grain integer :: i if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_ID: You must first call mpp_init.') !if grain is present, the clock is only triggered if it !is low ("coarse") enough: compared to clock_grain !finer-grained clocks are dormant. !if grain is absent, clock is triggered. if( PRESENT(grain) )then if( grain.GT.clock_grain )then mpp_clock_id = 0 return end if end if mpp_clock_id = 1 if( clock_num.EQ.0 )then !first clock_num = mpp_clock_id call clock_init(mpp_clock_id,name,flags) else FIND_CLOCK: do while( trim(name).NE.trim(clocks(mpp_clock_id)%name) ) mpp_clock_id = mpp_clock_id + 1 if( mpp_clock_id.GT.clock_num )then if( mpp_clock_id.GT.MAX_CLOCKS )then call mpp_error( FATAL, 'MPP_CLOCK_ID: too many clock requests, ' // & 'check your clock id request or increase MAX_CLOCKS.') else !new clock: initialize clock_num = mpp_clock_id call clock_init(mpp_clock_id,name,flags,grain) exit FIND_CLOCK end if end if end do FIND_CLOCK endif return end function mpp_clock_id !##################################################################### subroutine mpp_clock_begin(id) integer, intent(in) :: id if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: You must first call mpp_init.' ) if( .not. mpp_record_timing_data)return if( id.EQ.0 )return if( id.LT.0 .OR. id.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid id.' ) !$OMP MASTER if( clocks(id)%peset_num.NE.current_peset_num ) & call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: cannot change pelist context of a clock.' ) if( clocks(id)%is_on) call mpp_error(FATAL, 'MPP_CLOCK_BEGIN: mpp_clock_begin is called again '// & 'before calling mpp_clock_end for the clock '//trim(clocks(id)%name) ) if( clocks(id)%sync_on_begin .OR. sync_all_clocks )then !do an untimed sync at the beginning of the clock !this puts all PEs in the current pelist on par, so that measurements begin together !ending time will be different, thus measuring load imbalance for this clock. call mpp_sync() end if if (debug) then num_clock_ids = num_clock_ids+1 if(num_clock_ids > MAX_CLOCKS)call mpp_error(FATAL,'MPP_CLOCK_BEGIN: max num previous_clock exceeded.' ) previous_clock(num_clock_ids) = current_clock current_clock = id endif call system_clock_mpi( clocks(id)%tick ) clocks(id)%is_on = .true. !$OMP END MASTER return end subroutine mpp_clock_begin !##################################################################### subroutine mpp_clock_end(id) integer, intent(in) :: id integer(8) :: delta integer :: errunit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_END: You must first call mpp_init.' ) if( .not. mpp_record_timing_data)return if( id.EQ.0 )return if( id.LT.0 .OR. id.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid id.' ) !$OMP MASTER if( .NOT. clocks(id)%is_on) call mpp_error(FATAL, 'MPP_CLOCK_END: mpp_clock_end is called '// & 'before calling mpp_clock_begin for the clock '//trim(clocks(id)%name) ) call system_clock_mpi(end_tick) if( clocks(id)%peset_num.NE.current_peset_num ) & call mpp_error( FATAL, 'MPP_CLOCK_END: cannot change pelist context of a clock.' ) delta = end_tick - clocks(id)%tick if( delta.LT.0 )then errunit = stderr() write( errunit,* )'pe, id, start_tick, end_tick, delta, max_ticks=', pe, id, clocks(id)%tick, end_tick, delta, max_ticks delta = delta + max_ticks + 1 call mpp_error( WARNING, 'MPP_CLOCK_END: Clock rollover, assumed single roll.' ) end if clocks(id)%total_ticks = clocks(id)%total_ticks + delta if (debug) then if(num_clock_ids < 1) call mpp_error(NOTE,'MPP_CLOCK_END: min num previous_clock < 1.' ) current_clock = previous_clock(num_clock_ids) num_clock_ids = num_clock_ids-1 endif clocks(id)%is_on = .false. !$OMP END MASTER return end subroutine mpp_clock_end !##################################################################### subroutine mpp_record_time_start() mpp_record_timing_data = .TRUE. end subroutine mpp_record_time_start !##################################################################### subroutine mpp_record_time_end() mpp_record_timing_data = .FALSE. end subroutine mpp_record_time_end !##################################################################### subroutine increment_current_clock( event_id, bytes ) integer, intent(in) :: event_id integer, intent(in), optional :: bytes integer :: n integer(8) :: delta integer :: errunit if( .not. mpp_record_timing_data )return if( .not.debug .or. (current_clock.EQ.0) )return if( current_clock.LT.0 .OR. current_clock.GT.clock_num )call mpp_error( FATAL, 'MPP_CLOCK_BEGIN: invalid current_clock.' ) if( .NOT.clocks(current_clock)%detailed )return call system_clock_mpi(end_tick) n = clocks(current_clock)%events(event_id)%calls + 1 if( n.EQ.MAX_EVENTS )call mpp_error( WARNING, & 'MPP_CLOCK: events exceed MAX_EVENTS, ignore detailed profiling data for clock '//trim(clocks(current_clock)%name) ) if( n.GT.MAX_EVENTS )return clocks(current_clock)%events(event_id)%calls = n delta = end_tick - start_tick if( delta.LT.0 )then errunit = stderr() write( errunit,* )'pe, event_id, start_tick, end_tick, delta, max_ticks=', & pe, event_id, start_tick, end_tick, delta, max_ticks delta = delta + max_ticks + 1 call mpp_error( WARNING, 'MPP_CLOCK_END: Clock rollover, assumed single roll.' ) end if clocks(current_clock)%events(event_id)%ticks(n) = delta if( PRESENT(bytes) )clocks(current_clock)%events(event_id)%bytes(n) = bytes return end subroutine increment_current_clock !##################################################################### subroutine dump_clock_summary() real :: total_time,total_time_all,total_data real :: msg_size,eff_BW,s integer :: SD_UNIT, total_calls integer :: i,j,k,ct, msg_cnt character(len=2) :: u character(len=20) :: filename character(len=20),dimension(MAX_BINS),save :: bin data bin( 1) /' 0 - 8 B: '/ data bin( 2) /' 8 - 16 B: '/ data bin( 3) /' 16 - 32 B: '/ data bin( 4) /' 32 - 64 B: '/ data bin( 5) /' 64 - 128 B: '/ data bin( 6) /'128 - 256 B: '/ data bin( 7) /'256 - 512 B: '/ data bin( 8) /'512 - 1024 B: '/ data bin( 9) /' 1.0 - 2.1 KB: '/ data bin(10) /' 2.1 - 4.1 KB: '/ data bin(11) /' 4.1 - 8.2 KB: '/ data bin(12) /' 8.2 - 16.4 KB: '/ data bin(13) /' 16.4 - 32.8 KB: '/ data bin(14) /' 32.8 - 65.5 KB: '/ data bin(15) /' 65.5 - 131.1 KB: '/ data bin(16) /'131.1 - 262.1 KB: '/ data bin(17) /'262.1 - 524.3 KB: '/ data bin(18) /'524.3 - 1048.6 KB: '/ data bin(19) /' 1.0 - 2.1 MB: '/ data bin(20) /' >2.1 MB: '/ if( .NOT.ANY(clocks(1:clock_num)%detailed) )return write( filename,'(a,i6.6)' )'mpp_clock.out.', pe SD_UNIT = get_unit() open(SD_UNIT,file=trim(filename),form='formatted') COMM_TYPE: do ct = 1,clock_num if( .NOT.clocks(ct)%detailed )cycle write(SD_UNIT,*) & clock_summary(ct)%name(1:15),' Communication Data for PE ',pe write(SD_UNIT,*) ' ' write(SD_UNIT,*) ' ' total_time_all = 0.0 EVENT_TYPE: do k = 1,MAX_EVENT_TYPES-1 if(clock_summary(ct)%event(k)%total_time == 0.0)cycle total_time = clock_summary(ct)%event(k)%total_time total_time_all = total_time_all + total_time total_data = clock_summary(ct)%event(k)%total_data total_calls = clock_summary(ct)%event(k)%total_cnts write(SD_UNIT,1000) clock_summary(ct)%event(k)%name(1:9) // ':' write(SD_UNIT,1001) 'Total Data: ',total_data*1.0e-6, & 'MB; Total Time: ', total_time, & 'secs; Total Calls: ',total_calls write(SD_UNIT,*) ' ' write(SD_UNIT,1002) ' Bin Counts Avg Size Eff B/W' write(SD_UNIT,*) ' ' BIN_LOOP: do j=1,MAX_BINS if(clock_summary(ct)%event(k)%msg_size_cnts(j)==0)cycle if(j<=8)then s = 1.0 u = ' B' elseif(j<=18)then s = 1.0e-3 u = 'KB' else s = 1.0e-6 u = 'MB' endif msg_cnt = clock_summary(ct)%event(k)%msg_size_cnts(j) msg_size = & s*(clock_summary(ct)%event(k)%msg_size_sums(j)/real(msg_cnt)) eff_BW = (1.0e-6)*( clock_summary(ct)%event(k)%msg_size_sums(j) / & clock_summary(ct)%event(k)%msg_time_sums(j) ) write(SD_UNIT,1003) bin(j),msg_cnt,msg_size,u,eff_BW end do BIN_LOOP write(SD_UNIT,*) ' ' write(SD_UNIT,*) ' ' end do EVENT_TYPE ! "Data-less" WAIT if(clock_summary(ct)%event(MAX_EVENT_TYPES)%total_time>0.0)then total_time = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_time total_time_all = total_time_all + total_time total_calls = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_cnts write(SD_UNIT,1000) clock_summary(ct)%event(MAX_EVENT_TYPES)%name(1:9) // ':' write(SD_UNIT,1004) 'Total Calls: ',total_calls,'; Total Time: ', & total_time,'secs' endif write(SD_UNIT,*) ' ' write(SD_UNIT,1005) 'Total communication time spent for ' // & clock_summary(ct)%name(1:9) // ': ',total_time_all,'secs' write(SD_UNIT,*) ' ' write(SD_UNIT,*) ' ' write(SD_UNIT,*) ' ' end do COMM_TYPE close(SD_UNIT) 1000 format(a) 1001 format(a,f8.2,a,f8.2,a,i6) 1002 format(a) 1003 format(a,i6,' ',' ',f9.1,a,' ',f9.2,'MB/sec') 1004 format(a,i8,a,f9.2,a) 1005 format(a,f9.2,a) return end subroutine dump_clock_summary !##################################################################### integer function get_unit() integer,save :: i logical :: l_open ! 9 is reserved for etc_unit do i=10,99 inquire(unit=i,opened=l_open) if(.not.l_open)exit end do if(i==100)then call mpp_error(FATAL,'Unable to get I/O unit') else get_unit = i endif return end function get_unit !##################################################################### subroutine sum_clock_data() integer :: i,j,k,ct,event_size,event_cnt real :: msg_time CLOCK_TYPE: do ct=1,clock_num if( .NOT.clocks(ct)%detailed )cycle EVENT_TYPE: do j=1,MAX_EVENT_TYPES-1 event_cnt = clocks(ct)%events(j)%calls EVENT_SUMMARY: do i=1,event_cnt clock_summary(ct)%event(j)%total_cnts = & clock_summary(ct)%event(j)%total_cnts + 1 event_size = clocks(ct)%events(j)%bytes(i) k = find_bin(event_size) clock_summary(ct)%event(j)%msg_size_cnts(k) = & clock_summary(ct)%event(j)%msg_size_cnts(k) + 1 clock_summary(ct)%event(j)%msg_size_sums(k) = & clock_summary(ct)%event(j)%msg_size_sums(k) & + clocks(ct)%events(j)%bytes(i) clock_summary(ct)%event(j)%total_data = & clock_summary(ct)%event(j)%total_data & + clocks(ct)%events(j)%bytes(i) msg_time = clocks(ct)%events(j)%ticks(i) msg_time = tick_rate * real( clocks(ct)%events(j)%ticks(i) ) clock_summary(ct)%event(j)%msg_time_sums(k) = & clock_summary(ct)%event(j)%msg_time_sums(k) + msg_time clock_summary(ct)%event(j)%total_time = & clock_summary(ct)%event(j)%total_time + msg_time end do EVENT_SUMMARY end do EVENT_TYPE j = MAX_EVENT_TYPES ! WAITs ! "msg_size_cnts" doesn't really mean anything for WAIT ! but position will be used to store number of counts for now. event_cnt = clocks(ct)%events(j)%calls clock_summary(ct)%event(j)%msg_size_cnts(1) = event_cnt clock_summary(ct)%event(j)%total_cnts = event_cnt msg_time = tick_rate * real( sum ( clocks(ct)%events(j)%ticks(1:event_cnt) ) ) clock_summary(ct)%event(j)%msg_time_sums(1) = & clock_summary(ct)%event(j)%msg_time_sums(1) + msg_time clock_summary(ct)%event(j)%total_time = clock_summary(ct)%event(j)%msg_time_sums(1) end do CLOCK_TYPE return contains integer function find_bin(event_size) integer,intent(in) :: event_size integer :: k,msg_size msg_size = 8 k = 1 do while(event_size>msg_size .and. k uppercase(k:k) if(ca >= "a" .and. ca <= "z") ca = achar(ichar(ca)+co) enddo endif end function uppercase !####################################################################### function lowercase (cs) character(len=*), intent(in) :: cs character(len=len(cs)),target :: lowercase integer, parameter :: co=iachar('a')-iachar('A') ! case offset integer :: k,tlen character, pointer :: ca ! The transfer function truncates the string with xlf90_r tlen = len_trim(cs) if(tlen <= 0) then ! catch IBM compiler bug lowercase = cs ! simply return input blank string else lowercase = cs(1:tlen) ! #etd # 1291 do k=1, tlen ca => lowercase(k:k) if(ca >= "A" .and. ca <= "Z") ca = achar(ichar(ca)+co) enddo endif end function lowercase !####################################################################### !----------------------------------------------------------------------- ! ! AUTHOR: Rusty Benson (rusty.benson@noaa.gov) ! ! ! THESE LINES MUST BE PRESENT IN MPP.F90 ! ! ! parameter defining length of character variables ! integer, parameter :: INPUT_STR_LENGTH = 256 ! ! public variable needed for reading input.nml from an internal file ! character(len=INPUT_STR_LENGTH), dimension(:), allocatable, public :: input_nml_file ! !----------------------------------------------------------------------- ! subroutine READ_INPUT_NML ! ! ! Reads an existing input.nml into a character array and broadcasts ! it to the non-root mpi-tasks. This allows the use of reads from an ! internal file for namelist settings (requires 2003 compliant compiler) ! ! read(input_nml_file, nml=, iostat=status) ! ! subroutine read_input_nml(pelist_name_in) ! Include variable "version" to be written to log file. # 1 "../include/file_version.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 23 character(len=*), parameter :: version = 'unknown' # 1331 "../mpp/include/mpp_util.inc" 2 character(len=*), intent(in), optional :: pelist_name_in ! private variables integer :: log_unit integer :: num_lines, i logical :: file_exist character(len=len(peset(current_peset_num)%name)) :: pelist_name character(len=128) :: filename ! check the status of input_nml_file if ( allocated(input_nml_file) ) then deallocate(input_nml_file) endif ! the following code is necessary for using alternate namelist files (nests, stretched grids, etc) if (PRESENT(pelist_name_in)) then ! test to make sure length of pelist_name_in is <= pelist_name if (LEN(pelist_name_in) > LEN(pelist_name)) then call mpp_error(FATAL, & "mpp_util.inc: read_input_nml optional argument pelist_name_in has size greater than local pelist_name") else pelist_name = pelist_name_in endif else pelist_name = mpp_get_current_pelist_name() endif filename='input_'//trim(pelist_name)//'.nml' inquire(FILE=filename, EXIST=file_exist) if (.not. file_exist ) then filename='input.nml' endif num_lines = get_ascii_file_num_lines(filename, INPUT_STR_LENGTH) allocate(input_nml_file(num_lines)) call read_ascii_file(filename, INPUT_STR_LENGTH, input_nml_file) ! write info logfile if (pe == root_pe) then log_unit = stdlog() write(log_unit,'(a)') '========================================================================' write(log_unit,'(a)') 'READ_INPUT_NML: '//trim(version) write(log_unit,'(a)') 'READ_INPUT_NML: '//trim(filename)//' ' do i = 1, num_lines write(log_unit,*) trim(input_nml_file(i)) enddo end if end subroutine read_input_nml !####################################################################### !z1l: This is extracted from read_ascii_file function get_ascii_file_num_lines(FILENAME, LENGTH, PELIST) character(len=*), intent(in) :: FILENAME integer, intent(in) :: LENGTH integer, intent(in), optional, dimension(:) :: PELIST integer :: num_lines, get_ascii_file_num_lines character(len=LENGTH) :: str_tmp character(len=5) :: text integer :: status, f_unit, from_pe logical :: file_exist if( read_ascii_file_on) then call mpp_error(FATAL, & "mpp_util.inc: get_ascii_file_num_lines is called again before calling read_ascii_file") endif read_ascii_file_on = .true. from_pe = root_pe get_ascii_file_num_lines = -1 num_lines = -1 if ( pe == root_pe ) then inquire(FILE=FILENAME, EXIST=file_exist) if ( file_exist ) then f_unit = get_unit() open(UNIT=f_unit, FILE=FILENAME, ACTION='READ', STATUS='OLD', IOSTAT=status) if ( status .ne. 0 ) then write (UNIT=text, FMT='(I5)') status call mpp_error(FATAL, 'get_ascii_file_num_lines: Error opening file:' //trim(FILENAME)// & '. (IOSTAT = '//trim(text)//')') else num_lines = 1 do read (UNIT=f_unit, FMT='(A)', IOSTAT=status) str_tmp if ( status .lt. 0 ) exit if ( status .gt. 0 ) then write (UNIT=text, FMT='(I5)') num_lines call mpp_error(FATAL, 'get_ascii_file_num_lines: Error reading line '//trim(text)// & ' in file '//trim(FILENAME)//'.') end if if ( len_trim(str_tmp) == LENGTH ) then write(UNIT=text, FMT='(I5)') length call mpp_error(FATAL, 'get_ascii_file_num_lines: Length of output string ('//trim(text)//' is too small.& & Increase the LENGTH value.') end if num_lines = num_lines + 1 end do close(UNIT=f_unit) end if else call mpp_error(FATAL, 'get_ascii_file_num_lines: File '//trim(FILENAME)//' does not exist.') end if end if ! Broadcast number of lines call mpp_broadcast(num_lines, from_pe, PELIST=PELIST) get_ascii_file_num_lines = num_lines end function get_ascii_file_num_lines !----------------------------------------------------------------------- ! ! AUTHOR: Rusty Benson , ! Seth Underwood ! !----------------------------------------------------------------------- ! subroutine READ_ASCII_FILE ! ! ! Reads any ascii file into a character array and broadcasts ! it to the non-root mpi-tasks. Based off READ_INPUT_NML. ! ! Passed in 'Content' array, must be of the form: ! character(len=LENGTH), dimension(:), allocatable :: array_name ! ! Reads from this array must be done in a do loop over the number of ! lines, i.e.: ! ! do i=1, num_lines ! read (UNIT=array_name(i), FMT=*) var1, var2, ... ! end do ! subroutine read_ascii_file(FILENAME, LENGTH, Content, PELIST) character(len=*), intent(in) :: FILENAME integer, intent(in) :: LENGTH character(len=*), intent(inout), dimension(:) :: Content integer, intent(in), optional, dimension(:) :: PELIST ! Include variable "version" to be written to log file. # 1 "../include/file_version.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 23 character(len=*), parameter :: version = 'unknown' # 1472 "../mpp/include/mpp_util.inc" 2 character(len=5) :: text logical :: file_exist integer :: status, i, f_unit, log_unit integer :: from_pe integer :: pnum_lines, num_lines if( .NOT. read_ascii_file_on) then call mpp_error(FATAL, & "mpp_util.inc: get_ascii_file_num_lines needs to be called before calling read_ascii_file") endif read_ascii_file_on = .false. from_pe = root_pe num_lines = size(Content(:)) if ( pe == root_pe ) then ! write info logfile log_unit = stdlog() write(log_unit,'(a)') '========================================================================' write(log_unit,'(a)') 'READ_ASCII_FILE: '//trim(version) write(log_unit,'(a)') 'READ_ASCII_FILE: File: '//trim(FILENAME) inquire(FILE=FILENAME, EXIST=file_exist) if ( file_exist ) then f_unit = get_unit() open(UNIT=f_unit, FILE=FILENAME, ACTION='READ', STATUS='OLD', IOSTAT=status) if ( status .ne. 0 ) then write (UNIT=text, FMT='(I5)') status call mpp_error(FATAL, 'READ_ASCII_FILE: Error opening file: '//trim(FILENAME)//'. (IOSTAT = '//trim(text)//')') else if ( num_lines .gt. 0 ) then Content(:) = ' ' rewind(UNIT=f_unit, IOSTAT=status) if ( status .ne. 0 ) then write (UNIT=text, FMT='(I5)') status call mpp_error(FATAL, 'READ_ASCII_FILE: Unable to re-read file '//trim(FILENAME)//'. (IOSTAT = '& //trim(text)//'.') else ! A second 'sanity' check on the file pnum_lines = 1 do read (UNIT=f_unit, FMT='(A)', IOSTAT=status) Content(pnum_lines) if ( status .lt. 0 ) exit if ( status .gt. 0 ) then write (UNIT=text, FMT='(I5)') pnum_lines call mpp_error(FATAL, 'READ_ASCII_FILE: Error reading line '//trim(text)//' in file '//trim(FILENAME)//'.') end if if(pnum_lines > num_lines) then call mpp_error(FATAL, 'READ_ASCII_FILE: number of lines in file '//trim(FILENAME)// & ' is greater than size(Content(:)). ') end if if ( len_trim(Content(pnum_lines)) == LENGTH ) then write(UNIT=text, FMT='(I5)') length call mpp_error(FATAL, 'READ_ASCII_FILE: Length of output string ('//trim(text)//' is too small.& & Increase the LENGTH value.') end if pnum_lines = pnum_lines + 1 end do if(num_lines .NE. pnum_lines) then call mpp_error(FATAL, 'READ_ASCII_FILE: number of lines in file '//trim(FILENAME)// & ' does not equal to size(Content(:)) ' ) end if end if end if close(UNIT=f_unit) end if else call mpp_error(FATAL, 'READ_ASCII_FILE: File '//trim(FILENAME)//' does not exist.') end if end if ! Broadcast character array call mpp_broadcast(Content, LENGTH, from_pe, PELIST=PELIST) end subroutine read_ascii_file # 1397 "../mpp/mpp.F90" 2 # 1 "../mpp/include/mpp_comm.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** # 24 # 1 "../mpp/include/mpp_comm_mpi.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ROUTINES TO INITIALIZE/FINALIZE MPP MODULE: mpp_init, mpp_exit ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! subroutine mpp_init( flags, in, out, err, log ) ! integer, optional, intent(in) :: flags, in, out, err, log subroutine mpp_init( flags, localcomm ) integer, optional, intent(in) :: flags integer, optional, intent(in) :: localcomm integer :: my_pe, num_pes, len, i, iunit logical :: opened, existed integer :: unit_begin, unit_end, unit_nml, io_status character(len=5) :: this_pe type(mpp_type), pointer :: dtype if( module_is_initialized )return call MPI_INITIALIZED( opened, error ) !in case called from another MPI package if(opened .and. .NOT. PRESENT(localcomm)) call mpp_error( FATAL, 'MPP_INIT: communicator is required' ) if( .NOT.opened ) then call MPI_INIT(error) mpp_comm_private = MPI_COMM_WORLD else mpp_comm_private = localcomm endif call MPI_COMM_RANK( mpp_comm_private, pe, error ) call MPI_COMM_SIZE( mpp_comm_private, npes, error ) # 55 module_is_initialized = .TRUE. !PEsets: make defaults illegal allocate(peset(0:current_peset_max)) peset(:)%count = -1 peset(:)%id = -1 peset(:)%group = -1 peset(:)%start = -1 peset(:)%log2stride = -1 peset(:)%name = " " !0=single-PE, initialized so that count returns 1 peset(0)%count = 1 allocate( peset(0)%list(1) ) peset(0)%list = pe current_peset_num = 0 peset(0)%id = mpp_comm_private call MPI_COMM_GROUP( mpp_comm_private, peset(0)%group, error ) world_peset_num = get_peset( (/(i,i=0,npes-1)/) ) current_peset_num = world_peset_num !initialize current PEset to world !initialize clocks call system_clock_mpi( count=tick0, count_rate=ticks_per_sec, count_max=max_ticks ) tick_rate = 1./ticks_per_sec clock0 = mpp_clock_id( 'Total runtime', flags=MPP_CLOCK_SYNC ) ! Create the bytestream (default) mpp_datatype mpp_byte%counter = 1 mpp_byte%ndims = 0 allocate(mpp_byte%sizes(0)) allocate(mpp_byte%subsizes(0)) allocate(mpp_byte%starts(0)) mpp_byte%etype = MPI_BYTE mpp_byte%id = MPI_BYTE mpp_byte%prev => null() mpp_byte%next => null() ! Initialize datatype list with mpp_byte datatypes%head => mpp_byte datatypes%tail => mpp_byte datatypes%length = 0 if( PRESENT(flags) )then debug = flags.EQ.MPP_DEBUG verbose = flags.EQ.MPP_VERBOSE .OR. debug end if call mpp_init_logfile() call read_input_nml !--- read namelist read (input_nml_file, mpp_nml, iostat=io_status) # 122 if (io_status > 0) then call mpp_error(FATAL,'=>mpp_init: Error reading input.nml') endif if(sync_all_clocks .AND. mpp_pe()==mpp_root_pe() ) call mpp_error(NOTE, & "mpp_mod: mpp_nml variable sync_all_clocks is set to .true., all clocks are synchronized in mpp_clock_begin.") ! non-root pe messages written to other location than stdout() if(etc_unit_is_stderr) then etc_unit = stderr() else ! 9 is reserved for etc_unit etc_unit=9 inquire(unit=etc_unit,opened=opened) if(opened) call mpp_error(FATAL,'Unit 9 is already in use (etc_unit) in mpp_comm_mpi') if (trim(etcfile) /= '/dev/null') then write( etcfile,'(a,i6.6)' )trim(etcfile)//'.', pe endif inquire(file=etcfile, exist=existed) if(existed) then open( unit=etc_unit, file=trim(etcfile), status='REPLACE' ) else open( unit=etc_unit, file=trim(etcfile) ) endif endif ! max_request is set to maximum of npes * REQUEST_MULTIPLY ( default is 20) and MAX_REQUEST_MIN ( default 10000) max_request = max(MAX_REQUEST_MIN, mpp_npes()*REQUEST_MULTIPLY) allocate( request_send(max_request) ) allocate( request_recv(max_request) ) allocate( size_recv(max_request) ) allocate( type_recv(max_request) ) request_send(:) = MPI_REQUEST_NULL request_recv(:) = MPI_REQUEST_NULL size_recv(:) = 0 type_recv(:) = 0 !if optional argument logunit=stdout, write messages to stdout instead. !if specifying non-defaults, you must specify units not yet in use. ! if( PRESENT(in) )then ! inquire( unit=in, opened=opened ) ! if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stdin.' ) ! in_unit=in ! end if ! if( PRESENT(out) )then ! inquire( unit=out, opened=opened ) ! if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stdout.' ) ! out_unit=out ! end if ! if( PRESENT(err) )then ! inquire( unit=err, opened=opened ) ! if( opened )call mpp_error( FATAL, 'MPP_INIT: unable to open stderr.' ) ! err_unit=err ! end if ! log_unit=get_unit() ! if( PRESENT(log) )then ! inquire( unit=log, opened=opened ) ! if( opened .AND. log.NE.out_unit )call mpp_error( FATAL, 'MPP_INIT: unable to open stdlog.' ) ! log_unit=log ! end if !!log_unit can be written to only from root_pe, all others write to stdout ! if( log_unit.NE.out_unit )then ! inquire( unit=log_unit, opened=opened ) ! if( opened )call mpp_error( FATAL, 'MPP_INIT: specified unit for stdlog already in use.' ) ! if( pe.EQ.root_pe )open( unit=log_unit, file=trim(configfile), status='REPLACE' ) ! call mpp_sync() ! if( pe.NE.root_pe )open( unit=log_unit, file=trim(configfile), status='OLD' ) ! end if !messages iunit = stdlog() ! workaround for lf95. if( verbose )call mpp_error( NOTE, 'MPP_INIT: initializing MPP module...' ) if( pe.EQ.root_pe )then write( iunit,'(/a)' )'MPP module '//trim(version) write( iunit,'(a,i6)' )'MPP started with NPES=', npes write( iunit,'(a)' )'Using MPI library for message passing...' write( iunit, '(a,es12.4,a,i10,a)' ) & 'Realtime clock resolution=', tick_rate, ' sec (', ticks_per_sec, ' ticks/sec)' write( iunit, '(a,es12.4,a,i20,a)' ) & 'Clock rolls over after ', max_ticks*tick_rate, ' sec (', max_ticks, ' ticks)' write( iunit,'(/a)' )'MPP Parameter module '//trim(mpp_parameter_version) write( iunit,'(/a)' )'MPP Data module '//trim(mpp_data_version) end if stdout_unit = stdout() call mpp_clock_begin(clock0) return end subroutine mpp_init !####################################################################### !to be called at the end of a run subroutine mpp_exit() integer :: i, j, k, n, nmax, istat, out_unit, log_unit real :: t, tmin, tmax, tavg, tstd real :: m, mmin, mmax, mavg, mstd, t_total logical :: opened type(mpp_type), pointer :: dtype if( .NOT.module_is_initialized )return call mpp_set_current_pelist() call mpp_clock_end(clock0) t_total = clocks(clock0)%total_ticks*tick_rate out_unit = stdout() log_unit = stdlog() if( clock_num.GT.0 )then if( ANY(clocks(1:clock_num)%detailed) )then call sum_clock_data; call dump_clock_summary end if call mpp_sync() call FLUSH( out_unit ) if( pe.EQ.root_pe )then write( out_unit,'(/a,i6,a)' ) 'Tabulating mpp_clock statistics across ', npes, ' PEs...' if( ANY(clocks(1:clock_num)%detailed) ) & write( out_unit,'(a)' )' ... see mpp_clock.out.#### for details on individual PEs.' write( out_unit,'(/32x,a)' ) ' tmin tmax tavg tstd tfrac grain pemin pemax' end if write( log_unit,'(/37x,a)' ) 'time' call FLUSH( out_unit ) call mpp_sync() do i = 1,clock_num if( .NOT.ANY(peset(clocks(i)%peset_num)%list(:).EQ.pe) )cycle call mpp_set_current_pelist( peset(clocks(i)%peset_num)%list ) out_unit = stdout() log_unit = stdlog() !times between mpp_clock ticks t = clocks(i)%total_ticks*tick_rate tmin = t; call mpp_min(tmin) tmax = t; call mpp_max(tmax) tavg = t; call mpp_sum(tavg); tavg = tavg/mpp_npes() tstd = (t-tavg)**2; call mpp_sum(tstd); tstd = sqrt( tstd/mpp_npes() ) if( pe.EQ.root_pe )write( out_unit,'(a32,4f14.6,f7.3,3i6)' ) & clocks(i)%name, tmin, tmax, tavg, tstd, tavg/t_total, & clocks(i)%grain, minval(peset(clocks(i)%peset_num)%list), & maxval(peset(clocks(i)%peset_num)%list) write(log_unit,'(a32,f14.6)') clocks(i)%name, clocks(i)%total_ticks*tick_rate end do if( ANY(clocks(1:clock_num)%detailed) .AND. pe.EQ.root_pe )write( out_unit,'(/32x,a)' ) & ' tmin tmax tavg tstd mmin mmax mavg mstd mavg/tavg' do i = 1,clock_num !messages: bytelengths and times if( .NOT.clocks(i)%detailed )cycle if( .NOT.ANY(peset(clocks(i)%peset_num)%list(:).EQ.pe) )cycle call mpp_set_current_pelist( peset(clocks(i)%peset_num)%list ) out_unit = stdout() do j = 1,MAX_EVENT_TYPES n = clocks(i)%events(j)%calls; nmax = n call mpp_max(nmax) if( nmax.NE.0 )then !don't divide by n because n might be 0 m = 0 if( n.GT.0 )m = sum(clocks(i)%events(j)%bytes(1:n)) mmin = m; call mpp_min(mmin) mmax = m; call mpp_max(mmax) mavg = m; call mpp_sum(mavg); mavg = mavg/mpp_npes() mstd = (m-mavg)**2; call mpp_sum(mstd); mstd = sqrt( mstd/mpp_npes() ) t = 0 if( n.GT.0 )t = sum(clocks(i)%events(j)%ticks(1:n))*tick_rate tmin = t; call mpp_min(tmin) tmax = t; call mpp_max(tmax) tavg = t; call mpp_sum(tavg); tavg = tavg/mpp_npes() tstd = (t-tavg)**2; call mpp_sum(tstd); tstd = sqrt( tstd/mpp_npes() ) if( pe.EQ.root_pe )write( out_unit,'(a32,4f11.3,5es11.3)' ) & trim(clocks(i)%name)//' '//trim(clocks(i)%events(j)%name), & tmin, tmax, tavg, tstd, mmin, mmax, mavg, mstd, mavg/tavg end if end do end do end if call FLUSH( out_unit ) ! close down etc_unit: 9 inquire(unit=etc_unit, opened=opened) if (opened) then call FLUSH (etc_unit) close(etc_unit) endif ! Clear derived data types (skipping list head, mpp_byte) dtype => datatypes%head do while (.not. associated(dtype)) dtype => dtype%next dtype%counter = 1 ! Force deallocation call mpp_type_free(dtype) end do call mpp_set_current_pelist() call mpp_sync() call mpp_max(mpp_stack_hwm) if( pe.EQ.root_pe )write( out_unit,* )'MPP_STACK high water mark=', mpp_stack_hwm if(mpp_comm_private == MPI_COMM_WORLD ) call MPI_FINALIZE(error) return end subroutine mpp_exit !####################################################################### subroutine mpp_malloc( ptr, newlen, len ) integer, intent(in) :: newlen integer, intent(inout) :: len # 349 integer(8), intent(in) :: ptr call mpp_error( FATAL, 'mpp_malloc: requires use_MPI_SMA' ) return end subroutine mpp_malloc # 390 !####################################################################### !set the mpp_stack variable to be at least n LONG words long subroutine mpp_set_stack_size(n) integer, intent(in) :: n character(len=8) :: text if( n.GT.mpp_stack_size .AND. allocated(mpp_stack) )deallocate(mpp_stack) if( .NOT.allocated(mpp_stack) )then allocate( mpp_stack(n) ) mpp_stack_size = n end if write( text,'(i8)' )n if( pe.EQ.root_pe )call mpp_error( NOTE, 'MPP_SET_STACK_SIZE: stack size set to '//text//'.' ) return end subroutine mpp_set_stack_size !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! BASIC MESSAGE PASSING ROUTINE: mpp_transmit ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_char(data, length, from_pe, pelist ) character(len=*), intent(inout) :: data(:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, out_unit character :: str1D(length*size(data(:))) pointer(lptr, str1D) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'mpp_broadcast_text: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) if(mpp_pe() == mpp_root_pe()) then write( stdout_unit,'(a,i18,a,i5,a,2i5,2i8)' )& 'T=',tick, ' PE=',pe, 'mpp_broadcast_text begin: from_pe, length=', from_pe, length endif end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'mpp_broadcast_text: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo lptr = LOC (data) if( mpp_npes().GT.1 ) call MPI_BCAST( data, length*size(data(:)), MPI_CHARACTER, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length ) return end subroutine mpp_broadcast_char # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_real8( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous real(8) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe real(8), intent(in) :: put_data(*) real(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i real(8), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_REAL8, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_REAL8, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*8 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_REAL8, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_REAL8, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_REAL8, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_REAL8, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_REAL8 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_REAL8, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_real8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_real8( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(8), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_REAL8, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*8 ) return end subroutine mpp_broadcast_real8 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_real8_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe real(8), intent(in) :: put_data real(8), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len real(8) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_real8 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real8_scalar subroutine mpp_transmit_real8_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(8), intent(in) :: put_data(:,:) real(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real8_2d subroutine mpp_transmit_real8_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(8), intent(in) :: put_data(:,:,:) real(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real8_3d subroutine mpp_transmit_real8_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(8), intent(in) :: put_data(:,:,:,:) real(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real8_4d subroutine mpp_transmit_real8_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(8), intent(in) :: put_data(:,:,:,:,:) real(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_real8( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real8 subroutine mpp_send_real8( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(8), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_real8 subroutine mpp_recv_real8_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe real(8), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len real(8) :: get_data1D(1) real(8) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_real8_scalar subroutine mpp_send_real8_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe real(8), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len real(8) :: put_data1D(1) real(8) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real8_scalar subroutine mpp_recv_real8_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real8_2d subroutine mpp_send_real8_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(8), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real8_2d subroutine mpp_recv_real8_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real8_3d subroutine mpp_send_real8_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(8), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real8_3d subroutine mpp_recv_real8_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real8_4d subroutine mpp_send_real8_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(8), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real8_4d subroutine mpp_recv_real8_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real8_5d subroutine mpp_send_real8_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(8), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(8) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_real8_scalar( data, from_pe, pelist ) real(8), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) real(8) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_real8( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_real8_scalar subroutine mpp_broadcast_real8_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(8), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real8_2d subroutine mpp_broadcast_real8_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(8), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real8_3d subroutine mpp_broadcast_real8_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(8), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real8_4d subroutine mpp_broadcast_real8_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(8), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real8_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 507 "../mpp/include/mpp_comm_mpi.inc" 2 # 564 # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_real4( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous real(4) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe real(4), intent(in) :: put_data(*) real(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i real(4), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_REAL4, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_REAL4, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*4 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_REAL4, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_REAL4, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_REAL4, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_REAL4, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_REAL4 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_REAL4, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_real4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_real4( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(4), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_REAL4, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*4 ) return end subroutine mpp_broadcast_real4 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_real4_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe real(4), intent(in) :: put_data real(4), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len real(4) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_real4 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real4_scalar subroutine mpp_transmit_real4_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(4), intent(in) :: put_data(:,:) real(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real4_2d subroutine mpp_transmit_real4_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(4), intent(in) :: put_data(:,:,:) real(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real4_3d subroutine mpp_transmit_real4_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(4), intent(in) :: put_data(:,:,:,:) real(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real4_4d subroutine mpp_transmit_real4_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe real(4), intent(in) :: put_data(:,:,:,:,:) real(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request real(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_real4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_real4( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real4 subroutine mpp_send_real4( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(4), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_real4 subroutine mpp_recv_real4_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe real(4), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len real(4) :: get_data1D(1) real(4) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_real4_scalar subroutine mpp_send_real4_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe real(4), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len real(4) :: put_data1D(1) real(4) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real4_scalar subroutine mpp_recv_real4_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real4_2d subroutine mpp_send_real4_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(4), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real4_2d subroutine mpp_recv_real4_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real4_3d subroutine mpp_send_real4_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(4), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real4_3d subroutine mpp_recv_real4_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real4_4d subroutine mpp_send_real4_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(4), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real4_4d subroutine mpp_recv_real4_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe real(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_real4_5d subroutine mpp_send_real4_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe real(4), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request real(4) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_real4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_real4_scalar( data, from_pe, pelist ) real(4), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) real(4) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_real4( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_real4_scalar subroutine mpp_broadcast_real4_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(4), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real4_2d subroutine mpp_broadcast_real4_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(4), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real4_3d subroutine mpp_broadcast_real4_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(4), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real4_4d subroutine mpp_broadcast_real4_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. real(4), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) real(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_real4_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 621 "../mpp/include/mpp_comm_mpi.inc" 2 # 678 # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_int8( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous integer(8) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(8), intent(in) :: put_data(*) integer(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i integer(8), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_INTEGER8, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_INTEGER8, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*8 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_INTEGER8, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_INTEGER8 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_INTEGER8, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_int8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_int8( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(8), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_INTEGER8, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*8 ) return end subroutine mpp_broadcast_int8 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_int8_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe integer(8), intent(in) :: put_data integer(8), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len integer(8) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_int8 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int8_scalar subroutine mpp_transmit_int8_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(8), intent(in) :: put_data(:,:) integer(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int8_2d subroutine mpp_transmit_int8_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(8), intent(in) :: put_data(:,:,:) integer(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int8_3d subroutine mpp_transmit_int8_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(8), intent(in) :: put_data(:,:,:,:) integer(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int8_4d subroutine mpp_transmit_int8_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(8), intent(in) :: put_data(:,:,:,:,:) integer(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_int8( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int8 subroutine mpp_send_int8( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(8), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_int8 subroutine mpp_recv_int8_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe integer(8), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len integer(8) :: get_data1D(1) integer(8) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_int8_scalar subroutine mpp_send_int8_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe integer(8), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len integer(8) :: put_data1D(1) integer(8) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int8_scalar subroutine mpp_recv_int8_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int8_2d subroutine mpp_send_int8_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(8), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int8_2d subroutine mpp_recv_int8_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int8_3d subroutine mpp_send_int8_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(8), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int8_3d subroutine mpp_recv_int8_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int8_4d subroutine mpp_send_int8_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(8), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int8_4d subroutine mpp_recv_int8_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int8_5d subroutine mpp_send_int8_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(8), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(8) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_int8_scalar( data, from_pe, pelist ) integer(8), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) integer(8) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_int8( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_int8_scalar subroutine mpp_broadcast_int8_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(8), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int8_2d subroutine mpp_broadcast_int8_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(8), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int8_3d subroutine mpp_broadcast_int8_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(8), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int8_4d subroutine mpp_broadcast_int8_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(8), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int8_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 736 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_int4( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous integer(4) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(4), intent(in) :: put_data(*) integer(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i integer(4), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_INTEGER4, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_INTEGER4, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*4 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_INTEGER4, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_INTEGER4 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_INTEGER4, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_int4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_int4( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(4), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_INTEGER4, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*4 ) return end subroutine mpp_broadcast_int4 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_int4_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe integer(4), intent(in) :: put_data integer(4), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len integer(4) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_int4 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int4_scalar subroutine mpp_transmit_int4_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(4), intent(in) :: put_data(:,:) integer(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int4_2d subroutine mpp_transmit_int4_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(4), intent(in) :: put_data(:,:,:) integer(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int4_3d subroutine mpp_transmit_int4_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(4), intent(in) :: put_data(:,:,:,:) integer(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int4_4d subroutine mpp_transmit_int4_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe integer(4), intent(in) :: put_data(:,:,:,:,:) integer(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_int4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_int4( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int4 subroutine mpp_send_int4( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(4), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_int4 subroutine mpp_recv_int4_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe integer(4), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len integer(4) :: get_data1D(1) integer(4) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_int4_scalar subroutine mpp_send_int4_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe integer(4), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len integer(4) :: put_data1D(1) integer(4) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int4_scalar subroutine mpp_recv_int4_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int4_2d subroutine mpp_send_int4_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(4), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int4_2d subroutine mpp_recv_int4_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int4_3d subroutine mpp_send_int4_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(4), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int4_3d subroutine mpp_recv_int4_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int4_4d subroutine mpp_send_int4_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(4), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int4_4d subroutine mpp_recv_int4_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe integer(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_int4_5d subroutine mpp_send_int4_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe integer(4), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request integer(4) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_int4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_int4_scalar( data, from_pe, pelist ) integer(4), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) integer(4) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_int4( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_int4_scalar subroutine mpp_broadcast_int4_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(4), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int4_2d subroutine mpp_broadcast_int4_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(4), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int4_3d subroutine mpp_broadcast_int4_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(4), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int4_4d subroutine mpp_broadcast_int4_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. integer(4), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_int4_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 793 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_logical8( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous logical(8) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(8), intent(in) :: put_data(*) logical(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i logical(8), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_INTEGER8, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_INTEGER8, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*8 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_INTEGER8, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_INTEGER8, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_INTEGER8 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_INTEGER8, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*8 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_logical8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_logical8( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(8), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_INTEGER8, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*8 ) return end subroutine mpp_broadcast_logical8 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_logical8_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe logical(8), intent(in) :: put_data logical(8), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len logical(8) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_logical8 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical8_scalar subroutine mpp_transmit_logical8_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(8), intent(in) :: put_data(:,:) logical(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical8_2d subroutine mpp_transmit_logical8_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(8), intent(in) :: put_data(:,:,:) logical(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical8_3d subroutine mpp_transmit_logical8_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(8), intent(in) :: put_data(:,:,:,:) logical(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical8_4d subroutine mpp_transmit_logical8_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(8), intent(in) :: put_data(:,:,:,:,:) logical(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(8) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_logical8( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(8), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical8 subroutine mpp_send_logical8( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(8), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_logical8 subroutine mpp_recv_logical8_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe logical(8), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len logical(8) :: get_data1D(1) logical(8) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_logical8_scalar subroutine mpp_send_logical8_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe logical(8), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len logical(8) :: put_data1D(1) logical(8) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical8_scalar subroutine mpp_recv_logical8_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(8), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical8_2d subroutine mpp_send_logical8_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(8), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical8_2d subroutine mpp_recv_logical8_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(8), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical8_3d subroutine mpp_send_logical8_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(8), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical8_3d subroutine mpp_recv_logical8_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(8), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical8_4d subroutine mpp_send_logical8_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(8), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical8_4d subroutine mpp_recv_logical8_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(8), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical8_5d subroutine mpp_send_logical8_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(8), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(8) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical8_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_logical8_scalar( data, from_pe, pelist ) logical(8), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) logical(8) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_logical8( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_logical8_scalar subroutine mpp_broadcast_logical8_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(8), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical8_2d subroutine mpp_broadcast_logical8_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(8), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical8_3d subroutine mpp_broadcast_logical8_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(8), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical8_4d subroutine mpp_broadcast_logical8_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(8), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(8) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical8_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 850 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_transmit_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_logical4( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) !a message-passing routine intended to be reminiscent equally of both MPI and SHMEM !put_data and get_data are contiguous logical(4) arrays !at each call, your put_data array is put to to_pe's get_data ! your get_data array is got from from_pe's put_data !i.e we assume that typically (e.g updating halo regions) each PE performs a put _and_ a get !special PE designations: ! NULL_PE: to disable a put or a get (e.g at boundaries) ! ANY_PE: if remote PE for the put or get is to be unspecific ! ALL_PES: broadcast and collect operations (collect not yet implemented) !ideally we would not pass length, but this f77-style call performs better (arrays passed by address, not descriptor) !further, this permits contiguous words from an array of any rank to be passed (avoiding f90 rank conformance check) !caller is responsible for completion checks (mpp_sync_self) before and after integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(4), intent(in) :: put_data(*) logical(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i logical(4), allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_TRANSMIT: You must first call mpp_init.' ) if( to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE )return block_comm = .true. if(PRESENT(block)) block_comm = block if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT begin: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag = DEFAULT_TAG if(present(tag)) comm_tag = tag !do put first and then get if( to_pe.GE.0 .AND. to_pe.LT.npes )then !use non-blocking sends if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) !z1l: truly non-blocking send. ! if( request(to_pe).NE.MPI_REQUEST_NULL )then !only one message from pe->to_pe in queue ! if( debug )write( stderr(),* )'PE waiting for sending', pe, to_pe ! call MPI_WAIT( request(to_pe), stat, error ) ! end if if(present(send_request)) then call MPI_ISEND( put_data, put_len, MPI_INTEGER4, to_pe, comm_tag, mpp_comm_private, send_request, error) else cur_send_request = cur_send_request + 1 if( cur_send_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_send_request is greater than max_request, increase mpp_nml request_multiply") call MPI_ISEND( put_data, put_len, MPI_INTEGER4, to_pe, comm_tag, mpp_comm_private, request_send(cur_send_request), error) endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_SEND, put_len*4 ) else if( to_pe.EQ.ALL_PES )then !this is a broadcast from from_pe if( from_pe.LT.0 .OR. from_pe.GE.npes )call mpp_error( FATAL, 'MPP_TRANSMIT: broadcasting from invalid PE.' ) if( put_len.GT.get_len )call mpp_error( FATAL, 'MPP_TRANSMIT: size mismatch between put_data and get_data.' ) if( pe.EQ.from_pe )then if( LOC(get_data).NE.LOC(put_data) )then !dir$ IVDEP do i = 1,get_len get_data(i) = put_data(i) end do end if end if call mpp_broadcast( get_data, get_len, from_pe ) return else if( to_pe.EQ.ANY_PE )then !we don't have a destination to do puts to, so only do gets !...but you cannot have a pure get with MPI call mpp_error( FATAL, 'MPP_TRANSMIT: you cannot transmit to ANY_PE using MPI.' ) else if( to_pe.NE.NULL_PE )then !no other valid cases except NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid to_pe.' ) end if !do the get: for libSMA, a get means do a wait to ensure put on remote PE is complete if( from_pe.GE.0 .AND. from_pe.LT.npes )then !receive from from_pe if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( block_comm ) then call MPI_RECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, stat, error ) call MPI_GET_COUNT( stat, MPI_INTEGER4, rsize, error) if(rsize .NE. get_len) then print*, "rsize, get_len=", rsize, get_len, mpp_pe(), from_pe call mpp_error(FATAL, "MPP_TRANSMIT: get_len does not match size of data received") endif else ! if( request_recv(from_pe).NE.MPI_REQUEST_NULL )then !only one message from from_pe->pe in queue ! if( debug )write( stderr(),* )'PE waiting for receiving', pe, from_pe ! call MPI_WAIT( request_recv(from_pe), stat, error ) ! end if if(PRESENT(recv_request)) then call MPI_IRECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, & recv_request, error ) else cur_recv_request = cur_recv_request + 1 if( cur_recv_request > max_request ) call mpp_error(FATAL, & "MPP_TRANSMIT: cur_recv_request is greater than max_request, increase mpp_nml request_multiply") call MPI_IRECV( get_data, get_len, MPI_INTEGER4, from_pe, comm_tag, mpp_comm_private, & request_recv(cur_recv_request), error ) size_recv(cur_recv_request) = get_len type_recv(cur_recv_request) = MPI_INTEGER4 endif endif if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ANY_PE )then !receive from MPI_ANY_SOURCE if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) call MPI_RECV( get_data, get_len, MPI_INTEGER4, MPI_ANY_SOURCE, comm_tag, mpp_comm_private, stat, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_RECV, get_len*4 ) else if( from_pe.EQ.ALL_PES )then call mpp_error( FATAL, 'MPP_TRANSMIT: from_pe=ALL_PES has ambiguous meaning, and hence is not implemented.' ) else if( from_pe.NE.NULL_PE )then !only remaining valid choice is NULL_PE call mpp_error( FATAL, 'MPP_TRANSMIT: invalid from_pe.' ) end if if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_TRANSMIT end: to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if return end subroutine mpp_transmit_logical4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_logical4( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(4), intent(inout) :: data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_BROADCAST: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug )then call system_clock_mpi(tick) write( stdout_unit,'(a,i18,a,i6,a,2i6,2i8)' )& 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) ! find the rank of from_pe in the pelist. do i = 1, mpp_npes() if(peset(n)%list(i) == from_pe) then from_rank = i - 1 exit endif enddo if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_INTEGER4, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*4 ) return end subroutine mpp_broadcast_logical4 !#################################################################################### # 1 "../mpp/include/mpp_transmit.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_TRANSMIT ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_transmit_logical4_scalar( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, recv_request, send_request) integer, intent(in) :: to_pe, from_pe logical(4), intent(in) :: put_data logical(4), intent(out) :: get_data integer, optional, intent(in) :: plen, glen logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request integer :: put_len, get_len logical(4) :: put_data1D(1), get_data1D(1) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit_logical4 ( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical4_scalar subroutine mpp_transmit_logical4_2d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(4), intent(in) :: put_data(:,:) logical(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical4_2d subroutine mpp_transmit_logical4_3d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(4), intent(in) :: put_data(:,:,:) logical(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical4_3d subroutine mpp_transmit_logical4_4d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(4), intent(in) :: put_data(:,:,:,:) logical(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical4_4d subroutine mpp_transmit_logical4_5d( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request ) integer, intent(in) :: put_len, to_pe, get_len, from_pe logical(4), intent(in) :: put_data(:,:,:,:,:) logical(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: recv_request, send_request logical(4) :: put_data1D(put_len), get_data1D(get_len) pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & recv_request=recv_request, send_request=send_request ) return end subroutine mpp_transmit_logical4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_SEND and RECV ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_recv_logical4( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(4), intent(out) :: get_data(*) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical4 subroutine mpp_send_logical4( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(4), intent(in) :: put_data(*) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag=tag, send_request=request ) end subroutine mpp_send_logical4 subroutine mpp_recv_logical4_scalar( get_data, from_pe, glen, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: from_pe logical(4), intent(out) :: get_data logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request integer, optional, intent(in) :: glen integer :: get_len logical(4) :: get_data1D(1) logical(4) :: dummy(1) pointer( ptr, get_data1D ) ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request) end subroutine mpp_recv_logical4_scalar subroutine mpp_send_logical4_scalar( put_data, to_pe, plen, tag, request) !a mpp_transmit with null arguments on the get side integer, intent(in) :: to_pe logical(4), intent(in) :: put_data integer, optional, intent(in) :: plen integer, intent(in), optional :: tag integer, intent(out), optional :: request integer :: put_len logical(4) :: put_data1D(1) logical(4) :: dummy(1) pointer( ptr, put_data1D ) ptr = LOC(put_data) put_len=1; if(PRESENT(plen))put_len=plen call mpp_transmit( put_data1D, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical4_scalar subroutine mpp_recv_logical4_2d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(4), intent(out) :: get_data(:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical4_2d subroutine mpp_send_logical4_2d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(4), intent(in) :: put_data(:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical4_2d subroutine mpp_recv_logical4_3d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(4), intent(out) :: get_data(:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical4_3d subroutine mpp_send_logical4_3d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(4), intent(in) :: put_data(:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical4_3d subroutine mpp_recv_logical4_4d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(4), intent(out) :: get_data(:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical4_4d subroutine mpp_send_logical4_4d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(4), intent(in) :: put_data(:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical4_4d subroutine mpp_recv_logical4_5d( get_data, get_len, from_pe, block, tag, request ) !a mpp_transmit with null arguments on the put side integer, intent(in) :: get_len, from_pe logical(4), intent(out) :: get_data(:,:,:,:,:) logical, intent(in), optional :: block integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1,1,1) call mpp_transmit( dummy, 1, NULL_PE, get_data, get_len, from_pe, block, tag, recv_request=request ) end subroutine mpp_recv_logical4_5d subroutine mpp_send_logical4_5d( put_data, put_len, to_pe, tag, request ) !a mpp_transmit with null arguments on the get side integer, intent(in) :: put_len, to_pe logical(4), intent(in) :: put_data(:,:,:,:,:) integer, intent(in), optional :: tag integer, intent(out), optional :: request logical(4) :: dummy(1,1,1,1,1) call mpp_transmit( put_data, put_len, to_pe, dummy, 1, NULL_PE, tag = tag, send_request=request ) end subroutine mpp_send_logical4_5d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! MPP_BROADCAST ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mpp_broadcast_logical4_scalar( data, from_pe, pelist ) logical(4), intent(inout) :: data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) logical(4) :: data1D(1) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast_logical4( data1D, 1, from_pe, pelist ) return end subroutine mpp_broadcast_logical4_scalar subroutine mpp_broadcast_logical4_2d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(4), intent(inout) :: data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical4_2d subroutine mpp_broadcast_logical4_3d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(4), intent(inout) :: data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical4_3d subroutine mpp_broadcast_logical4_4d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(4), intent(inout) :: data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical4_4d subroutine mpp_broadcast_logical4_5d( data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. logical(4), intent(inout) :: data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) logical(4) :: data1D(length) pointer( ptr, data1D ) ptr = LOC(data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine mpp_broadcast_logical4_5d # 200 "../mpp/include/mpp_transmit_mpi.h" 2 # 907 "../mpp/include/mpp_comm_mpi.inc" 2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! GLOBAL REDUCTION ROUTINES: mpp_max, mpp_sum, mpp_min ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_max_real8_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(8), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n real(8) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_REAL8, MPI_MAX, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_max_real8_0d subroutine mpp_max_real8_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(8), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n real(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_REAL8, MPI_MAX, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_max_real8_1d # 926 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_max_real4_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(4), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n real(4) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_REAL4, MPI_MAX, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_max_real4_0d subroutine mpp_max_real4_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(4), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n real(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_REAL4, MPI_MAX, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_max_real4_1d # 941 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_max_int8_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(8), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n integer(8) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_INTEGER8, MPI_MAX, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_max_int8_0d subroutine mpp_max_int8_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(8), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n integer(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_INTEGER8, MPI_MAX, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_max_int8_1d # 957 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_max_int4_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(4), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n integer(4) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_INTEGER4, MPI_MAX, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_max_int4_0d subroutine mpp_max_int4_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(4), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n integer(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_INTEGER4, MPI_MAX, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_max_int4_1d # 972 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_min_real8_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(8), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n real(8) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_REAL8, MPI_MIN, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_min_real8_0d subroutine mpp_min_real8_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(8), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n real(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_REAL8, MPI_MIN, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_min_real8_1d # 986 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_min_real4_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(4), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n real(4) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_REAL4, MPI_MIN, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_min_real4_0d subroutine mpp_min_real4_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs real(4), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n real(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_REAL4, MPI_MIN, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_min_real4_1d # 1001 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_min_int8_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(8), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n integer(8) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_INTEGER8, MPI_MIN, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_min_int8_0d subroutine mpp_min_int8_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(8), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n integer(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_INTEGER8, MPI_MIN, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 8 ) return end subroutine mpp_min_int8_1d # 1017 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_reduce_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_min_int4_0d( a, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(4), intent(inout) :: a integer, intent(in), optional :: pelist(0:) integer :: n integer(4) :: work if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_0D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_0D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, 1, MPI_INTEGER4, MPI_MIN, peset(n)%id, error ) a = work if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_min_int4_0d subroutine mpp_min_int4_1d( a, length, pelist ) !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast to all PEs integer(4), intent(inout) :: a(:) integer, intent(in) :: length integer, intent(in), optional :: pelist(0:) integer :: n integer(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE_1D: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_1D_: using MPI_ALLREDUCE...' ) call MPI_ALLREDUCE( a, work, length, MPI_INTEGER4, MPI_MIN, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, 4 ) return end subroutine mpp_min_int4_1d # 1032 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_sum_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_real8( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8), intent(inout) :: a(*) integer :: n, errunit real(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call MPI_ALLREDUCE( a, work, length, MPI_REAL8, MPI_SUM, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*8 ) return end subroutine mpp_sum_real8 !####################################################################### # 1 "../mpp/include/mpp_sum.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_real8_scalar( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_real8 real(8), intent(inout) :: a integer, intent(in), optional :: pelist(:) real(8) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_real8( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_real8_scalar !####################################################################### subroutine mpp_sum_real8_2d( a, length, pelist ) real(8), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real8_2d !####################################################################### subroutine mpp_sum_real8_3d( a, length, pelist ) real(8), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real8_3d !####################################################################### subroutine mpp_sum_real8_4d( a, length, pelist ) real(8), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real8_4d !####################################################################### subroutine mpp_sum_real8_5d( a, length, pelist ) real(8), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real8_5d # 47 "../mpp/include/mpp_sum_mpi.h" 2 # 1052 "../mpp/include/mpp_comm_mpi.inc" 2 # 1073 # 1 "../mpp/include/mpp_sum_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_real4( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4), intent(inout) :: a(*) integer :: n, errunit real(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call MPI_ALLREDUCE( a, work, length, MPI_REAL4, MPI_SUM, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*4 ) return end subroutine mpp_sum_real4 !####################################################################### # 1 "../mpp/include/mpp_sum.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_real4_scalar( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_real4 real(4), intent(inout) :: a integer, intent(in), optional :: pelist(:) real(4) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_real4( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_real4_scalar !####################################################################### subroutine mpp_sum_real4_2d( a, length, pelist ) real(4), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real4_2d !####################################################################### subroutine mpp_sum_real4_3d( a, length, pelist ) real(4), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real4_3d !####################################################################### subroutine mpp_sum_real4_4d( a, length, pelist ) real(4), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real4_4d !####################################################################### subroutine mpp_sum_real4_5d( a, length, pelist ) real(4), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_real4_5d # 47 "../mpp/include/mpp_sum_mpi.h" 2 # 1095 "../mpp/include/mpp_comm_mpi.inc" 2 # 1117 # 1 "../mpp/include/mpp_sum_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_int8( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8), intent(inout) :: a(*) integer :: n, errunit integer(8) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call MPI_ALLREDUCE( a, work, length, MPI_INTEGER8, MPI_SUM, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*8 ) return end subroutine mpp_sum_int8 !####################################################################### # 1 "../mpp/include/mpp_sum.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_int8_scalar( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int8 integer(8), intent(inout) :: a integer, intent(in), optional :: pelist(:) integer(8) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_int8( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_int8_scalar !####################################################################### subroutine mpp_sum_int8_2d( a, length, pelist ) integer(8), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int8_2d !####################################################################### subroutine mpp_sum_int8_3d( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int8_3d !####################################################################### subroutine mpp_sum_int8_4d( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int8_4d !####################################################################### subroutine mpp_sum_int8_5d( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int8_5d # 47 "../mpp/include/mpp_sum_mpi.h" 2 # 1139 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_sum_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_int4( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4), intent(inout) :: a(*) integer :: n, errunit integer(4) :: work(length) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call MPI_ALLREDUCE( a, work, length, MPI_INTEGER4, MPI_SUM, peset(n)%id, error ) a(1:length) = work(1:length) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*4 ) return end subroutine mpp_sum_int4 !####################################################################### # 1 "../mpp/include/mpp_sum.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_int4_scalar( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int4 integer(4), intent(inout) :: a integer, intent(in), optional :: pelist(:) integer(4) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_int4( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_int4_scalar !####################################################################### subroutine mpp_sum_int4_2d( a, length, pelist ) integer(4), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int4_2d !####################################################################### subroutine mpp_sum_int4_3d( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int4_3d !####################################################################### subroutine mpp_sum_int4_4d( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int4_4d !####################################################################### subroutine mpp_sum_int4_5d( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum( a1D, length, pelist ) return end subroutine mpp_sum_int4_5d # 47 "../mpp/include/mpp_sum_mpi.h" 2 # 1160 "../mpp/include/mpp_comm_mpi.inc" 2 !-------------------------------- # 1 "../mpp/include/mpp_sum_mpi_ad.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_real8_ad( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8), intent(inout) :: a(*) integer :: n, errunit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call mpp_broadcast(a, length, peset(n)%list(1), PELIST=pelist) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*8 ) return end subroutine mpp_sum_real8_ad !####################################################################### # 1 "../mpp/include/mpp_sum_ad.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_real8_scalar_ad( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int4 real(8), intent(inout) :: a integer, intent(in), optional :: pelist(:) real(8) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_real8_ad( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_real8_scalar_ad !####################################################################### subroutine mpp_sum_real8_2d_ad( a, length, pelist ) real(8), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real8_2d_ad !####################################################################### subroutine mpp_sum_real8_3d_ad( a, length, pelist ) real(8), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real8_3d_ad !####################################################################### subroutine mpp_sum_real8_4d_ad( a, length, pelist ) real(8), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real8_4d_ad !####################################################################### subroutine mpp_sum_real8_5d_ad( a, length, pelist ) real(8), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real8_5d_ad # 49 "../mpp/include/mpp_sum_mpi_ad.h" 2 # 1180 "../mpp/include/mpp_comm_mpi.inc" 2 # 1201 # 1 "../mpp/include/mpp_sum_mpi_ad.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_real4_ad( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4), intent(inout) :: a(*) integer :: n, errunit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call mpp_broadcast(a, length, peset(n)%list(1), PELIST=pelist) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*4 ) return end subroutine mpp_sum_real4_ad !####################################################################### # 1 "../mpp/include/mpp_sum_ad.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_real4_scalar_ad( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int4 real(4), intent(inout) :: a integer, intent(in), optional :: pelist(:) real(4) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_real4_ad( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_real4_scalar_ad !####################################################################### subroutine mpp_sum_real4_2d_ad( a, length, pelist ) real(4), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real4_2d_ad !####################################################################### subroutine mpp_sum_real4_3d_ad( a, length, pelist ) real(4), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real4_3d_ad !####################################################################### subroutine mpp_sum_real4_4d_ad( a, length, pelist ) real(4), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real4_4d_ad !####################################################################### subroutine mpp_sum_real4_5d_ad( a, length, pelist ) real(4), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) real(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_real4_5d_ad # 49 "../mpp/include/mpp_sum_mpi_ad.h" 2 # 1223 "../mpp/include/mpp_comm_mpi.inc" 2 # 1245 # 1 "../mpp/include/mpp_sum_mpi_ad.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_int8_ad( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8), intent(inout) :: a(*) integer :: n, errunit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call mpp_broadcast(a, length, peset(n)%list(1), PELIST=pelist) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*8 ) return end subroutine mpp_sum_int8_ad !####################################################################### # 1 "../mpp/include/mpp_sum_ad.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_int8_scalar_ad( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int4 integer(8), intent(inout) :: a integer, intent(in), optional :: pelist(:) integer(8) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_int8_ad( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_int8_scalar_ad !####################################################################### subroutine mpp_sum_int8_2d_ad( a, length, pelist ) integer(8), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int8_2d_ad !####################################################################### subroutine mpp_sum_int8_3d_ad( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int8_3d_ad !####################################################################### subroutine mpp_sum_int8_4d_ad( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int8_4d_ad !####################################################################### subroutine mpp_sum_int8_5d_ad( a, length, pelist ) integer(8), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(8) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int8_5d_ad # 49 "../mpp/include/mpp_sum_mpi_ad.h" 2 # 1267 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_sum_mpi_ad.h" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_sum_int4_ad( a, length, pelist ) !sums array a over the PEs in pelist (all PEs if this argument is omitted) !result is also automatically broadcast: all PEs have the sum in a at the end !we are using f77-style call: array passed by address and not descriptor; further, !the f90 conformance check is avoided. integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4), intent(inout) :: a(*) integer :: n, errunit if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) n = get_peset(pelist); if( peset(n)%count.EQ.1 )return if( debug .and. (current_clock.NE.0) )call system_clock_mpi(start_tick) if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) if( debug ) then errunit = stderr() write( errunit,* )'pe, n, peset(n)%id=', pe, n, peset(n)%id endif call mpp_broadcast(a, length, peset(n)%list(1), PELIST=pelist) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_ALLREDUCE, length*4 ) return end subroutine mpp_sum_int4_ad !####################################################################### # 1 "../mpp/include/mpp_sum_ad.inc" 1 ! -*-f90-*- !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** !####################################################################### subroutine mpp_sum_int4_scalar_ad( a, pelist ) !sums array a when only first element is passed: this routine just converts to a call to mpp_sum_int4 integer(4), intent(inout) :: a integer, intent(in), optional :: pelist(:) integer(4) :: b(1) b(1) = a if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) call mpp_sum_int4_ad( b, 1, pelist ) a = b(1) return end subroutine mpp_sum_int4_scalar_ad !####################################################################### subroutine mpp_sum_int4_2d_ad( a, length, pelist ) integer(4), intent(inout) :: a(:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int4_2d_ad !####################################################################### subroutine mpp_sum_int4_3d_ad( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int4_3d_ad !####################################################################### subroutine mpp_sum_int4_4d_ad( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int4_4d_ad !####################################################################### subroutine mpp_sum_int4_5d_ad( a, length, pelist ) integer(4), intent(inout) :: a(:,:,:,:,:) integer, intent(in) :: length integer, intent(in), optional :: pelist(:) integer(4) :: a1D(length) pointer( ptr, a1D ) ptr = LOC(a) call mpp_sum_ad( a1D, length, pelist ) return end subroutine mpp_sum_int4_5d_ad # 49 "../mpp/include/mpp_sum_mpi_ad.h" 2 # 1288 "../mpp/include/mpp_comm_mpi.inc" 2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! SCATTER AND GATHER ROUTINES: mpp_alltoall ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_int4(sbuf, scount, rbuf, rcount, pelist) integer(4), intent(in) :: sbuf(:) integer(4), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_INTEGER4, rbuf, rcount, MPI_INTEGER4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_int4 subroutine mpp_alltoall_int4_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) integer(4), intent(in) :: sbuf(:) integer(4), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_INTEGER4, & rbuf, rsize, rdispl, MPI_INTEGER4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_int4_v subroutine mpp_alltoall_int4_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) integer(4), intent(in) :: sbuf(:) integer(4), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_int4_w # 1308 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_int8(sbuf, scount, rbuf, rcount, pelist) integer(8), intent(in) :: sbuf(:) integer(8), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_INTEGER8, rbuf, rcount, MPI_INTEGER8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_int8 subroutine mpp_alltoall_int8_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) integer(8), intent(in) :: sbuf(:) integer(8), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_INTEGER8, & rbuf, rsize, rdispl, MPI_INTEGER8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_int8_v subroutine mpp_alltoall_int8_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) integer(8), intent(in) :: sbuf(:) integer(8), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_int8_w # 1322 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_real4(sbuf, scount, rbuf, rcount, pelist) real(4), intent(in) :: sbuf(:) real(4), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_REAL4, rbuf, rcount, MPI_REAL4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_real4 subroutine mpp_alltoall_real4_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) real(4), intent(in) :: sbuf(:) real(4), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_REAL4, & rbuf, rsize, rdispl, MPI_REAL4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_real4_v subroutine mpp_alltoall_real4_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) real(4), intent(in) :: sbuf(:) real(4), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_real4_w # 1336 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_real8(sbuf, scount, rbuf, rcount, pelist) real(8), intent(in) :: sbuf(:) real(8), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_REAL8, rbuf, rcount, MPI_REAL8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_real8 subroutine mpp_alltoall_real8_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) real(8), intent(in) :: sbuf(:) real(8), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_REAL8, & rbuf, rsize, rdispl, MPI_REAL8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_real8_v subroutine mpp_alltoall_real8_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) real(8), intent(in) :: sbuf(:) real(8), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_real8_w # 1350 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_logical4(sbuf, scount, rbuf, rcount, pelist) logical(4), intent(in) :: sbuf(:) logical(4), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_INTEGER4, rbuf, rcount, MPI_INTEGER4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_logical4 subroutine mpp_alltoall_logical4_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) logical(4), intent(in) :: sbuf(:) logical(4), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_INTEGER4, & rbuf, rsize, rdispl, MPI_INTEGER4, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_logical4_v subroutine mpp_alltoall_logical4_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) logical(4), intent(in) :: sbuf(:) logical(4), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 4) end subroutine mpp_alltoall_logical4_w # 1364 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_alltoall_mpi.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_alltoall_logical8(sbuf, scount, rbuf, rcount, pelist) logical(8), intent(in) :: sbuf(:) logical(8), intent(inout) :: rbuf(:) integer, intent(in) :: scount, rcount integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoall...') ! TODO: Message lengths greater than 1 call MPI_Alltoall(sbuf, scount, MPI_INTEGER8, rbuf, rcount, MPI_INTEGER8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_logical8 subroutine mpp_alltoall_logical8_v(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist) logical(8), intent(in) :: sbuf(:) logical(8), intent(inout) :: rbuf(:) ! TODO: Optionally set displacements to cumulative sums of ssize, rsize integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) integer, intent(in), optional :: pelist(0:) integer :: n if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...') call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_INTEGER8, & rbuf, rsize, rdispl, MPI_INTEGER8, & peset(n)%id, error) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_logical8_v subroutine mpp_alltoall_logical8_w(sbuf, ssize, sdispl, stype, & rbuf, rsize, rdispl, rtype, pelist) logical(8), intent(in) :: sbuf(:) logical(8), intent(inout) :: rbuf(:) integer, intent(in) :: ssize(:), rsize(:) integer, intent(in) :: sdispl(:), rdispl(:) type(mpp_type), intent(in) :: stype(:), rtype(:) integer, intent(in), optional :: pelist(0:) integer :: i, n integer, allocatable :: sendtypes(:), recvtypes(:) if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.') n = get_peset(pelist) if (current_clock .NE. 0) call system_clock_mpi(start_tick) if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...') ! Convert mpp_types to MPI datatype IDs ! NOTE: sendtypes and recvtypes must be the same size allocate(sendtypes(size(stype))) allocate(recvtypes(size(rtype))) do i = 1, size(stype) sendtypes(i) = stype(i)%id recvtypes(i) = rtype(i)%id end do call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, & rbuf, rsize, rdispl, recvtypes, & peset(n)%id, error) deallocate(sendtypes, recvtypes) if (current_clock .NE. 0) & call increment_current_clock(EVENT_ALLTOALL, 8) end subroutine mpp_alltoall_logical8_w # 1378 "../mpp/include/mpp_comm_mpi.inc" 2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! DATA TRANSFER TYPES: mpp_type_create, mpp_type_free ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_int4(field, array_of_subsizes, array_of_starts, & dtype_out) integer(4), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_INTEGER4) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_INTEGER4, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_INTEGER4 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_int4 # 1389 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_int8(field, array_of_subsizes, array_of_starts, & dtype_out) integer(8), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_INTEGER8) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_INTEGER8, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_INTEGER8 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_int8 # 1394 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_real4(field, array_of_subsizes, array_of_starts, & dtype_out) real(4), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_REAL4) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_REAL4, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_REAL4 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_real4 # 1399 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_real8(field, array_of_subsizes, array_of_starts, & dtype_out) real(8), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_REAL8) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_REAL8, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_REAL8 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_real8 # 1404 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_logical4(field, array_of_subsizes, array_of_starts, & dtype_out) logical(4), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_INTEGER4) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_INTEGER4, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_INTEGER4 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_logical4 # 1409 "../mpp/include/mpp_comm_mpi.inc" 2 # 1 "../mpp/include/mpp_type_mpi.h" 1 subroutine mpp_type_create_logical8(field, array_of_subsizes, array_of_starts, & dtype_out) logical(8), intent(in) :: field(:,:,:) integer, intent(in) :: array_of_subsizes(:) integer, intent(in) :: array_of_starts(:) type(mpp_type), target, intent(out) :: dtype_out type(mpp_type), pointer :: dtype integer :: newtype ! MPI datatype ID if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_CREATE_: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_CREATE_: & &using MPI_Type_create_subarray...') dtype => datatypes%head ! TODO: Check mpp_byte ! Check if mpp_type already exists do while (.not. associated(dtype)) dtype => dtype%next if (dtype%ndims /= rank(field)) cycle if (any(dtype%sizes /= shape(field))) cycle if (any(dtype%subsizes /= array_of_subsizes)) cycle if (any(dtype%starts /= array_of_starts)) cycle if (dtype%etype /= MPI_INTEGER8) cycle ! If all parameters match, then the datatype exists and return dtype dtype%counter = dtype%counter + 1 dtype_out = dtype return end do ! The type does not exist; create a new internal type call MPI_Type_create_subarray( & rank(field), & shape(field), & array_of_subsizes, & array_of_starts, & MPI_ORDER_FORTRAN, & MPI_INTEGER8, & newtype, & error & ) ! Register on the MPI runtime call MPI_Type_commit(newtype, error) ! Create new entry allocate(dtype) allocate(dtype%sizes(rank(field))) allocate(dtype%subsizes(rank(field))) allocate(dtype%starts(rank(field))) ! Populate values dtype%counter = 1 dtype%ndims = rank(field) dtype%sizes = shape(field) dtype%subsizes = array_of_subsizes dtype%starts = array_of_starts dtype%etype = MPI_INTEGER8 dtype%id = newtype ! Add dtype to the list dtype%prev => datatypes%tail dtype%prev%next => dtype datatypes%tail => dtype datatypes%length = datatypes%length + 1 ! Copy dtype to output dtype_out = dtype if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_CREATE, 8) end subroutine mpp_type_create_logical8 # 1414 "../mpp/include/mpp_comm_mpi.inc" 2 ! Clear preprocessor flags ! NOTE: This should probably not take a pointer, but for now we do this. subroutine mpp_type_free(dtype) type(mpp_type), pointer, intent(inout) :: dtype if (.NOT. module_is_initialized) & call mpp_error(FATAL, 'MPP_TYPE_FREE: You must first call mpp_init.') if (current_clock .NE. 0) & call system_clock_mpi(start_tick) if (verbose) & call mpp_error(NOTE, 'MPP_TYPE_FREE: using MPI_Type_free...') ! Decrement the reference counter dtype%counter = dtype%counter - 1 if (dtype%counter < 1) then ! De-register the datatype in MPI runtime call MPI_Type_free(dtype%id, error) ! Remove from list dtype%prev => dtype%next ! Remove from memory if (allocated(dtype%sizes)) deallocate(dtype%sizes) if (allocated(dtype%subsizes)) deallocate(dtype%subsizes) if (allocated(dtype%starts)) deallocate(dtype%starts) deallocate(dtype) datatypes%length = datatypes%length - 1 end if if (current_clock .NE. 0) & call increment_current_clock(EVENT_TYPE_FREE, 8) end subroutine mpp_type_free # 26 "../mpp/include/mpp_comm.inc" 2 # 28 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i8_1d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_1d integer(8), intent(in) :: var (:) integer, optional :: pelist(:) integer(8), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i8_1d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i8_1d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i8_1d, pelist ) return end function mpp_chksum_i8_1d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i8_1d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_1d_rmask integer(8), intent(in) :: var (:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i8_1d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i8_1d_rmask # 40 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i8_2d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_2d integer(8), intent(in) :: var (:,:) integer, optional :: pelist(:) integer(8), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i8_2d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i8_2d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i8_2d, pelist ) return end function mpp_chksum_i8_2d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i8_2d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_2d_rmask integer(8), intent(in) :: var (:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i8_2d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i8_2d_rmask # 50 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i8_3d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_3d integer(8), intent(in) :: var (:,:,:) integer, optional :: pelist(:) integer(8), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i8_3d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i8_3d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i8_3d, pelist ) return end function mpp_chksum_i8_3d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i8_3d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_3d_rmask integer(8), intent(in) :: var (:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i8_3d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i8_3d_rmask # 60 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i8_4d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_4d integer(8), intent(in) :: var (:,:,:,:) integer, optional :: pelist(:) integer(8), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i8_4d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i8_4d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i8_4d, pelist ) return end function mpp_chksum_i8_4d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i8_4d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_4d_rmask integer(8), intent(in) :: var (:,:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i8_4d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i8_4d_rmask # 70 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i8_5d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_5d integer(8), intent(in) :: var (:,:,:,:,:) integer, optional :: pelist(:) integer(8), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i8_5d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i8_5d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i8_5d, pelist ) return end function mpp_chksum_i8_5d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i8_5d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i8_5d_rmask integer(8), intent(in) :: var (:,:,:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i8_5d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i8_5d_rmask # 80 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i4_1d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_1d integer(4), intent(in) :: var (:) integer, optional :: pelist(:) integer(4), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i4_1d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i4_1d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i4_1d, pelist ) return end function mpp_chksum_i4_1d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i4_1d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_1d_rmask integer(4), intent(in) :: var (:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i4_1d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i4_1d_rmask # 91 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i4_2d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_2d integer(4), intent(in) :: var (:,:) integer, optional :: pelist(:) integer(4), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i4_2d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i4_2d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i4_2d, pelist ) return end function mpp_chksum_i4_2d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i4_2d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_2d_rmask integer(4), intent(in) :: var (:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i4_2d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i4_2d_rmask # 101 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i4_3d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_3d integer(4), intent(in) :: var (:,:,:) integer, optional :: pelist(:) integer(4), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i4_3d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i4_3d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i4_3d, pelist ) return end function mpp_chksum_i4_3d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i4_3d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_3d_rmask integer(4), intent(in) :: var (:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i4_3d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i4_3d_rmask # 111 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i4_4d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_4d integer(4), intent(in) :: var (:,:,:,:) integer, optional :: pelist(:) integer(4), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i4_4d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i4_4d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i4_4d, pelist ) return end function mpp_chksum_i4_4d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i4_4d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_4d_rmask integer(4), intent(in) :: var (:,:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i4_4d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i4_4d_rmask # 121 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_int.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_i4_5d( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_5d integer(4), intent(in) :: var (:,:,:,:,:) integer, optional :: pelist(:) integer(4), intent(in), optional :: mask_val if ( PRESENT(mask_val) ) then !PACK on var/=mask_val ignores values in var !equiv to setting those values=0, but on sparse arrays !pack should return much smaller array to sum mpp_chksum_i4_5d = sum( INT( PACK(var,var/=mask_val),8) ) else mpp_chksum_i4_5d = sum(INT(var,8)) end if call mpp_sum( mpp_chksum_i4_5d, pelist ) return end function mpp_chksum_i4_5d !Handles real mask for easier implimentation ! until exists full integer vartypes... function mpp_chksum_i4_5d_rmask( var, pelist, mask_val ) integer(8) :: mpp_chksum_i4_5d_rmask integer(4), intent(in) :: var (:,:,:,:,:) integer, optional :: pelist(:) real, intent(in) :: mask_val integer(KIND(var))::imask_val integer(4)::i4tmp(2)=0 real(4)::r4tmp(2)=0 integer(8) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 character(LEN=32) :: tmpStr4,tmpStr5 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. !! These all resolve to MPP_FILL_INT !!Should catch real "default_fill"(MPP_FILL_DOUBLE) if (mask_val == MPP_FILL_DOUBLE ) then !this is FMS variable field default fill ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT !!! Current NETCDF fill values (AKA MPP_FILL_*) designed towards CEILING(MPP_FILL_{FLOAT,DOUBLE},kind=4byte)=MPP_FILL_INT else if ( CEILING(mask_val,4) == MPP_FILL_INT ) then ! we've also packed an MPP_FILL_ imask_val = MPP_FILL_INT ! Secondary Logic: !! We've done something dangerous else i8tmp = TRANSFER(mask_val , i8tmp ) i4tmp = TRANSFER(mask_val , i4tmp ) r4tmp = TRANSFER(mask_val , r4tmp ) if ( i8tmp == MPP_FILL_INT ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(i4tmp == MPP_FILL_INT) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else if ( ANY(r4tmp == MPP_FILL_DOUBLE) ) then ! we've packed an MPP_FILL_ imask_val = MPP_FILL_INT else ! we have no idea what this is ! construct detailed errStr errStr = "mpp_chksum: mpp_chksum_i" write(unit=tmpStr1,fmt="(I1)") KIND(var) write(unit=tmpstr2,fmt="(I1)") SIZE(SHAPE(var)) errStr = errStr // tmpStr1 // "_" // tmpstr2 // "d_rmask passed int var with REAL(" write(unit=tmpstr3,fmt="(I1)") KIND(mask_val) errStr = errStr // tmpstr3 // ") mask_val=" write(unit=tmpstr4,fmt=*) mask_val errStr = errStr // trim(tmpstr4) // "has been called with these strange values. Check your KINDS, _FillValue, pack and mask_val. // & & Hint: Try being explicit and using MPP_FILL_{INT,FLOAT,DOUBLE}. Continuing by using the default MPP_FILL_INT. // & & THIS WILL BE FATAL IN THE FUTURE!" call mpp_error(WARNING, trim(errStr) ) imask_val = MPP_FILL_INT end if end if mpp_chksum_i4_5d_rmask = mpp_chksum(var,pelist,mask_val=imask_val) return end function mpp_chksum_i4_5d_rmask # 131 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum_scalar.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_0d( var, pelist, mask_val ) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !mold and mask_val must be same numBytes, otherwise undefined behavior integer(8) :: mpp_chksum_r8_0d real(8), intent(in) :: var integer, intent(in), optional :: pelist(:) integer(8) :: mold(1) real(8), intent(in), optional :: mask_val pointer( p, mold ) p = LOC(var) if ( PRESENT(mask_val) ) then mpp_chksum_r8_0d = mpp_chksum( mold, pelist, TRANSFER(mask_val, mold(1)) ) else mpp_chksum_r8_0d = mpp_chksum( mold, pelist ) end if return end function mpp_chksum_r8_0d # 139 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_1d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r8_1d integer(8) :: mold(1) real(8), intent(in) :: var (:) integer, intent(in), optional :: pelist(:) real(8), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r8_1d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r8_1d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r8_1d # 147 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_2d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r8_2d integer(8) :: mold(1) real(8), intent(in) :: var (:,:) integer, intent(in), optional :: pelist(:) real(8), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r8_2d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r8_2d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r8_2d # 155 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_3d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r8_3d integer(8) :: mold(1) real(8), intent(in) :: var (:,:,:) integer, intent(in), optional :: pelist(:) real(8), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r8_3d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r8_3d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r8_3d # 163 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_4d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r8_4d integer(8) :: mold(1) real(8), intent(in) :: var (:,:,:,:) integer, intent(in), optional :: pelist(:) real(8), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r8_4d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r8_4d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r8_4d # 171 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r8_5d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r8_5d integer(8) :: mold(1) real(8), intent(in) :: var (:,:,:,:,:) integer, intent(in), optional :: pelist(:) real(8), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r8_5d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r8_5d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r8_5d # 179 "../mpp/include/mpp_comm.inc" 2 # 228 # 1 "../mpp/include/mpp_chksum_scalar.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_0d( var, pelist, mask_val ) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !mold and mask_val must be same numBytes, otherwise undefined behavior integer(8) :: mpp_chksum_r4_0d real(4), intent(in) :: var integer, intent(in), optional :: pelist(:) integer(8) :: mold(1) real(4), intent(in), optional :: mask_val pointer( p, mold ) p = LOC(var) if ( PRESENT(mask_val) ) then mpp_chksum_r4_0d = mpp_chksum( mold, pelist, TRANSFER(mask_val, mold(1)) ) else mpp_chksum_r4_0d = mpp_chksum( mold, pelist ) end if return end function mpp_chksum_r4_0d # 238 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_1d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r4_1d integer(8) :: mold(1) real(4), intent(in) :: var (:) integer, intent(in), optional :: pelist(:) real(4), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r4_1d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r4_1d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r4_1d # 246 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_2d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r4_2d integer(8) :: mold(1) real(4), intent(in) :: var (:,:) integer, intent(in), optional :: pelist(:) real(4), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r4_2d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r4_2d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r4_2d # 254 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_3d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r4_3d integer(8) :: mold(1) real(4), intent(in) :: var (:,:,:) integer, intent(in), optional :: pelist(:) real(4), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r4_3d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r4_3d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r4_3d # 262 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_4d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r4_4d integer(8) :: mold(1) real(4), intent(in) :: var (:,:,:,:) integer, intent(in), optional :: pelist(:) real(4), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r4_4d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r4_4d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r4_4d # 270 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_chksum.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** function mpp_chksum_r4_5d( var, pelist , mask_val) !mold is a dummy array to be used by TRANSFER() !must be same TYPE as result !result is 8, which will actually be int ifdef no_8byte_integers !optional mask_val is masked away in checksum_int.h function via PACK() integer(8) :: mpp_chksum_r4_5d integer(8) :: mold(1) real(4), intent(in) :: var (:,:,:,:,:) integer, intent(in), optional :: pelist(:) real(4), intent(in),optional :: mask_val if ( PRESENT(mask_val) ) then mpp_chksum_r4_5d = mpp_chksum( TRANSFER(var,mold), pelist, & mask_val= TRANSFER(mask_val,mold(1) ) ) else mpp_chksum_r4_5d = mpp_chksum( TRANSFER(var,mold), pelist ) end if return end function mpp_chksum_r4_5d # 278 "../mpp/include/mpp_comm.inc" 2 # 328 !################################################# # 1 "../mpp/include/mpp_gather.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_gather_logical_1d(sbuf, rbuf,pelist) ! JWD: Did not create mpp_gather_2d because have no requirement for it ! JWD: See mpp_gather_2dv below logical, dimension(:), intent(in) :: sbuf logical, dimension(:), intent(inout) :: rbuf integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) cnt = size(sbuf(:)) if(size(rbuf(:)) < cnt*nproc) call mpp_error(FATAL, & "MPP_GATHER_1D_: size(rbuf) must be at least npes*size(sbuf) ") !--- pre-post receiving if(pe == op_root) then rbuf(1:cnt) = sbuf do l = 2, nproc call mpp_recv(rbuf((l-1)*cnt+1), glen=cnt, from_pe=pelist2(l), block=.FALSE., tag=COMM_TAG_1 ) enddo else call mpp_send(sbuf(1), plen=cnt, to_pe=op_root, tag=COMM_TAG_1) endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_logical_1d subroutine mpp_gather_logical_1dv(sbuf, ssize, rbuf, rsize, pelist) logical, dimension(:), intent(in) :: sbuf logical, dimension(:), intent(inout) :: rbuf integer, intent(in) :: ssize integer, dimension(:), intent(in) :: rsize integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, pos, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=0+root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) !--- pre-post receiving if (pe .eq. op_root) then pos = 1 do l = 1,nproc ! include op_root to simplify logic if (rsize(l) == 0) then cycle ! avoid ranks with no data endif call mpp_recv(rbuf(pos),glen=rsize(l),from_pe=pelist2(l), & block=.FALSE.,tag=COMM_TAG_2) pos = pos + rsize(l) enddo endif if (ssize .gt. 0) then call mpp_send(sbuf(1),plen=ssize,to_pe=op_root,tag=COMM_TAG_2) !avoid ranks with no data endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_logical_1dv subroutine mpp_gather_pelist_logical_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist logical, dimension(is:ie,js:je), intent(in) :: array_seg logical, dimension(:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift logical :: arr3D(size(array_seg,1),size(array_seg,2),1) logical :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_gather_pelist_logical_2d subroutine mpp_gather_pelist_logical_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist logical, dimension(is:ie,js:je,1:nk), intent(in) :: array_seg logical, dimension(:,:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D logical, dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(:), allocatable :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! gather indices into global index on root_pe if (is_root_pe) then allocate(temp(1:size(pelist))) do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! gather segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) ! unbuffer/copy the data into the return array do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) deallocate(temp(i)%data) endif enddo deallocate(temp) else ! non root_pe's send data to root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_send(array_seg, msgsize, root_pe, COMM_TAG_2) call mpp_sync_self(check=EVENT_SEND) endif call mpp_sync_self() return end subroutine mpp_gather_pelist_logical_3d # 342 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_gather.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_gather_int4_1d(sbuf, rbuf,pelist) ! JWD: Did not create mpp_gather_2d because have no requirement for it ! JWD: See mpp_gather_2dv below integer(4), dimension(:), intent(in) :: sbuf integer(4), dimension(:), intent(inout) :: rbuf integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) cnt = size(sbuf(:)) if(size(rbuf(:)) < cnt*nproc) call mpp_error(FATAL, & "MPP_GATHER_1D_: size(rbuf) must be at least npes*size(sbuf) ") !--- pre-post receiving if(pe == op_root) then rbuf(1:cnt) = sbuf do l = 2, nproc call mpp_recv(rbuf((l-1)*cnt+1), glen=cnt, from_pe=pelist2(l), block=.FALSE., tag=COMM_TAG_1 ) enddo else call mpp_send(sbuf(1), plen=cnt, to_pe=op_root, tag=COMM_TAG_1) endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_int4_1d subroutine mpp_gather_int4_1dv(sbuf, ssize, rbuf, rsize, pelist) integer(4), dimension(:), intent(in) :: sbuf integer(4), dimension(:), intent(inout) :: rbuf integer, intent(in) :: ssize integer, dimension(:), intent(in) :: rsize integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, pos, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=0+root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) !--- pre-post receiving if (pe .eq. op_root) then pos = 1 do l = 1,nproc ! include op_root to simplify logic if (rsize(l) == 0) then cycle ! avoid ranks with no data endif call mpp_recv(rbuf(pos),glen=rsize(l),from_pe=pelist2(l), & block=.FALSE.,tag=COMM_TAG_2) pos = pos + rsize(l) enddo endif if (ssize .gt. 0) then call mpp_send(sbuf(1),plen=ssize,to_pe=op_root,tag=COMM_TAG_2) !avoid ranks with no data endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_int4_1dv subroutine mpp_gather_pelist_int4_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist integer(4), dimension(is:ie,js:je), intent(in) :: array_seg integer(4), dimension(:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer(4) :: arr3D(size(array_seg,1),size(array_seg,2),1) integer(4) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_gather_pelist_int4_2d subroutine mpp_gather_pelist_int4_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist integer(4), dimension(is:ie,js:je,1:nk), intent(in) :: array_seg integer(4), dimension(:,:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D integer(4), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(:), allocatable :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! gather indices into global index on root_pe if (is_root_pe) then allocate(temp(1:size(pelist))) do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! gather segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) ! unbuffer/copy the data into the return array do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) deallocate(temp(i)%data) endif enddo deallocate(temp) else ! non root_pe's send data to root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_send(array_seg, msgsize, root_pe, COMM_TAG_2) call mpp_sync_self(check=EVENT_SEND) endif call mpp_sync_self() return end subroutine mpp_gather_pelist_int4_3d # 354 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_gather.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_gather_real4_1d(sbuf, rbuf,pelist) ! JWD: Did not create mpp_gather_2d because have no requirement for it ! JWD: See mpp_gather_2dv below real(4), dimension(:), intent(in) :: sbuf real(4), dimension(:), intent(inout) :: rbuf integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) cnt = size(sbuf(:)) if(size(rbuf(:)) < cnt*nproc) call mpp_error(FATAL, & "MPP_GATHER_1D_: size(rbuf) must be at least npes*size(sbuf) ") !--- pre-post receiving if(pe == op_root) then rbuf(1:cnt) = sbuf do l = 2, nproc call mpp_recv(rbuf((l-1)*cnt+1), glen=cnt, from_pe=pelist2(l), block=.FALSE., tag=COMM_TAG_1 ) enddo else call mpp_send(sbuf(1), plen=cnt, to_pe=op_root, tag=COMM_TAG_1) endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_real4_1d subroutine mpp_gather_real4_1dv(sbuf, ssize, rbuf, rsize, pelist) real(4), dimension(:), intent(in) :: sbuf real(4), dimension(:), intent(inout) :: rbuf integer, intent(in) :: ssize integer, dimension(:), intent(in) :: rsize integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, pos, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=0+root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) !--- pre-post receiving if (pe .eq. op_root) then pos = 1 do l = 1,nproc ! include op_root to simplify logic if (rsize(l) == 0) then cycle ! avoid ranks with no data endif call mpp_recv(rbuf(pos),glen=rsize(l),from_pe=pelist2(l), & block=.FALSE.,tag=COMM_TAG_2) pos = pos + rsize(l) enddo endif if (ssize .gt. 0) then call mpp_send(sbuf(1),plen=ssize,to_pe=op_root,tag=COMM_TAG_2) !avoid ranks with no data endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_real4_1dv subroutine mpp_gather_pelist_real4_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist real(4), dimension(is:ie,js:je), intent(in) :: array_seg real(4), dimension(:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift real(4) :: arr3D(size(array_seg,1),size(array_seg,2),1) real(4) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_gather_pelist_real4_2d subroutine mpp_gather_pelist_real4_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist real(4), dimension(is:ie,js:je,1:nk), intent(in) :: array_seg real(4), dimension(:,:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D real(4), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(:), allocatable :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! gather indices into global index on root_pe if (is_root_pe) then allocate(temp(1:size(pelist))) do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! gather segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) ! unbuffer/copy the data into the return array do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) deallocate(temp(i)%data) endif enddo deallocate(temp) else ! non root_pe's send data to root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_send(array_seg, msgsize, root_pe, COMM_TAG_2) call mpp_sync_self(check=EVENT_SEND) endif call mpp_sync_self() return end subroutine mpp_gather_pelist_real4_3d # 366 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_gather.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_gather_real8_1d(sbuf, rbuf,pelist) ! JWD: Did not create mpp_gather_2d because have no requirement for it ! JWD: See mpp_gather_2dv below real(8), dimension(:), intent(in) :: sbuf real(8), dimension(:), intent(inout) :: rbuf integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) cnt = size(sbuf(:)) if(size(rbuf(:)) < cnt*nproc) call mpp_error(FATAL, & "MPP_GATHER_1D_: size(rbuf) must be at least npes*size(sbuf) ") !--- pre-post receiving if(pe == op_root) then rbuf(1:cnt) = sbuf do l = 2, nproc call mpp_recv(rbuf((l-1)*cnt+1), glen=cnt, from_pe=pelist2(l), block=.FALSE., tag=COMM_TAG_1 ) enddo else call mpp_send(sbuf(1), plen=cnt, to_pe=op_root, tag=COMM_TAG_1) endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_real8_1d subroutine mpp_gather_real8_1dv(sbuf, ssize, rbuf, rsize, pelist) real(8), dimension(:), intent(in) :: sbuf real(8), dimension(:), intent(inout) :: rbuf integer, intent(in) :: ssize integer, dimension(:), intent(in) :: rsize integer, dimension(:), intent(in), optional :: pelist(:) integer :: cnt, l, nproc, pos, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be ! the operation root if(PRESENT(pelist))then nproc = size(pelist) allocate(pelist2(nproc)) pelist2 = pelist else nproc = mpp_npes() allocate(pelist2(nproc)) pelist2 = (/ (l, l=0+root_pe, nproc-1+root_pe) /) endif op_root = pelist2(1) !--- pre-post receiving if (pe .eq. op_root) then pos = 1 do l = 1,nproc ! include op_root to simplify logic if (rsize(l) == 0) then cycle ! avoid ranks with no data endif call mpp_recv(rbuf(pos),glen=rsize(l),from_pe=pelist2(l), & block=.FALSE.,tag=COMM_TAG_2) pos = pos + rsize(l) enddo endif if (ssize .gt. 0) then call mpp_send(sbuf(1),plen=ssize,to_pe=op_root,tag=COMM_TAG_2) !avoid ranks with no data endif call mpp_sync_self(check=EVENT_RECV) call mpp_sync_self() deallocate(pelist2) end subroutine mpp_gather_real8_1dv subroutine mpp_gather_pelist_real8_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist real(8), dimension(is:ie,js:je), intent(in) :: array_seg real(8), dimension(:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift real(8) :: arr3D(size(array_seg,1),size(array_seg,2),1) real(8) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_gather_pelist_real8_2d subroutine mpp_gather_pelist_real8_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist real(8), dimension(is:ie,js:je,1:nk), intent(in) :: array_seg real(8), dimension(:,:,:), intent(inout) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D real(8), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(:), allocatable :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_gather_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! gather indices into global index on root_pe if (is_root_pe) then allocate(temp(1:size(pelist))) do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! gather segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) ! unbuffer/copy the data into the return array do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) deallocate(temp(i)%data) endif enddo deallocate(temp) else ! non root_pe's send data to root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_send(array_seg, msgsize, root_pe, COMM_TAG_2) call mpp_sync_self(check=EVENT_SEND) endif call mpp_sync_self() return end subroutine mpp_gather_pelist_real8_3d # 378 "../mpp/include/mpp_comm.inc" 2 !################################################# # 1 "../mpp/include/mpp_scatter.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_scatter_pelist_int4_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist integer(4), dimension(is:ie,js:je), intent(inout) :: array_seg integer(4), dimension(:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer(4) :: arr3D(size(array_seg,1),size(array_seg,2),1) integer(4) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_scatter_pelist_int4_2d subroutine mpp_scatter_pelist_int4_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist integer(4), dimension(is:ie,js:je,1:nk), intent(inout) :: array_seg integer(4), dimension(:,:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D integer(4), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(size(pelist)) :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! scatter indices into global index on root_pe if (is_root_pe) then do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_scatter_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! scatter segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk ! allocate and copy data into a contiguous memory space allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) temp(i)%data(i1:i2,j1:j2,1:nk)=data(i1:i2,j1:j2,1:nk) call mpp_send(temp(i)%data, msgsize, pelist(i), COMM_TAG_2) else ! data copy - no send to self array_seg(is:ie,js:je,1:nk) = data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) endif enddo call mpp_sync_self(check=EVENT_SEND) ! deallocate the temporary array used for the send do i = 1, size(pelist) if (allocated(temp(i)%data)) deallocate(temp(i)%data) enddo else ! non root_pe's recv data from root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_recv(array_seg, msgsize, root_pe, .FALSE., COMM_TAG_2) call mpp_sync_self(check=EVENT_RECV) endif call mpp_sync_self() return end subroutine mpp_scatter_pelist_int4_3d # 387 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_scatter.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_scatter_pelist_real4_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist real(4), dimension(is:ie,js:je), intent(inout) :: array_seg real(4), dimension(:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift real(4) :: arr3D(size(array_seg,1),size(array_seg,2),1) real(4) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_scatter_pelist_real4_2d subroutine mpp_scatter_pelist_real4_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist real(4), dimension(is:ie,js:je,1:nk), intent(inout) :: array_seg real(4), dimension(:,:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D real(4), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(size(pelist)) :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! scatter indices into global index on root_pe if (is_root_pe) then do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_scatter_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! scatter segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk ! allocate and copy data into a contiguous memory space allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) temp(i)%data(i1:i2,j1:j2,1:nk)=data(i1:i2,j1:j2,1:nk) call mpp_send(temp(i)%data, msgsize, pelist(i), COMM_TAG_2) else ! data copy - no send to self array_seg(is:ie,js:je,1:nk) = data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) endif enddo call mpp_sync_self(check=EVENT_SEND) ! deallocate the temporary array used for the send do i = 1, size(pelist) if (allocated(temp(i)%data)) deallocate(temp(i)%data) enddo else ! non root_pe's recv data from root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_recv(array_seg, msgsize, root_pe, .FALSE., COMM_TAG_2) call mpp_sync_self(check=EVENT_RECV) endif call mpp_sync_self() return end subroutine mpp_scatter_pelist_real4_3d # 395 "../mpp/include/mpp_comm.inc" 2 # 1 "../mpp/include/mpp_scatter.h" 1 !*********************************************************************** !* GNU Lesser General Public License !* !* This file is part of the GFDL Flexible Modeling System (FMS). !* !* FMS is free software: you can redistribute it and/or modify it under !* the terms of the GNU Lesser General Public License as published by !* the Free Software Foundation, either version 3 of the License, or (at !* your option) any later version. !* !* FMS is distributed in the hope that it will be useful, but WITHOUT !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License !* for more details. !* !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** subroutine mpp_scatter_pelist_real8_2d(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist real(8), dimension(is:ie,js:je), intent(inout) :: array_seg real(8), dimension(:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift real(8) :: arr3D(size(array_seg,1),size(array_seg,2),1) real(8) :: data3D(size( data,1),size( data,2),1) pointer( aptr, arr3D ) pointer( dptr, data3D ) aptr = LOC(array_seg) dptr = LOC( data) call mpp_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) return end subroutine mpp_scatter_pelist_real8_2d subroutine mpp_scatter_pelist_real8_3d(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist real(8), dimension(is:ie,js:je,1:nk), intent(inout) :: array_seg real(8), dimension(:,:,:), intent(in) :: data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift integer :: i, msgsize, root_pe, root_pe_test integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D real(8), dimension(:,:,:), allocatable :: data endtype array3D type(array3d), dimension(size(pelist)) :: temp if (.not.ANY(mpp_pe().eq.pelist(:))) return if (is_root_pe) then root_pe = mpp_pe() root_pe_test = 999 if (.not.ANY(pelist(:).eq.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not a member of pelist") else root_pe = 0 root_pe_test = -999 endif ! need this check in case MPI-rank 0 is a member of the pelist call mpp_max(root_pe_test, pelist) if (root_pe_test.lt.0) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): root_pe not specified or not a member of the pelist") ! need to make sure only one root_pe has been specified call mpp_sum(root_pe, pelist) if ((is_root_pe) .and. (mpp_pe().ne.root_pe)) call mpp_error(FATAL, & "fms_io(mpp_scatter_pelist): too many root_pes specified") ioff=0 joff=0 if (present(ishift)) ioff=ishift if (present(jshift)) joff=jshift my_ind(1) = is my_ind(2) = ie my_ind(3) = js my_ind(4) = je ! scatter indices into global index on root_pe if (is_root_pe) then do i = 1, size(pelist) ! root_pe data copy - no send to self if (pelist(i).eq.root_pe) then gind(:,i) = my_ind(:) else call mpp_recv(gind(:,i:i), 4, pelist(i), .FALSE., COMM_TAG_1) endif enddo call mpp_sync_self(check=EVENT_RECV) gind(1,:)=gind(1,:)+ioff gind(2,:)=gind(2,:)+ioff gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & call mpp_error(FATAL,"fms_io(mpp_scatter_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else ! non root_pe's send indices to root_pe call mpp_send(my_ind(:), 4, root_pe, COMM_TAG_1) call mpp_sync_self(check=EVENT_SEND) endif ! scatter segments into data based on indices if (is_root_pe) then do i = 1, size(pelist) if (pelist(i).ne.root_pe) then ! no send to self i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk ! allocate and copy data into a contiguous memory space allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) temp(i)%data(i1:i2,j1:j2,1:nk)=data(i1:i2,j1:j2,1:nk) call mpp_send(temp(i)%data, msgsize, pelist(i), COMM_TAG_2) else ! data copy - no send to self array_seg(is:ie,js:je,1:nk) = data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) endif enddo call mpp_sync_self(check=EVENT_SEND) ! deallocate the temporary array used for the send do i = 1, size(pelist) if (allocated(temp(i)%data)) deallocate(temp(i)%data) enddo else ! non root_pe's recv data from root_pe msgsize = (my_ind(2)-my_ind(1)+1) * (my_ind(4)-my_ind(3)+1) * nk call mpp_recv(array_seg, msgsize, root_pe, .FALSE., COMM_TAG_2) call mpp_sync_self(check=EVENT_RECV) endif call mpp_sync_self() return end subroutine mpp_scatter_pelist_real8_3d # 403 "../mpp/include/mpp_comm.inc" 2 # 1398 "../mpp/mpp.F90" 2 end module mpp_mod